reduce-historical/psl-1983/util/program-command-interpreter.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Program-Command-Interpreter.SL - Perform Program Command
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        10 August 1982
% Revised:     8 December 1982
%
% 8-Dec-82 Alan Snyder
%   Changed use of DSKIN (now an EXPR).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% This file redefines the start-up routine for PSL (Lisp Reader) to first read
% and interpret the program command string.  If the command string contains a
% recognized command name, then the corresponding function is immediately
% executed and the program QUITs.  Otherwise, the normal top-level function
% definition is restored and invoked as normal.  Commands are defined using the
% property PROGRAM-COMMAND (see below).  This file defines only one command,
% COMPILE, which is used to compile Lisp files (not RLisp files).

(BothTimes (load common))
(load parse-command-string get-command-string compiler)

(fluid '(*usermode *redefmsg CurrentReadMacroIndicator* CurrentScanTable*))

(cond ((funboundp 'original-main)
       (copyd 'original-main 'main)))

(de main ()
  (let ((CurrentReadMacroIndicator* 'LispReadMacro) % Crock!
	(CurrentScanTable* LispScanTable*)
	(c-list (parse-command-string (get-command-string)))
	(*usermode nil)
	(*redefmsg nil))
       (perform-program-command c-list)
       (copyd 'main 'original-main)
       )
  (original-main)
  )

(de perform-program-command (c-list)
  (if (not (Null c-list))
      (let ((command (car c-list)))
	   (if (StringP command)
	       (let* ((command-id (intern (string-upcase command)))
		      (func (get command-id 'PROGRAM-COMMAND)))
		     (if func (apply func (list c-list))))))))

(put 'COMPILE 'PROGRAM-COMMAND 'compile-program-command)

(fluid '(*quiet_faslout *WritingFASLFile))

(de compile-program-command (c-list)
  (setq c-list (cdr c-list))
  (for (in file-name-root c-list)
       (do (let* ((form (list 'COMPILE-FILE file-name-root))
		  (*break NIL)
		  (result (ErrorSet form T NIL))
		  )
	     (if (FixP result)
	         (progn
		   (if *WritingFASLFile (faslend))
	           (printf "%n ***** Error during compilation of %w.%n"
		           file-name-root)
	           ))
	     )))
  (quit))

(de compile-file (file-name-root)
  (let ((source-fn (string-concat file-name-root ".SL"))
	(binary-fn (string-concat file-name-root ".B"))
	(*quiet_faslout T)
	)
       (if (not (FileP source-fn))
	   (printf "Unable to open source file: %w%n" source-fn)
	   % else
	   (printf "%n----- Compiling %w%n" source-fn binary-fn)
	   (faslout file-name-root)
	   (dskin source-fn)
	   (faslend)
	   (printf "%nDone compiling %w%n%n" source-fn)
	   )))