(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "19-Oct-93 10:41:17" "{Pele:mv:envos}Sources>CLTL2>XCLC-TOP-LEVEL.;2" 89121 IL:|previous| IL:|date:| "15-Dec-92 21:18:47" "{Pele:mv:envos}Sources>CLTL2>XCLC-TOP-LEVEL.;1") ; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-TOP-LEVELCOMS) (IL:RPAQQ IL:XCLC-TOP-LEVELCOMS ( (IL:* IL:|;;| "Top-level entry points") (IL:STRUCTURES COMPILER-CONTEXT) (IL:VARIABLES *COMPILE-FILE-CONTEXT* *COMPILE-SCAN-CONTEXT* *COMPILE-DEFINER-CONTEXT*) (IL:FUNCTIONS COMPILER-ERROR) (IL:FUNCTIONS COMPILER-APPLY) (IL:FUNCTIONS COMPILER-WARNING COMPILER-CERROR BUMP-DIAGNOSTIC-COUNT COMPILATION-VALUES) (IL:FUNCTIONS WITH-COMPILATION-UNIT) (IL:VARIABLES *EVAL-WHEN-COMPILE* *FASL-HANDLE* *INPUT-FILENAME* *INPUT-STREAM* *LAP-STREAM* *LOAD-COMPILED-CODE* *NEW-COMPILER-IS-EXPANDING* *OUTSTANDING-LOOSE-FORMS* *COMPILING-DEFINER* *LOOSE-NAME* *COMPILE-VERBOSE* *COMPILE-PRINT* *ANY-DIAGNOSTICS* *ANY-SERIOUS-DIAGNOSTICS*) (IL:VARIABLES *COMPILE-FILE-PATHNAME* *COMPILE-FILE-TRUENAME*) (IL:FUNCTIONS COMPILE-FILE COMPILE-FILE-PATHNAME) (IL:FUNCTIONS START-COMPILATION FINISH-COMPILATION) (IL:FUNCTIONS SCAN-ONE-FORM FUNCTION-P) (IL:FUNCTIONS COMPILER-MESSAGE COMPILING-MESSAGE DONE-MESSAGE) (IL:COMS (IL:STRUCTURES STYLE-WARNING UNKNOWN-FUNCTION-WARNING) (IL:FUNCTIONS STYLE-WARN CHECK-FOR-UNKNOWN-FUNCTION CHECK-FOR-UNKNOWN-SETF WARN-ABOUT-UNKNOWN-FUNCTIONS)) (IL:VARIABLES *PROCESSED-FUNCTIONS* *UNKNOWN-FUNCTIONS* *CURRENT-FUNCTION*) (IL:COMS (IL:STRUCTURES ASSEMBLER-ERROR) (IL:FUNCTIONS ASSEMBLER-ERROR)) (IL:* IL:|;;| "Reading the #, macro") (IL:VARIABLES *COMPILER-IS-READING*) (IL:STRUCTURES EVAL-WHEN-LOAD) (IL:* IL:|;;| "Support for Block Compilation") (IL:VARIABLES *BLOCK-HASH-TABLE* *BLOCKS* *CURRENT-BLOCK*) (IL:STRUCTURES BLOCK-DECL) (IL:FUNCTIONS SET-UP-BLOCK-DECLS) (IL:* IL:|;;| "Processing of top-level forms in a file") (IL:VARIABLES PASS) (IL:FUNCTIONS CONSTANT-EXPRESSION-P) (IL:FUNCTIONS COMPILE-AND-DUMP COMPILE-AND-DUMP-1 COMPILE-ONE-LAMBDA) (IL:FUNCTIONS OPTIMIZE-AND-MACROEXPAND OPTIMIZE-AND-MACROEXPAND-1 EXPAND-DEFINER PROCESS-FORMS) (IL:FUNCTIONS MAYBE-REMOVE-COMMENTS) (IL:FUNCTIONS COMPILE-FILE-SETF-SYMBOL-FUNCTION COMPILE-FILE-DEFINEQ COMPILE-FILE-DEFCONSTANT COMPILE-FILE-DECLARE\: COMPILE-FILE-DEFINE-FILE-INFO COMPILE-FILE-PACKAGE-FORM COMPILE-FILE-PROCLAMATION COMPILE-FILE-COMPILER-LET COMPILE-FILE-MACROLET COMPILE-FILE-DEFINER COMPILE-FILE-NAMED-PROGN COMPILE-FILE-OUTSTANDING-LOOSE-FORMS COMPILE-FILE-LOOSE-FORM COMPILE-FILE-PROCESS-FUNCTION) (IL:FUNCTIONS CRACK-DEFMACRO ESTABLISH-MACRO-IN-COMPILER) (IL:* IL:|;;| "Support for :Process-Entire-File") (IL:VARIABLES *DEFERRED-FORMS* *MAKING-SECOND-PASS* *PREPROCESSING-PHASE*) (IL:FUNCTIONS COMPILE-SCAN-DECLARE\: COMPILE-SCAN-DEFINE-FILE-INFO COMPILE-SCAN-MACROLET COMPILE-SCAN-DEFINER COMPILE-SCAN-LOOSE-FORM COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS) (IL:FUNCTIONS MERGE-FIRST-FORMS) (IL:* IL:|;;| "for compiling definers") (IL:VARIABLES *LAP-FLG* *AUTOMATIC-SPECIAL-DECLARATIONS*) (IL:FUNCTIONS COMPILE COMPILE-SYMBOL-FUNCTION COMPILE-DEFINER) (IL:FUNCTIONS COMPILE-FORM RAW-COMPILE) (IL:FUNCTIONS COMPILE-DEFINER-DEFINER COMPILE-DEFINER-NAMED-PROGN COMPILE-DEFINER-PROCESS-FUNCTION COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS) (IL:* IL:|;;| "Arrange for correct compiler to be used.") (IL:PROP IL:FILETYPE IL:XCLC-TOP-LEVEL) (IL:* IL:|;;| "Arrange for the correct makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-TOP-LEVEL))) (IL:* IL:|;;| "Top-level entry points") (DEFSTRUCT (COMPILER-CONTEXT (:FAST-ACCESSORS T) (:CONC-NAME NIL) (:COPIER NIL) (:PREDICATE NIL)) SETF-SYMBOL-FUNCTION-FN DEFINEQ-FN DEFCONSTANT-FN DECLARE\:-FN DEFINE-FILE-INFO-FN PACKAGE-FORM-FN PROCLAIM-FN COMPILER-LET-FN MACROLET-FN DEFINER-FN NAMED-PROGN-FN PROCESS-FUNCTION-FN PROCESS-LOOSE-FORM-FN PROCESS-OUTSTANDING-LOOSE-FORMS-FN) (DEFPARAMETER *COMPILE-FILE-CONTEXT* (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-FILE-SETF-SYMBOL-FUNCTION :DEFINEQ-FN 'COMPILE-FILE-DEFINEQ :DEFCONSTANT-FN 'COMPILE-FILE-DEFCONSTANT :DECLARE\:-FN 'COMPILE-FILE-DECLARE\: :DEFINE-FILE-INFO-FN 'COMPILE-FILE-DEFINE-FILE-INFO :PACKAGE-FORM-FN 'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION :COMPILER-LET-FN 'COMPILE-FILE-COMPILER-LET :MACROLET-FN 'COMPILE-FILE-MACROLET :DEFINER-FN 'COMPILE-FILE-DEFINER :NAMED-PROGN-FN 'COMPILE-FILE-NAMED-PROGN :PROCESS-FUNCTION-FN 'COMPILE-FILE-PROCESS-FUNCTION :PROCESS-LOOSE-FORM-FN 'COMPILE-FILE-LOOSE-FORM :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-FILE-OUTSTANDING-LOOSE-FORMS)) (DEFPARAMETER *COMPILE-SCAN-CONTEXT* (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-SCAN-LOOSE-FORM :DEFINEQ-FN 'COMPILE-SCAN-LOOSE-FORM :DEFCONSTANT-FN 'COMPILE-SCAN-LOOSE-FORM :DECLARE\:-FN 'COMPILE-SCAN-DECLARE\: :DEFINE-FILE-INFO-FN 'COMPILE-SCAN-DEFINE-FILE-INFO :PACKAGE-FORM-FN 'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION :COMPILER-LET-FN 'COMPILE-SCAN-LOOSE-FORM :MACROLET-FN 'COMPILE-SCAN-MACROLET :DEFINER-FN 'COMPILE-SCAN-DEFINER :NAMED-PROGN-FN 'COMPILE-SCAN-LOOSE-FORM :PROCESS-FUNCTION-FN 'COMPILER-ERROR :PROCESS-LOOSE-FORM-FN 'COMPILE-SCAN-LOOSE-FORM :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS)) (DEFPARAMETER *COMPILE-DEFINER-CONTEXT* (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-FILE-SETF-SYMBOL-FUNCTION :DEFINEQ-FN 'COMPILE-FILE-DEFINEQ :DEFCONSTANT-FN 'COMPILE-FILE-DEFCONSTANT :DECLARE\:-FN 'COMPILER-ERROR :DEFINE-FILE-INFO-FN 'COMPILER-ERROR :PACKAGE-FORM-FN 'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION :COMPILER-LET-FN 'COMPILE-FILE-COMPILER-LET :MACROLET-FN 'COMPILE-FILE-MACROLET :DEFINER-FN 'COMPILE-DEFINER-DEFINER :NAMED-PROGN-FN 'COMPILE-DEFINER-NAMED-PROGN :PROCESS-FUNCTION-FN 'COMPILE-DEFINER-PROCESS-FUNCTION :PROCESS-LOOSE-FORM-FN 'COMPILE-FILE-LOOSE-FORM :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS)) (DEFUN COMPILER-ERROR (COMPILER-CONTEXT &REST ARGS) (ERROR "Unexpected compiler error. Context is ~s args are ~s" COMPILER-CONTEXT ARGS)) (DEFMACRO COMPILER-APPLY (KEY COMPILER-CONTEXT &OPTIONAL FORM &REST OTHER-ARGS) (LET ((ACCESSOR (INTERN (CONCATENATE 'STRING (STRING KEY) "-FN") (FIND-PACKAGE "COMPILER")))) (IF FORM `(FUNCALL (,ACCESSOR ,COMPILER-CONTEXT) ,COMPILER-CONTEXT ,FORM ,@OTHER-ARGS) `(FUNCALL (,ACCESSOR ,COMPILER-CONTEXT) ,COMPILER-CONTEXT)))) (DEFMACRO COMPILER-WARNING (&REST ARGS) `(PROGN (INCF *ANY-DIAGNOSTICS*) (STYLE-WARN ,@ARGS))) (DEFMACRO COMPILER-CERROR (&REST ARGS) `(PROGN (INCF *ANY-SERIOUS-DIAGNOSTICS*) (INCF *ANY-DIAGNOSTICS*) (CERROR ,@ARGS))) (DEFMACRO BUMP-DIAGNOSTIC-COUNT (FORM) (IL:* IL:|;;|  "A trivial hack to bump the diagnostic count returned by some other part of the compiler ") `(MULTIPLE-VALUE-BIND (NAME DIAGS SERIOUS) ,FORM (VALUES NAME (IF DIAGS (1+ DIAGS) 1) SERIOUS))) (DEFMACRO COMPILATION-VALUES (VALUE) `(VALUES ,VALUE (COND ((NOT (ZEROP *ANY-DIAGNOSTICS*)) *ANY-DIAGNOSTICS*)) (COND ((NOT (ZEROP *ANY-SERIOUS-DIAGNOSTICS*)) *ANY-SERIOUS-DIAGNOSTICS*)))) (DEFMACRO WITH-COMPILATION-UNIT ((&REST LISP::OPTION-LIST) &BODY LISP::FORMS) `(PROGN ,@LISP::FORMS)) (DEFVAR *EVAL-WHEN-COMPILE* NIL "Bound to T during processing of forms to be evaluated at compile-time.") (DEFVAR *FASL-HANDLE* NIL "Handle used for writing out the code to a FASL file.") (DEFVAR *INPUT-FILENAME* NIL "Full name of the file being compiled.") (DEFVAR *INPUT-STREAM* NIL "Stream from which compile-file reads forms.") (DEFVAR *LAP-STREAM* NIL "Stream to which compile-file writes LAP output.") (DEFVAR *LOAD-COMPILED-CODE* NIL "Non-nil if new compiled code should be installed in running Lisp. :save if old versions should be saved on the property list before installing") (DEFVAR *NEW-COMPILER-IS-EXPANDING* NIL "Bound to T whenever the new compiler might be expanding macros. Used in some optimizers to let them only take effect in the new compiler." ) (DEFVAR *OUTSTANDING-LOOSE-FORMS* NIL "A list of the random top-level forms to be gathered together into a single lambda for compilation.") (DEFVAR *COMPILING-DEFINER* NIL) (DEFVAR *LOOSE-NAME* NIL) (DEFVAR *COMPILE-VERBOSE* NIL) (DEFVAR *COMPILE-PRINT* T) (DEFVAR *ANY-DIAGNOSTICS* NIL) (DEFVAR *ANY-SERIOUS-DIAGNOSTICS* NIL) (DEFVAR *COMPILE-FILE-PATHNAME* NIL "Pathname of file being compiled") (DEFVAR *COMPILE-FILE-TRUENAME* NIL "Truename of file being compiled") (DEFUN COMPILE-FILE (INPUT-FILE &KEY (OUTPUT-FILE NIL) (LAP-FILE NIL) (ERROR-FILE NIL) (ERRORS-TO-TERMINAL T) (FILE-MANAGER-FORMAT NIL F-M-F-GIVEN) (PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN) (LOAD NIL) ((:VERBOSE *COMPILE-VERBOSE*) *COMPILE-VERBOSE*) ((:PRINT *COMPILE-PRINT*) *COMPILE-PRINT*) (PACKAGE NIL)) (IL:* IL:\;  "Edited 15-Dec-92 16:06 by jrb:") (IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.") (IL:* IL:|;;;| " :Output-File") (IL:* IL:|;;| "The name of a file to which binary code should be written.") (IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'") (IL:* IL:|;;;| ":Lap-File") (IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.") (IL:* IL:|;;|  " If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.") (IL:* IL:|;;;| ":Error-FIle") (IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'") (IL:* IL:|;;;| ":Errors-To-Terminal") (IL:* IL:|;;|  "True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.") (IL:* IL:|;;;| ":File-Manager-Format") (IL:* IL:|;;|  "True if the file should be assumed to have been produced by the MAKEFILE function.") (IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.") (IL:* IL:|;;;| ":Process-Entire-File") (IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (COMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.") (IL:* IL:|;;;| ":Load") (IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.") (IL:* IL:|;;;| ":Verbose") (IL:* IL:|;;| "Controls *COMPILE-VERBOSE*, which controls the printing of a banner on *STANDARD-OUTPUT* desfribing the file being compiled.") (IL:* IL:|;;;| ":Print") (IL:* IL:|;;| " Controls *COMPILE-PRINT*, which controls the printing of per-form compilation messages to *STANDARD-OUTPUT*") (IL:* IL:|;;;| ":Package") (IL:* IL:|;;|  "Controls the default package for reading the source; similar to the :PACKAGE keyword for :LOAD") (LET ((*ERROR-OUTPUT* *ERROR-OUTPUT*) (*INPUT-STREAM* NIL) (*INPUT-FILENAME* NIL) (*FASL-HANDLE* NIL) (FASL-PATHNAME NIL) (*LAP-STREAM* NIL) (*COMPILE-FILE-PATHNAME*) (*COMPILE-FILE-TRUENAME*) (ERROR-FILE-STREAM NIL) (COMPILATION-SUCCEEDED NIL) (*LOAD-COMPILED-CODE* LOAD) (*CONTEXT* (MAKE-CONTEXT :TOP-LEVEL-P T :VALUES-USED 0)) (*ENVIRONMENT* (MAKE-ENV :PARENT T)) (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE)) (*OUTSTANDING-LOOSE-FORMS* NIL) (*PROCESSED-FUNCTIONS* NIL) (*UNKNOWN-FUNCTIONS* NIL) (*ANY-DIAGNOSTICS* 0) (*ANY-SERIOUS-DIAGNOSTICS* 0) (*INPUT-FILECOMS-VARIABLE* NIL) (IL:* IL:\;  "Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.") (IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.") (IL:SPECVARS T) (IL:LOCALVARS IL:SYSLOCALVARS) (IL:LOCALFREEVARS NIL) (IL:GLOBALVARS IL:GLOBALVARS) (IL:NLAMA IL:NLAMA) (IL:NLAML IL:NLAML) (IL:LAMA IL:LAMA) (IL:DONTCOMPILEFNS IL:DONTCOMPILEFNS)) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA IL:NLAML IL:LAMA IL:DONTCOMPILEFNS)) (UNWIND-PROTECT (PROGN (IL:* IL:|;;| "Set up the input stream.") (IL:* IL:|;;| "NOTE: If you change the handling of *INPUT-FILENAME* or *FASL-PATHNAME*, you also have to change COMPILE-FILE-PATHNAME to do the same thing.") (LET ((PATH (OR (PROBE-FILE INPUT-FILE) (PROBE-FILE (MERGE-PATHNAMES INPUT-FILE ".lisp"))))) (COND (PATH (SETQ *INPUT-FILENAME* PATH) (SETQ *INPUT-STREAM* (OPEN PATH :DIRECTION :INPUT)) (WHEN (AND (FBOUNDP 'IL:OPENTEXTSTREAM) (FBOUNDP 'IL:\\TEDIT.FORMATTEDP1) (IF (IL:RANDACCESSP *INPUT-STREAM*) (IL:\\TEDIT.FORMATTEDP1 *INPUT-STREAM*) (WITH-OPEN-FILE (TEMP-STREAM *INPUT-STREAM*) (IL:\\TEDIT.FORMATTEDP1 TEMP-STREAM)))) (SETQ *INPUT-STREAM* (IL:OPENTEXTSTREAM *INPUT-STREAM* NIL NIL NIL '(IL:READONLY T))))) (T (ERROR "The file \"~A\" is nonexistent or cannot be read.~%" INPUT-FILE ))) (SETQ *COMPILE-FILE-PATHNAME* PATH) (SETQ *COMPILE-FILE-TRUENAME* (TRUENAME PATH))) (IL:* IL:|;;| "Set up the FASL output stream.") (SETQ FASL-PATHNAME (COND (OUTPUT-FILE (PATHNAME OUTPUT-FILE)) (T (MAKE-PATHNAME :TYPE (STRING (LOCALLY (DECLARE (SPECIAL IL:FASL.EXT) ) IL:FASL.EXT)) :VERSION :NEWEST :DEFAULTS *INPUT-FILENAME*)))) (SETQ *FASL-HANDLE* (FASL:OPEN-FASL-HANDLE FASL-PATHNAME)) (IL:* IL:|;;| "Set up the LAP stream.") (WHEN LAP-FILE (SETQ *LAP-STREAM* (OPEN (IF (EQ LAP-FILE T) (MAKE-PATHNAME :TYPE "dlap" :VERSION :NEWEST :DEFAULTS *INPUT-FILENAME*) LAP-FILE) :DIRECTION :OUTPUT))) (IL:* IL:|;;| "Set up the error output stream.") (WHEN ERROR-FILE (SETQ ERROR-FILE-STREAM (OPEN (IF (EQ ERROR-FILE T) (MAKE-PATHNAME :TYPE "log" :VERSION :NEWEST :DEFAULTS *INPUT-FILENAME*) ERROR-FILE) :DIRECTION :OUTPUT))) (SETQ *ERROR-OUTPUT* (IF ERRORS-TO-TERMINAL (IF ERROR-FILE-STREAM (MAKE-BROADCAST-STREAM ERROR-FILE-STREAM *ERROR-OUTPUT*) *ERROR-OUTPUT*) ERROR-FILE-STREAM)) (IL:* IL:|;;|  "Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.") (IF (NOT F-M-F-GIVEN) (SETQ FILE-MANAGER-FORMAT (EQ (IL:SKIPSEPRCODES *INPUT-STREAM* IL:FILERDTBL) (IL:CHARCODE "(")))) (IF (NOT P-E-F-GIVEN) (SETQ PROCESS-ENTIRE-FILE FILE-MANAGER-FORMAT)) (IL:* IL:|;;| "Pick the right readtable and do the compilation.") (IL:WITH-READER-ENVIRONMENT (IF FILE-MANAGER-FORMAT IL:*OLD-INTERLISP-READ-ENVIRONMENT* IL:*COMMON-LISP-READ-ENVIRONMENT*) (IL:* IL:|;;| "If we have a FILE-MANAGER file and :PACKAGE is not specified, leave *PACKAGE* in the current reader-environment alone, otherwise go default *PACKAGE*.") (UNLESS (AND (NULL PACKAGE) FILE-MANAGER-FORMAT) (SETQ *PACKAGE* (LISP::DEFAULT-IO-PACKAGE PACKAGE))) (START-COMPILATION FASL-PATHNAME) (PROCESS-FORMS PROCESS-ENTIRE-FILE) (FINISH-COMPILATION) (SETQ COMPILATION-SUCCEEDED T) (IL:* IL:|;;|  "Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))") (COMPILATION-VALUES FASL-PATHNAME))) (IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.") (IF (STREAMP *INPUT-STREAM*) (CLOSE *INPUT-STREAM*)) (IF (NOT (NULL *FASL-HANDLE*)) (FASL:CLOSE-FASL-HANDLE *FASL-HANDLE* :ABORT (NOT COMPILATION-SUCCEEDED))) (IF (STREAMP ERROR-FILE-STREAM) (CLOSE ERROR-FILE-STREAM)) (IF (STREAMP *LAP-STREAM*) (CLOSE *LAP-STREAM*))))) (DEFUN COMPILE-FILE-PATHNAME (PATHNAME &KEY LISP::OUTPUT-FILE &ALLOW-OTHER-KEYS) (IL:* IL:\;  "Edited 13-Apr-92 14:37 by jrb:") (OR (AND LISP::OUTPUT-FILE (PATHNAME LISP::OUTPUT-FILE)) (MAKE-PATHNAME :TYPE (STRING (LOCALLY (DECLARE (SPECIAL IL:FASL.EXT)) IL:FASL.EXT)) :VERSION :NEWEST :DEFAULTS (OR (PROBE-FILE PATHNAME) (PROBE-FILE (MERGE-PATHNAMES PATHNAME ".lisp")) (PATHNAME PATHNAME))))) (DEFUN START-COMPILATION (FASL-PATHNAME) (IL:* IL:\;  "Edited 29-Jan-92 14:18 by jrb:") (IL:* IL:|;;;| "Write out banners on the various output files.") (FLET ((DATE-STRING (UNIV-TIME) (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOUR DATE MONTH YEAR DAY-OF-WEEK) (DECODE-UNIVERSAL-TIME UNIV-TIME) (FORMAT NIL "~A, ~D ~A ~D, ~D:~2,'0D:~2,'0D" (NTH DAY-OF-WEEK '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) DATE (NTH (1- MONTH) '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) YEAR HOUR MINUTES SECONDS)))) (LET ((FASL-STREAM (FASL:BEGIN-TEXT *FASL-HANDLE*))) (FORMAT FASL-STREAM "XCL Compiler output for source file ~A~%~ Source file created ~A.~%~ FASL file created ~A.~%" (NAMESTRING *INPUT-FILENAME*) (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*)) (DATE-STRING (GET-UNIVERSAL-TIME)))) (FASL:BEGIN-BLOCK *FASL-HANDLE*) (WHEN (STREAMP *LAP-STREAM*) (FORMAT *LAP-STREAM* "XCL Compiler output for source file ~A~%~ Source file created ~A.~%~ LAP file created ~A.~%~%" (NAMESTRING *INPUT-FILENAME*) (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*)) (DATE-STRING (GET-UNIVERSAL-TIME)))) (WHEN *COMPILE-VERBOSE* (FORMAT *STANDARD-OUTPUT* ";;; Compiling ~a created ~a~%;;; to ~a on ~a~2%" (NAMESTRING *INPUT-FILENAME*) (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*)) (NAMESTRING FASL-PATHNAME) (DATE-STRING (FILE-WRITE-DATE FASL-PATHNAME)))))) (DEFUN FINISH-COMPILATION NIL (IL:* IL:|;;;| "Clean up after the compilation.") (IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.") (LOCALLY (DECLARE (IL:GLOBALVARS IL:NOTCOMPILEDFILES)) (SETQ IL:NOTCOMPILEDFILES (REMOVE (INTERN (LET ((TYPE (PATHNAME-TYPE *INPUT-FILENAME*))) (STRING-UPCASE (IF (ZEROP (LENGTH TYPE)) (PATHNAME-NAME *INPUT-FILENAME*) (FORMAT NIL "~A.~A" (PATHNAME-NAME *INPUT-FILENAME*) TYPE)))) "INTERLISP") IL:NOTCOMPILEDFILES))) (IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.") (WARN-ABOUT-UNKNOWN-FUNCTIONS)) (DEFUN SCAN-ONE-FORM (FORM COMPILER-CONTEXT) (IL:* IL:\;  "Edited 31-Jan-92 11:56 by jrb:") (IL:* IL:|;;| "Assumes sedit like comments have already been stripped ") (IF (ATOM FORM) FORM (CASE (CAR FORM) ((IL:FUNCTION FUNCTION QUOTE) (EVAL FORM)) ((PROGN) (LET ((VALUE NIL)) (DOLIST (SUB-FORM (CDR FORM)) (SETQ VALUE (SCAN-ONE-FORM SUB-FORM COMPILER-CONTEXT))) VALUE)) ((DEFMACRO) (LET ((NAME (SECOND FORM))) (COND ((NOT (SYMBOLP NAME)) (COMPILER-CERROR "Ignore this DEFMACRO." "~S is not a legal macro name." NAME)) (T (UNLESS *MAKING-SECOND-PASS* (ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO FORM))) (SCAN-ONE-FORM (OPTIMIZE-AND-MACROEXPAND-1 FORM) COMPILER-CONTEXT))))) ((EVAL-WHEN) (IF (NOT (AND (LISTP (SECOND FORM)) (NOT (EQ 'QUOTE (CAR (SECOND FORM)))))) (COMPILER-CERROR "Ignore its contents." "Ill-formed EVAL-WHEN:~%~S" FORM) (LET ((EVAL-SPECIFIED (OR (MEMBER :EXECUTE (CADR FORM) :TEST #'EQ) (MEMBER 'IL:EVAL (CADR FORM) :TEST #'EQ) (MEMBER 'EVAL (CADR FORM) :TEST #'EQ))) (LOAD-TOPLEVEL-SPECIFIED (AND (CONTEXT-TOP-LEVEL-P *CONTEXT*) (MEMBER :LOAD-TOPLEVEL (CADR FORM) :TEST #'EQ))) (LOAD-SPECIFIED (OR (MEMBER 'IL:LOAD (CADR FORM) :TEST #'EQ) (MEMBER 'LOAD (CADR FORM) :TEST #'EQ))) (COMPILE-TOPLEVEL-SPECIFIED (AND (CONTEXT-TOP-LEVEL-P *CONTEXT*) (MEMBER :COMPILE-TOPLEVEL (CADR FORM) :TEST #'EQ))) (COMPILE-SPECIFIED (OR (MEMBER 'IL:COMPILE (CADR FORM) :TEST #'EQ) (MEMBER 'COMPILE (CADR FORM) :TEST #'EQ)))) (COND ((OR LOAD-SPECIFIED LOAD-TOPLEVEL-SPECIFIED) (LET ((*EVAL-WHEN-COMPILE* (OR COMPILE-SPECIFIED COMPILE-TOPLEVEL-SPECIFIED (AND *EVAL-WHEN-COMPILE* EVAL-SPECIFIED)))) (LET ((VALUE NIL)) (DOLIST (SUB-FORM (CDDR FORM)) (SETQ VALUE (SCAN-ONE-FORM SUB-FORM COMPILER-CONTEXT))) VALUE))) (T (WHEN (OR COMPILE-SPECIFIED COMPILE-TOPLEVEL-SPECIFIED (AND *EVAL-WHEN-COMPILE* EVAL-SPECIFIED)) (LET ((VALUE NIL)) (DOLIST (INNER-FORM (CDDR FORM)) (SETQ VALUE (EVAL INNER-FORM))) VALUE))))))) ((DEFCONSTANT) (COMPILER-APPLY DEFCONSTANT COMPILER-CONTEXT FORM)) ((IL:DECLARE\:) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT FORM)) ((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT FORM)) ((IL:DEFINEQ) (COMPILER-APPLY IL:DEFINEQ COMPILER-CONTEXT FORM)) ((IL:DEFINE-FILE-INFO) (COMPILER-APPLY IL:DEFINE-FILE-INFO COMPILER-CONTEXT FORM)) ((MAKE-PACKAGE IN-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT EXPORT UNEXPORT USE-PACKAGE UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT FORM)) ((PROCLAIM) (COMPILER-APPLY PROCLAIM COMPILER-CONTEXT FORM)) ((COMPILER-LET) (COMPILER-APPLY COMPILER-LET COMPILER-CONTEXT FORM)) ((MACROLET SI::%MACROLET) (COMPILER-APPLY MACROLET COMPILER-CONTEXT FORM)) ((DEFINER) (COMPILER-APPLY DEFINER COMPILER-CONTEXT FORM)) ((NAMED-PROGN) (COMPILER-APPLY NAMED-PROGN COMPILER-CONTEXT FORM)) (OTHERWISE (IF *MAKING-SECOND-PASS* (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM) (MULTIPLE-VALUE-BIND (NEW-FORM CHANGED-P) (OPTIMIZE-AND-MACROEXPAND-1 FORM) (IF (NOT CHANGED-P) (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM) (SCAN-ONE-FORM NEW-FORM COMPILER-CONTEXT)))))))) (DEFUN FUNCTION-P (FORM) (AND (CONSP FORM) (OR (EQ (FIRST FORM) 'FUNCTION) (EQ (FIRST FORM) 'IL:FUNCTION)) (CONSP (SECOND FORM)))) (DEFMACRO COMPILER-MESSAGE (FORMAT-STRING &REST FORMAT-ARGS) (IL:* IL:|;;| "Strangely enough, this macro is used ONLY in XCLC-TOP-LEVEL") `(AND *COMPILE-PRINT* (FORMAT *STANDARD-OUTPUT* ,FORMAT-STRING ,@FORMAT-ARGS))) (DEFMACRO COMPILING-MESSAGE (NAME) `(COMPILER-MESSAGE "Compiling ~a " ,NAME)) (DEFMACRO DONE-MESSAGE NIL `(COMPILER-MESSAGE " Done~%")) (DEFINE-CONDITION STYLE-WARNING (SIMPLE-WARNING) NIL) (DEFINE-CONDITION UNKNOWN-FUNCTION-WARNING (STYLE-WARNING) (CALL-LIST) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "The following functions were called in the code just compiled, but are not known to exist:~%" ) (DOLIST (PAIR (UNKNOWN-FUNCTION-WARNING-CALL-LIST CONDITION)) (FORMAT T " ~S -- called from " (CAR PAIR)) (IL:* IL:|;;|  "I almost used this hairy thing, but FORMAT is too slow... Aren't you glad?") (IL:* IL:|;;|  "\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"") (COND ((NULL (CDR PAIR)) (FORMAT T "nowhere?!~%")) ((NULL (CDDR PAIR)) (FORMAT T "~S.~%" (SECOND PAIR))) ((NULL (CDDDR PAIR)) (FORMAT T "~S and ~S.~%" (SECOND PAIR) (THIRD PAIR))) (T (DO ((TAIL (CDR PAIR) (CDR TAIL))) ((NULL TAIL)) (PRIN1 (CAR TAIL)) (COND ((CDDR TAIL) (PRINC ", ")) ((CDR TAIL) (PRINC " and ")))) (PRINC ".") (TERPRI))))))) (DEFUN STYLE-WARN (DATUM &REST ARGUMENTS) (IL:* IL:\;  "Edited 19-Feb-92 14:55 by jrb:") (LET ((*CURRENT-CONDITION* (IL:MAKE-INTO-CONDITION DATUM 'STYLE-WARNING ARGUMENTS))) (WHEN *BREAK-ON-WARNINGS* (BREAK "Warning: ~A" *CURRENT-CONDITION*)) (PROCEED-CASE (PROGN (IL:RAISE-SIGNAL *CURRENT-CONDITION*) (FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%" *CURRENT-CONDITION*) NIL) (MUFFLE-WARNING NIL :REPORT "Don't print the warning" NIL)))) (DEFUN CHECK-FOR-UNKNOWN-FUNCTION (NAME) (WHEN (AND (NOT (FBOUNDP NAME)) (NOT (MEMBER NAME *PROCESSED-FUNCTIONS* :TEST 'EQ)) (OR (ENV-INLINE-DISALLOWED *ENVIRONMENT* NAME) (NOT (OR (GET NAME 'OPTIMIZER-LIST) (GET NAME 'TRANSFORM) (GET NAME 'IL:DOPVAL))))) (LET ((LOOKUP (ASSOC NAME *UNKNOWN-FUNCTIONS* :TEST 'EQ))) (IF (NULL LOOKUP) (PUSH (LIST NAME *CURRENT-FUNCTION*) *UNKNOWN-FUNCTIONS*) (PUSHNEW *CURRENT-FUNCTION* (CDR LOOKUP)))))) (DEFUN CHECK-FOR-UNKNOWN-SETF (SETF-NAME DEFUN-SETF-NAME) (WHEN (AND (NOT (FBOUNDP DEFUN-SETF-NAME)) (NOT (MEMBER DEFUN-SETF-NAME *PROCESSED-FUNCTIONS* :TEST 'EQ)) (OR (ENV-INLINE-DISALLOWED *ENVIRONMENT* DEFUN-SETF-NAME) (NOT (OR (GET DEFUN-SETF-NAME 'OPTIMIZER-LIST) (GET DEFUN-SETF-NAME 'TRANSFORM) (GET DEFUN-SETF-NAME 'IL:DOPVAL))))) (LET ((LOOKUP (ASSOC SETF-NAME *UNKNOWN-FUNCTIONS* :TEST 'EQUAL))) (IF (NULL LOOKUP) (PUSH (LIST SETF-NAME *CURRENT-FUNCTION*) *UNKNOWN-FUNCTIONS*) (PUSHNEW *CURRENT-FUNCTION* (CDR LOOKUP)))))) (DEFUN WARN-ABOUT-UNKNOWN-FUNCTIONS NIL (IL:* IL:\;  "Edited 31-Jan-92 12:03 by jrb:") (IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.") (WHEN (NOT (NULL *UNKNOWN-FUNCTIONS*)) (COMPILER-WARNING 'UNKNOWN-FUNCTION-WARNING :CALL-LIST *UNKNOWN-FUNCTIONS*))) (DEFVAR *PROCESSED-FUNCTIONS* (IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation. Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.") ) (DEFVAR *UNKNOWN-FUNCTIONS* (IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation. Actually, it's an AList mapping the unknown function to the list of functions in which it is called. Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.") ) (DEFVAR *CURRENT-FUNCTION* (IL:* IL:|;;;| "The name of the unit currently being compiled.") ) (DEFINE-CONDITION ASSEMBLER-ERROR (IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.") (ERROR) (FORMAT-STRING FORMAT-ARGUMENTS) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT *ERROR-OUTPUT* "Error during assembly:~% ~?" ( ASSEMBLER-ERROR-FORMAT-STRING CONDITION) (ASSEMBLER-ERROR-FORMAT-ARGUMENTS CONDITION))))) (DEFUN ASSEMBLER-ERROR (STRING &REST ARGUMENTS) (ERROR 'ASSEMBLER-ERROR :FORMAT-STRING STRING :FORMAT-ARGUMENTS ARGUMENTS)) (IL:* IL:|;;| "Reading the #, macro") (DEFVAR *COMPILER-IS-READING* NIL "Bound to T during compile-file so that READ can properly treat #,") (DEFSTRUCT EVAL-WHEN-LOAD "Structure wrapping a form to be evaluated at load time. Used in the implementation of the #, reader macro." IL:FORM) (IL:* IL:|;;| "Support for Block Compilation") (DEFVAR *BLOCK-HASH-TABLE* NIL (IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function. Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.") ) (DEFVAR *BLOCKS* NIL (IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file. This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)") ) (DEFVAR *CURRENT-BLOCK* NIL (IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function. This is NIL if the function is not a part of any block.") ) (DEFSTRUCT (BLOCK-DECL (:INLINE NIL)) (IL:* IL:|;;;| "A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.") (IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.") (IL:* IL:|;;;| "FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.") (IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.") NAME FN-NAME-MAP SPECVARS LOCALVARS LOCALFREEVARS GLOBALVARS) (DEFUN SET-UP-BLOCK-DECLS (DECLS) (IL:* IL:\;  "Edited 31-Jan-92 12:02 by jrb:") (IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.") (LET ((HASH-TABLE (MAKE-HASH-TABLE))) (DOLIST (DECL DECLS) (LET* ((BLOCK-NAME (CAR DECL)) (BD (MAKE-BLOCK-DECL :NAME BLOCK-NAME)) (IL:SPECVARS IL:SPECVARS) (IL:LOCALVARS IL:LOCALVARS) (IL:LOCALFREEVARS NIL) (IL:GLOBALVARS IL:GLOBALVARS) (NOT-RENAMED-FNS (CONS BLOCK-NAME (UNION IL:RETFNS IL:NOLINKFNS))) (FNS NIL)) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NOLINKFNS)) (IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.") (COND ((NULL BLOCK-NAME) (SETQ IL:SPECVARS T) (SETQ IL:LOCALVARS IL:SYSLOCALVARS)) (T (SETQ IL:LOCALVARS T) (SETQ IL:SPECVARS IL:SYSSPECVARS))) (IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.") (DOLIST (ITEM (CDR DECL)) (COND ((SYMBOLP ITEM) (PUSH ITEM FNS) (PUSH BD (GETHASH ITEM HASH-TABLE))) ((CONSP ITEM) (CASE (CAR ITEM) ((IL:SPECVARS IL:LOCALVARS) (IL:EVAL ITEM)) ((IL:GLOBALVARS IL:LOCALFREEVARS) (LET ((VARIABLE (CAR ITEM)) (VALUE (CDR ITEM))) (WHEN (AND (CONSP VALUE) (EQ (CAR VALUE) 'IL:*)) (SETQ VALUE (IL:EVAL (CADR VALUE)))) (IF (LISTP VALUE) (SET VARIABLE (UNION (CDR ITEM) (SYMBOL-VALUE (CAR ITEM)))) (SET VARIABLE VALUE)))) ((IL:BLKLIBRARY IL:LINKFNS) (COMPILER-WARNING "The ~S feature is no longer supported." (CAR ITEM))) ((IL:DONTCOMPILEFNS) (COMPILER-WARNING "DONTCOMPILEFNS is not supported in BLOCK: declarations." )) ((IL:BLKAPPLYFNS IL:NOLINKFNS IL:RETFNS IL:ENTRIES) (IL:* IL:\;  "These functions should not be renamed, according to BYTEBLOCKCOMPILE2.") (WHEN (CONSP (CDR ITEM)) (SETQ NOT-RENAMED-FNS (APPEND (CDR ITEM) NOT-RENAMED-FNS)))) (OTHERWISE (COMPILER-CERROR "Ignore the unknown variable." "Unknown variable ~S mentioned in a BLOCK: declaration" (CAR ITEM))))) (T (COMPILER-CERROR "Ignore the illegal item" "Illegal item in a BLOCK: declaration: ~S" ITEM)))) (SETF (BLOCK-DECL-SPECVARS BD) IL:SPECVARS) (SETF (BLOCK-DECL-LOCALVARS BD) IL:LOCALVARS) (SETF (BLOCK-DECL-LOCALFREEVARS BD) IL:LOCALFREEVARS) (SETF (BLOCK-DECL-GLOBALVARS BD) IL:GLOBALVARS) (LET* ((BLOCK-NAME-STRING (STRING BLOCK-NAME)) (BLOCK-PACKAGE (SYMBOL-PACKAGE BLOCK-NAME))) (UNLESS (NULL BLOCK-NAME) (IL:* IL:\;  "NIL blocks don't do renaming.") (SETF (BLOCK-DECL-FN-NAME-MAP BD) (IL:|for| FN IL:|in| (NSET-DIFFERENCE FNS NOT-RENAMED-FNS) IL:|collect| (CONS FN (INTERN (CONCATENATE 'STRING "\\" BLOCK-NAME-STRING "/" (STRING FN)) BLOCK-PACKAGE)))))))) HASH-TABLE)) (IL:* IL:|;;| "Processing of top-level forms in a file") (DEFCONSTANT PASS 'PASS "Useful for ameliorating the obvious quoting bug.") (DEFUN CONSTANT-EXPRESSION-P (FORM) (OR (CONSTANTP FORM) (AND (CONSP FORM) (LET* ((FN (CAR FORM)) (S-E-DATA (GET FN 'SIDE-EFFECTS-DATA))) (AND (EQ (CAR S-E-DATA) :NONE) (EQ (CDR S-E-DATA) :NONE) (DOLIST (ARG (CDR FORM) T) (IF (NOT (CONSTANT-EXPRESSION-P ARG)) (RETURN NIL)))))))) (DEFUN COMPILE-AND-DUMP (NAME DEFN KIND) (LET ((*CURRENT-BLOCK* NIL) (IL:* IL:\;  "So that we aren't dependent upon the top-level binding.") ) (COND ((AND (SYMBOLP NAME) (EQ KIND :FUNCTION)) (WHEN (MEMBER NAME IL:DONTCOMPILEFNS :TEST 'EQ) (RETURN-FROM COMPILE-AND-DUMP)) (LET ((BD-LIST (AND *BLOCK-HASH-TABLE* (GETHASH NAME *BLOCK-HASH-TABLE*)))) (COND ((NULL BD-LIST) (COMPILE-AND-DUMP-1 NAME DEFN KIND)) (T (DOLIST (*CURRENT-BLOCK* BD-LIST) (LET* ((LOOKUP (ASSOC NAME (BLOCK-DECL-FN-NAME-MAP *CURRENT-BLOCK*))) (NEW-NAME (IF (NULL LOOKUP) NAME (CDR LOOKUP))) (IL:SPECVARS (BLOCK-DECL-SPECVARS *CURRENT-BLOCK*)) (IL:LOCALVARS (BLOCK-DECL-LOCALVARS *CURRENT-BLOCK*)) (IL:LOCALFREEVARS (BLOCK-DECL-LOCALFREEVARS *CURRENT-BLOCK*)) (IL:GLOBALVARS (BLOCK-DECL-GLOBALVARS *CURRENT-BLOCK*))) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (COMPILE-AND-DUMP-1 NEW-NAME DEFN KIND))))))) (T (COMPILE-AND-DUMP-1 NAME DEFN KIND))))) (DEFUN COMPILE-AND-DUMP-1 (NAME DEFN KIND) (IL:* IL:\;  "Edited 29-Jan-92 15:58 by jrb:") (WHEN (EQ KIND :FUNCTION) (PUSH NAME *PROCESSED-FUNCTIONS*) (SETQ *UNKNOWN-FUNCTIONS* (REMOVE NAME *UNKNOWN-FUNCTIONS* :KEY 'CAR))) (LET* ((*CURRENT-FUNCTION* NAME) (LAP-FN (COMPILE-ONE-LAMBDA NAME DEFN)) DCODE) (WHEN (STREAMP *LAP-STREAM*) (PPRINT LAP-FN *LAP-STREAM*) (TERPRI *LAP-STREAM*) (TERPRI *LAP-STREAM*)) (WHEN *COMPILE-PRINT* (PRINC ".")) (IL:BLOCK) (CONDITION-CASE (SETQ DCODE (D-ASSEM:ASSEMBLE-FUNCTION LAP-FN)) (ASSEMBLER-ERROR (CONDITION) (FORMAT *ERROR-OUTPUT* "~&~A~%" CONDITION) (PRINC "Aborted.") (TERPRI) (RETURN-FROM COMPILE-AND-DUMP-1 NIL))) (WHEN *COMPILE-PRINT* (PRINC ".")) (IL:BLOCK) (ECASE KIND ((:FUNCTION) (FASL:DUMP-FUNCTION-DEF *FASL-HANDLE* DCODE NAME)) ((:ONE-SHOT) (FASL:DUMP-FUNCALL *FASL-HANDLE* DCODE))) (WHEN *COMPILE-PRINT* (PRINC ".")) (IL:BLOCK) (WHEN (NOT (NULL *LOAD-COMPILED-CODE*)) (ECASE KIND (:FUNCTION (WHEN (AND (EQ :SAVE *LOAD-COMPILED-CODE*) (FBOUNDP NAME) (CONSP (SYMBOL-FUNCTION NAME)) (NOT (IL:HASDEF NAME 'IL:FUNCTIONS))) (SETF (GET NAME 'IL:EXPR) (SYMBOL-FUNCTION NAME))) (SETF (SYMBOL-FUNCTION NAME) (D-ASSEM:INTERN-DCODE DCODE))) (:ONE-SHOT (LET ((IL:FILEPKGFLG NIL)) (IL:* IL:\;  "so that things don't get marked as changed when you execute the one-shot.") (DECLARE (SPECIAL IL:FILEPKGFLG)) (FUNCALL (D-ASSEM:INTERN-DCODE DCODE)))))))) (DEFUN COMPILE-ONE-LAMBDA (NAME DEFN) (IL:* IL:|;;;| "Return a LAP function for the given function definition. NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.") (LET ((*CONTEXT* *NULL-CONTEXT*) (*AUTOMATIC-SPECIAL-DECLARATIONS* NIL)) (LET ((TREE (ALPHA-LAMBDA DEFN :NAME NAME)) LAP-CODE) (UNWIND-PROTECT (SETQ LAP-CODE (PEEPHOLE-OPTIMIZE (GENERATE-CODE (ANNOTATE-TREE (META-EVALUATE TREE))))) (RELEASE-TREE TREE)) LAP-CODE))) (DEFUN OPTIMIZE-AND-MACROEXPAND (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*) (CONTEXT *CONTEXT*)) (IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.") (PROG (NEW-FORM CHANGED-P) (MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P) (OPTIMIZE-AND-MACROEXPAND-1 FORM ENVIRONMENT CONTEXT)) (UNLESS CHANGED-P (RETURN (VALUES FORM NIL))) LOOP (MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P) (OPTIMIZE-AND-MACROEXPAND-1 NEW-FORM ENVIRONMENT CONTEXT)) (IF CHANGED-P (GO LOOP) (RETURN (VALUES NEW-FORM T))))) (DEFUN OPTIMIZE-AND-MACROEXPAND-1 (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*) (CONTEXT *CONTEXT*)) (IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR. Return two values like MACROEXPAND-1.") (LET ((*NEW-COMPILER-IS-EXPANDING* T)) (COND ((OR (ATOM FORM) (NOT (SYMBOLP (CAR FORM)))) (VALUES FORM NIL)) (T (IL:* IL:|;;| "Check for compiler optimizers.") (LET ((OPTIMIZERS (OPTIMIZER-LIST (CAR FORM)))) (WHEN (AND (NOT (NULL OPTIMIZERS)) (NOT (ENV-FBOUNDP ENVIRONMENT (CAR FORM) :LEXICAL-ONLY T)) (NOT (ENV-INLINE-DISALLOWED ENVIRONMENT (CAR FORM)))) (IL:* IL:\;  "Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.") (DOLIST (OPT-FN OPTIMIZERS) (LET ((RESULT (FUNCALL OPT-FN FORM ENVIRONMENT CONTEXT))) (UNLESS (OR (EQ RESULT 'PASS) (EQ RESULT 'IL:IGNOREMACRO) (EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.") (RETURN-FROM OPTIMIZE-AND-MACROEXPAND-1 (VALUES RESULT T))))))) (IL:* IL:|;;| "Check for a macro expansion function.") (MACROEXPAND-1 FORM ENVIRONMENT))))) (DEFMACRO EXPAND-DEFINER (DEFINER BODY-WITHOUT-COMMENTS &OPTIONAL ENVIRONMENT) `(LET ((*NEW-COMPILER-IS-EXPANDING* T)) (XCL::%EXPAND-DEFINER ,DEFINER ,BODY-WITHOUT-COMMENTS ,ENVIRONMENT))) (DEFUN PROCESS-FORMS (PROCESS-ENTIRE-FILE) (LET ((*DEFERRED-FORMS* NIL) (*BLOCKS* NIL) (*BLOCK-HASH-TABLE* NIL) (*PREPROCESSING-PHASE* PROCESS-ENTIRE-FILE) (EOF-VALUE '(NIL)) FORM) (LOOP (IL:SKIPSEPRS *INPUT-STREAM*) (WHEN (IL:EOFP *INPUT-STREAM*) (RETURN)) (SETQ FORM (LET ((*COMPILER-IS-READING* T)) (READ *INPUT-STREAM* NIL EOF-VALUE))) (WHEN (EQ FORM EOF-VALUE) (RETURN)) (IF PROCESS-ENTIRE-FILE (LET ((NEW-FORM (CASE (AND (CONSP FORM) (CAR FORM)) (IL:PRETTYCOMPRINT (SETQ *INPUT-FILECOMS-VARIABLE* (CADR FORM)) NIL) (IL:RPAQQ (IF (EQ (SECOND FORM) *INPUT-FILECOMS-VARIABLE*) (IL:* IL:|;;|  "Don't remove comments from file coms") FORM (REMOVE-COMMENTS FORM))) (IL:DEFCLASS (IL:* IL:|;;|  "Don't remove comments from LOOPS DEFCLASS forms") FORM) (OTHERWISE (REMOVE-COMMENTS FORM))))) (SCAN-ONE-FORM NEW-FORM *COMPILE-SCAN-CONTEXT*)) (SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*))) (WHEN PROCESS-ENTIRE-FILE (LET ((*MAKING-SECOND-PASS* T) (*BLOCK-HASH-TABLE* (SET-UP-BLOCK-DECLS *BLOCKS*))) (MAPC #'(LAMBDA (FORM) (SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*)) (NREVERSE *DEFERRED-FORMS*)))) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS *COMPILE-FILE-CONTEXT*))) (DEFUN MAYBE-REMOVE-COMMENTS (FORM) (COND ((EQ 'IL:DEFCLASS (CAR FORM)) IL:FORM) (T (REMOVE-COMMENTS FORM)))) (DEFUN COMPILE-FILE-SETF-SYMBOL-FUNCTION (COMPILER-CONTEXT FORM) (LET ((NAME-FORM (SECOND FORM)) (FUNCTION-FORM (THIRD FORM))) (COND ((AND (CONSTANTP NAME-FORM) (SYMBOLP (EVAL NAME-FORM)) (FUNCTION-P FUNCTION-FORM)) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM)) (LET ((NAME (SECOND NAME-FORM)) (DEFINITION (SECOND FUNCTION-FORM))) (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a" (CAR DEFINITION) NAME) NAME DEFINITION))) (T (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM))))) (DEFUN COMPILE-FILE-DEFINEQ (COMPILER-CONTEXT FORM) (WHEN *EVAL-WHEN-COMPILE* (IL:EVAL FORM)) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (MAPCAR #'(LAMBDA (DEFN) (LET ((REAL-DEFN (IF (NULL (CDDR DEFN)) (SECOND DEFN) (CONS 'IL:LAMBDA (CDR DEFN))))) (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~s" (CAR REAL-DEFN) (CAR DEFN)) (CAR DEFN) REAL-DEFN))) (CDR FORM))) (DEFUN COMPILE-FILE-DEFCONSTANT (COMPILER-CONTEXT FORM) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (DESTRUCTURING-BIND (NAME SYMBOL INITIAL-VALUE &OPTIONAL DOC) FORM (LET ((VALUE NIL)) (IF (AND (CONSTANT-EXPRESSION-P INITIAL-VALUE) (VALUE-FOLDABLE-P (SETQ VALUE (EVAL INITIAL-VALUE)))) (SETF (CONSTANT-VALUE SYMBOL) VALUE) (ENV-DECLARE-A-GLOBAL (FIND-TOP-ENVIRONMENT *ENVIRONMENT*) SYMBOL))) (SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL (LOCALLY (DECLARE (GLOBAL ,SYMBOL)) ,(EXPAND-DEFINER 'DEFCONSTANT (REMOVE-COMMENTS FORM) *ENVIRONMENT*))) COMPILER-CONTEXT))) (DEFUN COMPILE-FILE-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T)) (IL:* IL:\;  "Edited 31-Jan-92 12:57 by jrb:") (LET ((*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*)) (DO ((TAIL (CDR FORM) (CDR TAIL))) ((ENDP TAIL)) (COND ((SYMBOLP (CAR TAIL)) (CASE (CAR TAIL) ((IL:EVAL@LOAD IL:DOEVAL@LOAD IL:DONTEVAL@LOAD) NIL) ((IL:EVAL@LOADWHEN) (POP TAIL)) ((IL:EVAL@COMPILE IL:DOEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* T)) ((IL:DONTEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* NIL)) ((IL:EVAL@COMPILEWHEN) (SETQ *EVAL-WHEN-COMPILE* (IL:EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((IL:COPY IL:DOCOPY) (SETQ DOCOPY T)) ((IL:DONTCOPY) (SETQ DOCOPY NIL)) ((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((IL:FIRST) ) ((IL:NOTFIRST IL:COMPILERVARS) ) (OTHERWISE (COMPILER-WARNING "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL)))) ) ((EQ 'IL:DECLARE\: (CAR (CAR TAIL))) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL) DOCOPY)) ((EQ 'IL:BLOCK\: (CAR (CAR TAIL))) (IF (NULL *PREPROCESSING-PHASE*) (COMPILER-CERROR "Ignore the BLOCK: declaration." "Files with Interlisp BLOCK: declarations must be compiled with :PROCESS-ENTIRE-FILE = T." ) (PUSH (CDR (CAR TAIL)) *BLOCKS*))) (T (WHEN *EVAL-WHEN-COMPILE* (IL:EVAL (CAR TAIL))) (WHEN DOCOPY (SCAN-ONE-FORM (CAR TAIL) COMPILER-CONTEXT))))))) (DEFUN COMPILE-FILE-DEFINE-FILE-INFO (COMPILER-CONTEXT FORM) (LET ((*STANDARD-INPUT* *INPUT-STREAM*) IL:FILECREATEDLOC) (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC)) (EVAL FORM)) (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT `(LET ((*STANDARD-INPUT* (OPEN "{Null}" :DIRECTION :OUTPUT)) IL:FILECREATEDLOC) (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC)) ,FORM)) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)) (DEFUN COMPILE-FILE-PACKAGE-FORM (COMPILER-CONTEXT FORM) (UNLESS *MAKING-SECOND-PASS* (EVAL FORM)) (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)) (DEFUN COMPILE-FILE-PROCLAMATION (COMPILER-CONTEXT FORM) (IL:* IL:\;  "Edited 31-Jan-92 11:59 by jrb:") (DECLARE (SPECIAL IL:GLOBALVARS IL:SPECVARS IL:LOCALVARS)) (LET ((FORM (EVAL (SECOND FORM))) (TOP-ENV (FIND-TOP-ENVIRONMENT *ENVIRONMENT*))) (IF (ATOM FORM) (COMPILER-CERROR "Ignore the proclamation." "Illegal form in PROCLAIM:~%~S" FORM) (CASE (CAR FORM) ((SPECIAL) (MAPC #'(LAMBDA (SYMBOL) (ENV-PROCLAIM-SPECIAL TOP-ENV SYMBOL)) (CDR FORM))) ((GLOBAL) (MAPC #'(LAMBDA (SYMBOL) (ENV-PROCLAIM-GLOBAL TOP-ENV SYMBOL)) (CDR FORM))) ((IL:GLOBALVARS) (SETQ IL:GLOBALVARS (UNION IL:GLOBALVARS (CDR FORM)))) ((IL:SPECVARS) (COND ((CONSP (CDR FORM)) (UNLESS (EQ IL:SPECVARS T) (SETQ IL:SPECVARS (UNION IL:SPECVARS (CDR FORM))))) ((EQ (CDR FORM) T) (SETQ IL:SPECVARS T) (SETQ IL:LOCALVARS IL:SYSLOCALVARS)) (T (COMPILER-CERROR "Ignore it" "Illegal SPECVARS proclamation: ~S" FORM)))) ((IL:LOCALVARS) (COND ((CONSP (CDR FORM)) (UNLESS (EQ IL:LOCALVARS T) (SETQ IL:LOCALVARS (UNION IL:LOCALVARS (CDR FORM))))) ((EQ (CDR FORM) T) (SETQ IL:LOCALVARS T) (SETQ IL:SPECVARS IL:SYSSPECVARS)) (T (COMPILER-CERROR "Ignore it" "Illegal LOCALVARS proclamation: ~S" FORM)))) ((TYPE FTYPE IL:FUNCTION FUNCTION) NIL) ((INLINE) (ENV-ALLOW-INLINES TOP-ENV (CDR FORM))) ((NOTINLINE) (ENV-DISALLOW-INLINES TOP-ENV (CDR FORM))) ((IGNORE OPTIMIZE) NIL) ((DECLARATION) (ENV-ADD-DECLS TOP-ENV (CDR FORM))) (OTHERWISE (UNLESS (OR (LISP::TYPE-EXPANDER (CAR FORM)) (XCL::DECL-SPECIFIER-P (CAR FORM)) (ENV-DECL-P TOP-ENV (CAR FORM))) (COMPILER-CERROR "Ignore it." "Unknown declaration specifier in PROCLAIM: ~S." (CAR FORM)))))) ) (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)) (DEFUN COMPILE-FILE-COMPILER-LET (COMPILER-CONTEXT FORM) (IL:* IL:\;  "Edited 31-Jan-92 11:55 by jrb:") (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (DESTRUCTURING-BIND (BINDING-LIST &REST INNER-FORMS) (CDR FORM) (LET (VARS VALS) (DOLIST (BINDING BINDING-LIST) (COND ((ATOM BINDING) (PUSH BINDING VARS) (PUSH NIL VALS)) ((NULL (CDR BINDING)) (PUSH (CAR BINDING) VARS) (PUSH NIL VALS)) ((AND (CONSP (CDR BINDING)) (NULL (CDDR BINDING))) (PUSH (CAR BINDING) VARS) (PUSH (EVAL (CADR BINDING)) VALS)) (T (COMPILER-CERROR "Bind the CAR of the binding to NIL" "Bad binding in COMPILER-LET: ~S" BINDING) (PUSH (CAR BINDING) VARS) (PUSH NIL VALS)))) (PROGV VARS VALS (MAPC #'(LAMBDA (FORM) (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) INNER-FORMS) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))))) (DEFUN COMPILE-FILE-MACROLET (COMPILER-CONTEXT FORM) (DESTRUCTURING-BIND (JUNK MACRO-DEFNS &BODY BODY) FORM (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (LET ((*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*))) (DOLIST (MACRO-DEFN MACRO-DEFNS) (ENV-BIND-FUNCTION *ENVIRONMENT* (CAR MACRO-DEFN) :MACRO (CRACK-DEFMACRO (CONS 'DEFMACRO MACRO-DEFN)))) (DOLIST (FORM BODY) (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)))) (DEFUN COMPILE-FILE-DEFINER (COMPILER-CONTEXT FORM) (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV) (CDR FORM) (LET* ((MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION)) (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION)) (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV))) (IF *COMPILING-DEFINER* (SCAN-ONE-FORM BODY COMPILER-CONTEXT) (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (LET ((*COMPILING-DEFINER* T) (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER NAME))) (COMPILING-MESSAGE *LOOSE-NAME*) (SCAN-ONE-FORM BODY COMPILER-CONTEXT) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (DONE-MESSAGE))))))) (DEFUN COMPILE-FILE-NAMED-PROGN (COMPILER-CONTEXT FORM) (DESTRUCTURING-BIND (DEFINER-NAME NAME &REST PROGN-FORMS) (CDR FORM) (IF *COMPILING-DEFINER* (MAPC #'(LAMBDA (FORM) (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) PROGN-FORMS) (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (LET ((*COMPILING-DEFINER* T) (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER-NAME NAME))) (COMPILING-MESSAGE *LOOSE-NAME*) (MAPC #'(LAMBDA (FORM) (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) PROGN-FORMS) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (DONE-MESSAGE)))))) (DEFUN COMPILE-FILE-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT) (WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*)) (IF *COMPILING-DEFINER* (COMPILE-AND-DUMP *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE *OUTSTANDING-LOOSE-FORMS*)) :ONE-SHOT) (LET ((NAME (FORMAT NIL "~&~D top-level form~:P" (LIST-LENGTH *OUTSTANDING-LOOSE-FORMS*))) ) (COMPILING-MESSAGE NAME) (COMPILE-AND-DUMP NAME `(LAMBDA NIL ,@(REVERSE *OUTSTANDING-LOOSE-FORMS*)) :ONE-SHOT) (DONE-MESSAGE))) (SETQ *OUTSTANDING-LOOSE-FORMS* NIL))) (DEFUN COMPILE-FILE-LOOSE-FORM (COMPILER-CONTEXT FORM) (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM)) (PUSH FORM *OUTSTANDING-LOOSE-FORMS*)) (DEFUN COMPILE-FILE-PROCESS-FUNCTION (COMPILER-CONTEXT MESSAGE NAME DEFINITION) (IF *COMPILING-DEFINER* (COMPILE-AND-DUMP NAME DEFINITION :FUNCTION) (PROGN (COMPILING-MESSAGE MESSAGE) (COMPILE-AND-DUMP NAME DEFINITION :FUNCTION) (DONE-MESSAGE))) NAME) (DEFUN CRACK-DEFMACRO (FORM) (IL:* IL:|;;;| "FORM is a call to DEFMACRO. Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.") (LET ((NAME (SECOND FORM)) (ARG-LIST (THIRD FORM)) (BODY (CDDDR FORM)) (WHOLE (GENSYM)) (ENV-VAR (GENSYM))) (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (IL:PARSE-DEFMACRO ARG-LIST WHOLE BODY NAME *ENVIRONMENT* :ENVIRONMENT ENV-VAR) (VALUES `(LAMBDA (,WHOLE ,ENV-VAR) ,@DECLS (BLOCK ,NAME ,CODE)) DOC)))) (DEFUN ESTABLISH-MACRO-IN-COMPILER (NAME EXPN-FN) (IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.") (ENV-BIND-FUNCTION (FIND-TOP-ENVIRONMENT *ENVIRONMENT*) NAME :MACRO EXPN-FN)) (IL:* IL:|;;| "Support for :Process-Entire-File") (DEFVAR *DEFERRED-FORMS* NIL "A list onto which most forms will be pushed if we are preprocessing an Interlisp-format file. After the first pass through the file is done, and all macros and other eval-when(compile) forms have been processed, a second pass will be made down this list to actually compile the forms." ) (DEFVAR *MAKING-SECOND-PASS* NIL (IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.") ) (DEFVAR *PREPROCESSING-PHASE* NIL (IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.") ) (DEFUN COMPILE-SCAN-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T) (DOFIRST NIL)) (IL:* IL:\;  "Edited 31-Jan-92 12:59 by jrb:") (LET ((FIRST-FORMS NIL) (IL:DFNFLG IL:DFNFLG) (*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*)) (DO ((TAIL (CDR FORM) (CDR TAIL))) ((ENDP TAIL) (WHEN FIRST-FORMS (MERGE-FIRST-FORMS FIRST-FORMS))) (COND ((SYMBOLP (CAR TAIL)) (CASE (CAR TAIL) ((IL:EVAL@LOAD IL:DOEVAL@LOAD IL:DONTEVAL@LOAD) NIL) ((IL:EVAL@LOADWHEN) (POP TAIL)) ((IL:EVAL@COMPILE IL:DOEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* T)) ((IL:DONTEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* NIL)) ((IL:EVAL@COMPILEWHEN) (SETQ *EVAL-WHEN-COMPILE* (IL:EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((IL:COPY IL:DOCOPY) (SETQ DOCOPY T)) ((IL:DONTCOPY) (SETQ DOCOPY NIL)) ((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((IL:FIRST) (SETQ DOFIRST T)) ((IL:NOTFIRST) (SETQ DOFIRST NIL)) ((IL:COMPILERVARS) (SETQ IL:DFNFLG T)) (OTHERWISE (COMPILER-WARNING "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL)))) ) ((EQ 'IL:DECLARE\: (CAR (CAR TAIL))) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL) DOCOPY DOFIRST)) ((EQ 'IL:BLOCK\: (CAR (CAR TAIL))) (PUSH (CDR (CAR TAIL)) *BLOCKS*)) (T (WHEN *EVAL-WHEN-COMPILE* (IL:EVAL (CAR TAIL))) (WHEN DOCOPY (IF DOFIRST (LET ((*DEFERRED-FORMS* NIL)) (SCAN-ONE-FORM (CAR TAIL) COMPILER-CONTEXT) (SETQ FIRST-FORMS (APPEND FIRST-FORMS *DEFERRED-FORMS*))) (SCAN-ONE-FORM (CAR TAIL) COMPILER-CONTEXT)))))))) (DEFUN COMPILE-SCAN-DEFINE-FILE-INFO (COMPILER-CONTEXT FORM) (LET ((*STANDARD-INPUT* *INPUT-STREAM*) IL:FILECREATEDLOC) (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC)) (EVAL FORM)) (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)) (DEFUN COMPILE-SCAN-MACROLET (COMPILER-CONTEXT FORM) (DESTRUCTURING-BIND (JUNK MACRO-DEFNS &BODY BODY) FORM (LET (OUTER-DEFERRED-FORMS) (LET ((*DEFERRED-FORMS* NIL) (*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*))) (DOLIST (MACRO-DEFN MACRO-DEFNS) (ENV-BIND-FUNCTION *ENVIRONMENT* (CAR MACRO-DEFN) :MACRO (CRACK-DEFMACRO (CONS 'DEFMACRO MACRO-DEFN)))) (DOLIST (FORM BODY) (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) (SETQ OUTER-DEFERRED-FORMS *DEFERRED-FORMS*)) (WHEN (NOT (NULL OUTER-DEFERRED-FORMS)) (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT `(MACROLET ,MACRO-DEFNS ,@(REVERSE OUTER-DEFERRED-FORMS))))))) (DEFUN COMPILE-SCAN-DEFINER (COMPILER-CONTEXT FORM) (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV) (CDR FORM) (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT (LET* ((*DEFERRED-FORMS* NIL) (MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION)) (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION)) (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV))) (SCAN-ONE-FORM BODY COMPILER-CONTEXT) `(NAMED-PROGN ,DEFINER ,NAME ,@(NREVERSE *DEFERRED-FORMS*)))))) (DEFUN COMPILE-SCAN-LOOSE-FORM (COMPILER-CONTEXT FORM) (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM)) (PUSH FORM *DEFERRED-FORMS*)) (DEFUN COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT) NIL) (DEFUN MERGE-FIRST-FORMS (FORMS) (DO* ((TAIL *DEFERRED-FORMS* (CDR TAIL)) (NEW-TAIL (CDR TAIL) (CDR TAIL))) ((ENDP TAIL) (IF (NULL NEW-TAIL) (NCONC *DEFERRED-FORMS* FORMS)) NIL) (WHEN (EQL (CAAR NEW-TAIL) 'IL:FILECREATED) (SETF (CDR TAIL) FORMS) (SETF (CDR (LAST FORMS)) NEW-TAIL) (RETURN)))) (IL:* IL:|;;| "for compiling definers") (DEFVAR *LAP-FLG* NIL) (DEFVAR *AUTOMATIC-SPECIAL-DECLARATIONS*) (DEFUN COMPILE (NAME &OPTIONAL DEFN &KEY LAP) (IL:* IL:\;  "Edited 31-Jan-92 15:34 by jrb:") (IL:* IL:|;;| "COMPILE now uses the XCL::NAME-OF-EXECUTABLE name-mapping service; this blots up a lot of junk special-cases.") (LET ((EXECUTABLE-NAME (XCL::NAME-OF-EXECUTABLE NAME))) (IF (AND NAME (NULL EXECUTABLE-NAME)) (ERROR "~s is not a function name" NAME) (PROGN (IL:VIRGINFN NAME T) (COND ((EQ NAME EXECUTABLE-NAME) (COMPILE-SYMBOL-FUNCTION NAME DEFN LAP)) (DEFN (COMPILE-SYMBOL-FUNCTION EXECUTABLE-NAME DEFN LAP NAME)) ((LISP::SETF-NAME-P NAME) (IL:* IL:|;;| "We have to special-case this one because (SETF FOO) is not the file-package name of (DEFUN (SETF FOO)...).") (LET ((REAL-NAME (SECOND NAME)) (SETF-DEFN (IL:GETD EXECUTABLE-NAME))) (TYPECASE SETF-DEFN (CONS (COMPILE-SYMBOL-FUNCTION EXECUTABLE-NAME SETF-DEFN LAP NAME )) ((OR NULL IL:COMPILED-CLOSURE) (FORMAT T (IF SETF-DEFN "~s is already compiled" "~s has no installed definition") NAME) (IF (AND (IL:HASDEF REAL-NAME 'IL:SETFS) (EQ (CAR (IL:GETDEF REAL-NAME 'IL:SETFS)) 'DEFUN) (Y-OR-N-P "Shall I use the SETFS definition? ")) (BUMP-DIAGNOSTIC-COUNT (COMPILE-DEFINER REAL-NAME 'IL:SETFS :LAP LAP)) (VALUES NIL 1 1))) (OTHERWISE (FORMAT T "There's something funny installed as the definition for ~S.~%I'm not going any further.~%" NAME) (VALUES NIL 1 1))))) (T (COMPILE-SYMBOL-FUNCTION EXECUTABLE-NAME NIL LAP NAME))))))) (DEFUN COMPILE-SYMBOL-FUNCTION (NAME DEFN LAP &OPTIONAL (REAL-NAME NAME)) (IL:* IL:\;  "Edited 31-Jan-92 15:36 by jrb:") (LET ((DIAGS 0)) (WHEN (NULL DEFN) (SETQ DEFN (IL:GETD NAME)) (TYPECASE DEFN (CONS NIL) ((OR NULL IL:COMPILED-CLOSURE) (IF (NULL DEFN) (FORMAT T "There's no installed definition for ~S.~%" REAL-NAME) (FORMAT T "~S is already compiled.~%" REAL-NAME)) (WHEN (AND (IL:HASDEF REAL-NAME 'IL:FUNCTIONS) (Y-OR-N-P "Shall I use the FUNCTIONS definition? ")) (RETURN-FROM COMPILE-SYMBOL-FUNCTION (BUMP-DIAGNOSTIC-COUNT (COMPILE-DEFINER REAL-NAME 'IL:FUNCTIONS :LAP LAP)))) (WHEN (AND (GET NAME 'IL:EXPR) (Y-OR-N-P "Shall I use the definition on the EXPR property? " NAME)) (BUMP-DIAGNOSTIC-COUNT (RETURN-FROM COMPILE-SYMBOL-FUNCTION (COMPILE NAME (GET NAME 'IL:EXPR) :LAP LAP)))) (RETURN-FROM COMPILE-SYMBOL-FUNCTION (VALUES NIL 1 1))) (OTHERWISE (FORMAT T "There's something funny installed as the definition for ~S.~%I'm not going any further.~%" NAME) (RETURN-FROM COMPILE-SYMBOL-FUNCTION (VALUES NIL 1 1))))) (LET* ((*ENVIRONMENT* (MAKE-ENV :PARENT T :TARGET-ARCHITECTURE *HOST-ARCHITECTURE*)) (IL:SPECVARS IL:SPECVARS) (IL:LOCALVARS IL:LOCALVARS) (IL:LOCALFREEVARS NIL) (IL:GLOBALVARS IL:GLOBALVARS) (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE)) (*PROCESSED-FUNCTIONS* (LIST NAME)) (*UNKNOWN-FUNCTIONS* NIL) (*CURRENT-FUNCTION* NAME) (*INPUT-STREAM* NIL) (*LAP-FLG* LAP) (IL:* IL:\; "FXAR-111") (*ANY-DIAGNOSTICS* 0) (*ANY-SERIOUS-DIAGNOSTICS* 0) (COMPILED-DEFN (RAW-COMPILE NAME DEFN))) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (WARN-ABOUT-UNKNOWN-FUNCTIONS) (COMPILATION-VALUES (IF (NULL NAME) COMPILED-DEFN (PROGN (WHEN (AND (NOT (IL:HASDEF NAME 'IL:FUNCTIONS)) (CONSP (IL:GETD NAME))) (SETF (GET NAME 'IL:EXPR) (IL:GETD NAME))) (SETF (SYMBOL-FUNCTION NAME) COMPILED-DEFN) NAME)))))) (DEFUN COMPILE-DEFINER (NAME TYPE &KEY LAP) (IL:* IL:\;  "Edited 31-Jan-92 13:49 by jrb:") (LET ((*ENVIRONMENT* (MAKE-ENV :PARENT T)) (*OUTSTANDING-LOOSE-FORMS* NIL) (*EVAL-WHEN-COMPILE* NIL) (*ANY-DIAGNOSTICS* 0) (*ANY-SERIOUS-DIAGNOSTICS* 0)) (COMPILE-FORM (IL:GETDEF NAME TYPE NIL '(IL:NOCOPY T))) (COMPILATION-VALUES NAME))) (DEFUN COMPILE-FORM (FORM &KEY LAP) (IL:* IL:\;  "Edited 31-Jan-92 15:20 by jrb:") (LET ((*CONTEXT* (MAKE-CONTEXT :TOP-LEVEL-P T :VALUES-USED 0)) (*ENVIRONMENT* (MAKE-ENV :PARENT T)) (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE)) (*PROCESSED-FUNCTIONS* NIL) (*UNKNOWN-FUNCTIONS* NIL) (*OUTSTANDING-LOOSE-FORMS* NIL) (*LAP-FLG* LAP) (IL:SPECVARS IL:SPECVARS) (IL:LOCALVARS IL:LOCALVARS) (IL:LOCALFREEVARS NIL) (IL:GLOBALVARS IL:GLOBALVARS) VALUE) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (PROGV (IF *ANY-DIAGNOSTICS* NIL `(*ANY-DIAGNOSTICS* *ANY-SERIOUS-DIAGNOSTICS*)) (IF *ANY-DIAGNOSTICS* NIL `(0 0)) (SETQ VALUE (MULTIPLE-VALUE-LIST (SCAN-ONE-FORM (REMOVE-COMMENTS FORM) *COMPILE-DEFINER-CONTEXT*))) (IF *OUTSTANDING-LOOSE-FORMS* (SETQ VALUE (MULTIPLE-VALUE-LIST (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS *COMPILE-DEFINER-CONTEXT*)))) (WARN-ABOUT-UNKNOWN-FUNCTIONS) (COMPILATION-VALUES VALUE)))) (DEFUN RAW-COMPILE (NAME DEFINITION) (LET* ((*CURRENT-FUNCTION* NAME) (LAP-FN (COMPILE-ONE-LAMBDA NAME DEFINITION)) COMPILED-DEFN) (WHEN (NOT (NULL *LAP-FLG*)) (PPRINT LAP-FN (IF (STREAMP *LAP-FLG*) *LAP-FLG* *STANDARD-OUTPUT*))) (CONDITION-CASE (SETQ COMPILED-DEFN (LET ((DCODE (D-ASSEM:ASSEMBLE-FUNCTION LAP-FN))) (UNWIND-PROTECT (D-ASSEM:INTERN-DCODE DCODE) (D-ASSEM:RELEASE-DCODE DCODE)))) (ASSEMBLER-ERROR (CONDITION) (FORMAT *ERROR-OUTPUT* "~&~A~%" CONDITION) (RETURN-FROM RAW-COMPILE NIL))) COMPILED-DEFN)) (DEFUN COMPILE-DEFINER-DEFINER (COMPILER-CONTEXT FORM) (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV) (CDR FORM) (LET* ((MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION)) (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION)) (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV))) (IF *COMPILING-DEFINER* (SCAN-ONE-FORM BODY COMPILER-CONTEXT) (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (LET ((*COMPILING-DEFINER* T) (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER NAME)) VALUE) (SETQ VALUE (SCAN-ONE-FORM BODY COMPILER-CONTEXT)) (IF *OUTSTANDING-LOOSE-FORMS* (SETQ VALUE (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))) VALUE)))))) (DEFUN COMPILE-DEFINER-NAMED-PROGN (COMPILER-CONTEXT FORM) (DESTRUCTURING-BIND (DEFINER-NAME NAME &REST PROGN-FORMS) (CDR FORM) (IF *COMPILING-DEFINER* (MAPC #'(LAMBDA (FORM) (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) PROGN-FORMS) (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) (LET ((*COMPILING-DEFINER* T) (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER-NAME NAME))) (MAPC #'(LAMBDA (FORM) (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) PROGN-FORMS) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)))) NAME)) (DEFUN COMPILE-DEFINER-PROCESS-FUNCTION (COMPILER-CONTEXT MESSAGE NAME DEFINITION) (PUSH NAME *PROCESSED-FUNCTIONS*) (SETQ *UNKNOWN-FUNCTIONS* (REMOVE NAME *UNKNOWN-FUNCTIONS* :KEY 'CAR)) (LET ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*)) COMPILED-DEFN) (IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:") (SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*) *HOST-ARCHITECTURE*) (SETQ COMPILED-DEFN (RAW-COMPILE NAME DEFINITION)) (WHEN (AND (NOT (IL:HASDEF NAME 'IL:FUNCTIONS)) (CONSP (IL:GETD NAME))) (SETF (GET NAME 'IL:EXPR) (IL:GETD NAME))) (SETF (SYMBOL-FUNCTION NAME) COMPILED-DEFN) NAME)) (DEFUN COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT) (IL:* IL:|;;|  "Compile any outstanding loose forms in the context of a structure definition being compiled") (WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*)) (LET* ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*)) COMPILED-DEFN) (IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:") (SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*) *HOST-ARCHITECTURE*) (SETQ COMPILED-DEFN (RAW-COMPILE *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE *OUTSTANDING-LOOSE-FORMS* )))) (SETQ *OUTSTANDING-LOOSE-FORMS* NIL) (FUNCALL COMPILED-DEFN)))) (IL:* IL:|;;| "Arrange for correct compiler to be used.") (IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:FILETYPE :COMPILE-FILE) (IL:* IL:|;;| "Arrange for the correct makefile environment") (IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 1992 1993)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP