;-*- Mode:Common-Lisp; Package:Compiler; Base:10 -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved. ;;; Copyright (C) 1980, Massachusetts Institute of Technology. ;;;; *-----------------------------------------------------------* ;;;; | -- TI Explorer Lisp Compiler -- | ;;;; | This file contains the COMPILE-FILE function and related | ;;;; | support for compiling from files and streams. | ;;;; *-----------------------------------------------------------* ;;; Feb. 1984 - Version 98 from MIT via LMI. ;;; July 1984 - TI modifications: ;;; Modify message for warning on top-level atom (bug report 150). ;;; Change COMPILE-FILE argument OUTPUT-FILENAME to OUTPUT-FILE. ;;; Add support for OPTIMIZE and INLINE declarations. ;;; Etc. ;;; 07/25/84 - Update to match MIT patch 98.30: modify COMPILE-FILE arguments, ;;; COMPILE-STREAM documentation, and function DEFUN-COMPATIBILITY ;;; to eliminate :FEXPR and :EXPR symbol references. ;;; Also added :VERBOSE option and ARGLIST declaration to COMPILE-FILE. ;;; 09/06/84 - Add :TARGET option to COMPILE-FILE and return error status. ;;; 11/12/84 - Generate .EXFASL file instead of .QFASL for Explorer. ;;; 12/07/84 - Allow using .XFASL instead of .EXFASL . ;;; 12/26/84 - Use SI:EVAL1 instead of EVAL; add use of FILE-CONSTANTS-LIST. ;;; 1/17/85 - Collect timing information. ;;; 1/18/85 - Modify handling of PROCLAIM. ;;; 1/25/85 - Fix QC-FILE for output file type on cross-compilation. ;;; 2/16/85 - Discard top-level atoms in COMPILE-STREAM instead of fasdumping; ;;; remove REL file support (conditional on #+MIT). ;;; 2/23/85 - Record :MODE attribute in object file as :ZETALISP instead of :LISP. ;;; 4/02/85 - New severity of :IGNORABLE-MISTAKE for WARN. ;;; 4/15/85 - Fix to use CLI:NAMED-LAMBDA in Common-Lisp mode compile file. ;;; 4/25/85 - Add COMPILE-FORM; expand all macros in cold load files. ;;; 7/24/85 - Reduce value of QC-FILE-WHACK-THRESHOLD to fix SPR 7. ;;; 9/23/85 - Moved a few variable declarations to the DEFS file. ;;; 9/26/85 - Fix to start new whack between functions within a top-level PROGN. [SPR 804] ;;; 10/21/85 - Fix QC-FILE-COMMON handling of EXPORT etc. [SPR 884] ;;; 1/14/86 - Fix merging of output pathname in QC-FILE. ;;; 2/06/86 - Deleted function MEMQL - no longer used. ;;; 3/08/86 - Moved SPECIAL, UNSPECIAL, and PROCLAIM to new file MINDEFS. ;;; 4/06/86 - Converted from Zetalisp to Common Lisp. ;;; 5/19/86 - Eliminated use of MEMQ and PUTPROP. ;;; 5/28/86 - Deleted function QC-FILE-RESET -- what it used to do is now done ;;; by COMPILER-WARM-BOOT. ;;; 6/04/86 - Moved COMPILE-FILE and QC-FILE before COMPILE-STREAM. ;;; 6/18/86 - Modify to work without MAKE-SYSTEM being loaded. ;;; 8/11/86 - Major changes to COMPILE-DRIVER, QC-FILE-COMMON, etc. ;;; 8/23/86 - Eliminated remnants of READ-THEN-PROCESS-FLAG. ;;; 9/30/86 - Moved BARF, WARN, and PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED ;;; to file COMPILE, QC-FILE-LOAD to ZETALISP, DECLARE-OPTIMIZE to P1FUNS. ;;; 11/21/86 - Updates to QC-FILE and COMPILE-TIME-EVAL. Remove optimizers for DEFUN etc. ;;; 1/15/87 - Give warning on undefined function used at top level. ;;; 1/16/87 - Fix the Fasl Update command. ;;; 2/06/87 - Use SI:COPY-OBJECT-TREE in COMPILE-TIME-EVAL . ;;; 2/07/87 - Remove write-protection of SOURCE-CODE-AREA . ;;; 2/10/87 - Fix FASD-BREAKOFF-FUNCTION for non-top-level DEFMACRO. ;;; 3/07/87 - Update QC-FILE warning for missing file attributes. ;;; 4/23/87 - Fix FASD-BREAKOFF-FUNCTION for SPR 4903. ;;; 5/05/87 - Fix COMPILE-TOP-LEVEL-FORM for SPR 4544 and 4508. ;;;------------------ The following done after Explorer release 3.0 ------ ;;; 6/17/87 - Fix COMPILE-TOP-LEVEL-FORM for SPR 5063. ;;; 7/22/87 - Eliminate use of *LAST-ADDRESS-READ* in COMPILE-STREAM and COMPILE-FORM. ;;; 7/30/87 - Update area usage in QC-FILE-WORK-COMPILE . ;;;------------------ The following done after Explorer release 4.0 ------ ;;; 4/13/88 DNG - Fix COMPILE-STREAM for SPR 7234. ;;;------------------ The following done for Explorer release 5.0 ------ ;;; 7/26/88 JHO - Update QC-FILE, COMPILE-STREAM, COMPILE-TIME-EVAL, COMPILE-FORM, and ;;; FASL-UPDATE-STREAM to support FILE-LOCAL-DECLARATIONS-DEF-ALIST. ;;; 8/04/88 DNG - Remove :TARGET option from COMPILE-FILE doc string. ;;; Bind SELF to NIL in COMPILE-STREAM. ;;; 8/19/88 clm - Updated QC-FILE-COMMON to support FILE-LOCAL-DECLARATIONS-DEF-ALIST. ;;;------------------ The following done for Explorer release 6.0 ------ ;;; 1/25/89 DNG - Fix large index handling in FASD-BREAKOFF-FUNCTION . ;;; 3/16/89 DNG - Include updates to QC-FILE etc. for CLOS - environment support. ;;; 4/11/89 DNG - Remove obsolete code for VM1. Change EVAL1 to *EVAL. ;;; 4/12/89 DNG - Remove unused code for REL files. Deleted unused variable QC-FILE-PACKAGE . ;;; 4/22/89 DNG - Update COMPILE-STREAM and COMPILE-TOP-LEVEL-FORM for supporting Scheme. ;;; 5/18/89 DNG - Fix bug in PUTDECL-ALIST . ;;; Note: in the comments in this file, QFASL usually means either QFASL, XFASL, or XLD. (DEFVAR QC-FILE-IN-CORE-FLAG :UNBOUND "Holds an argument to QC-FILE which, if non-NIL, causes fasl-updating instead of compilation.") (DEFPARAMETER QC-FILE-WHACK-THRESHOLD (- LENGTH-OF-FASL-TABLE 1024.) "Generate a new whack in the output XFASL file when fasl table gets this big.") (DEFVAR TARGET-FEATURES NIL) ; *FEATURES* list for the target machine (EVAL-WHEN (EVAL COMPILE) (UNLESS (FBOUNDP 'SYS:SCHEME-ON-P) ;; The official definition of this is in "SYS:PUBLIC.SCHEME;MODE". SYS: (DEFSUBST SCHEME-ON-P (&OPTIONAL GLOBALLY) "Returns true if the current Lisp Mode is :SCHEME and returns false otherwise. If GLOBALLY is non-NIL, the global bindings, instead of the local bindings, are checked." (IF GLOBALLY (EQ (SYMEVAL-GLOBALLY '*LISP-MODE*) :SCHEME) (EQ *LISP-MODE* :SCHEME))))) (DEFUN COMPILE-FILE (&OPTIONAL INPUT-FILENAME &KEY OUTPUT-FILE LOAD SET-DEFAULT-PATHNAME (VERBOSE COMPILER-VERBOSE VERBOSE-SUPPLIED) TARGET DECLARE ((:PACKAGE PACKAGE-SPEC)) ((:SUPPRESS-DEBUG-INFO *SUPPRESS-DEBUG-INFO*) *SUPPRESS-DEBUG-INFO*) #+compiler:debug MERCILESS ) "Compile source file INPUT-FILE to an object file named OUTPUT-FILE. OUTPUT-FILE defaults based on INPUT-FILE, which defaults using the FS:LOAD-PATHNAME-DEFAULTS. Additional optional arguments are: :LOAD if true means to load the output file after compiling. :VERBOSE if true means to print the name of each function as it is compiled. :DECLARE is a list of declaration specifiers. :SET-DEFAULT-PATHNAME if true means to set the default pathname. :PACKAGE is the package to compile in. :SUPPRESS-DEBUG-INFO if true discards debugging information and documentation strings of functions whose names are not EXPORTed. Two values are returned; the first is the output file pathname and the second is a status code equal to one of the following constants: COMPILER:OK, COMPILER:WARNINGS, COMPILER:ERRORS, or COMPILER:FATAL." ;; :TARGET is the name of the machine for which code will be generated. ;; 2/01/86 - Added option :SUPPRESS-DEBUG-INFO. ;; 3/14/86 - Added option :MERCILESS to suppress defaulting target ;; definitions from the host environment. (DECLARE (ARGLIST INPUT-FILE &KEY :OUTPUT-FILE :LOAD :VERBOSE :SET-DEFAULT-PATHNAME :PACKAGE :DECLARE #+compiler:debug :TARGET :SUPPRESS-DEBUG-INFO #+compiler:debug :MERCILESS )) (DECLARE (VALUES OUTPUT-FILE ERROR-STATUS)) (UNLESS (NULL TARGET) (SETQ TARGET (VALIDATE-TARGET TARGET T)) ) (MULTIPLE-VALUE-BIND ( OUTFILE STATUS ) (LET (( COMPILER-VERBOSE VERBOSE ) ( DECLARATION-LIST (IF (OR (NULL DECLARE) (CONSP (FIRST DECLARE))) DECLARE ; list of declaration specifiers (LIST DECLARE)) ) ; make list from single specifier #+compiler:debug ( *DEFAULT-DEFS-FROM-HOST* (NOT MERCILESS) )) (COND #+compiler:debug ((keywordp output-file) (let-unless-constant (( target-processor (or target host-processor) )) (qc-file-mem input-filename package-spec declaration-list (not set-default-pathname)))) (T (INHIBIT-STYLE-WARNINGS (QC-FILE (OR INPUT-FILENAME "") OUTPUT-FILE NIL NIL PACKAGE-SPEC DECLARATION-LIST (NOT SET-DEFAULT-PATHNAME) NIL TARGET)) )) ) (WHEN (AND LOAD (< STATUS FATAL)) (IF VERBOSE-SUPPLIED (LOAD OUTFILE :VERBOSE VERBOSE) (LOAD OUTFILE))) (VALUES OUTFILE STATUS) ) ) (DEFUN QC-FILE (INFILE &OPTIONAL OUTFILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC FILE-LOCAL-DECLARATIONS DONT-SET-DEFAULT-P IGNORE ; used to be READ-THEN-PROCESS-FLAG #.(IF (GET-FOR-TARGET 'TARGET-PROCESSOR 'SYSTEM-CONSTANT) 'IGNORE 'TARGET-PROCESSOR) &AUX GENERIC-PATHNAME QC-FILE-MACROS-EXPANDED (QC-FILE-RECORD-MACROS-EXPANDED T) ( DECLARATIONS-IGNORED DECLARATIONS-IGNORED ) ( INLINE-DECLARATIONS INLINE-DECLARATIONS ) ( *RETURN-STATUS* OK ) ( SI:FDEFINE-FILE-DEFINITIONS NIL )) "Compile Lisp source file INFILE, producing a binary file and calling it OUTFILE. PACKAGE-SPEC specifies which package to read the source in \(usually the file's attribute list provides the right default). LOAD-FLAG and IN-CORE-FLAG are semi-losing features; leave them NIL." ;; 1/25/85 DNG - Fix target file type. ;; 2/05/85 DNG - Modify target processor handling to allow different *FEATURES* ;; list for Lambda and Cadr. ;; 9/17/85 DNG - Use new function PROCESSOR-TYPE-FOR-FILE. ;; 1/14/86 DNG - Fix merging of output pathname to always have correct ;; type and version: ;; * Never write a ".LISP" file. ;; * Supersede the same version as the input file if the name ;; of the output file is the same as that of the input file. ;; * If a different name is specified for the output, or if ;; the output explicitely specifies "#>", then ;; write a new version one greater than the last version. ;; 1/31/86 DNG - Bind SI:FDEFINE-FILE-DEFINITIONS to NIL so it doesn't accumulate ;; pointers into the compiler temporary area. ;; 3/03/86 DNG - When cross-compiling, ADVISE FDEFINE so that functions definitions ;; within an (EVAL-WHEN (COMPILE) ...) are defined in the target envirionment. ;; 5/29/86 DNG - Modified to work when TARGET-PROCESSOR is a constant. ;; 6/18/86 DNG - Modify to work when SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE is not defined. ;; 9/04/86 DNG - Use new function MERGE-PATHNAMES-WITH-NEW-TYPE; ;; return the :TRUENAME of the output stream instead of the :PATHNAME. ;; 9/05/86 DNG - Give warning on missing attributes. [SPR 1165] ;;11/21/86 DNG - Remove call to SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE which no ;; longer exists in release 3. Use ZETA-C:C-COMPILE-FILE for ".c" files. ;; Delete binding of SI:INTERPRETER-DECLARATION-TYPE-ALIST. ;; 2/09/87 DNG - Modify test for missing file attributes. ;; 3/02/87 DNG - BIND interpreter environment to NIL since not done by file attribute bindings anymore. ;; 3/07/87 DNG - Modify test for missing file attributes again to try to keep up with FS changes. ;; 7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST ;;10/26/88 DNG - Add binding of *COMPILE-FILE-ENVIRONMENT* and call CLEAN-UP-ENVIRONMENT. ;;10/31/88 DNG - Add binding of *LOCAL-ENVIRONMENT* so it has the correct ;; value when COMPILE-STREAM calls PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED. ;;11/03/88 DNG - Add an UNWIND-PROTECT to ensure that CLEAN-UP-ENVIRONMENT is called. ;; 4/12/89 DNG - Add setting of ENV-GLOBAL-ENV. (DECLARE (VALUES OUTFILE STATUS)) (record-individual-time 'qc-file (WHEN-SUPPORTING-CROSS-COMPILATION (WHEN (NULL TARGET-PROCESSOR) (SETQ TARGET-PROCESSOR HOST-PROCESSOR))) ;; Default the specified input and output file names. Open files. (SETQ INFILE (FS:MERGE-PATHNAME-DEFAULTS INFILE FS:LOAD-PATHNAME-DEFAULTS NIL)) (WHEN (EQ (SEND INFILE :CANONICAL-TYPE) :C) (LET ((X (FIND-PACKAGE "ZETA-C"))) (UNLESS (NULL X) (LET ((*PACKAGE* (IF PACKAGE-SPEC (FIND-PACKAGE PACKAGE-SPEC) *PACKAGE*))) (RETURN-FROM QC-FILE (VALUES (FUNCALL (INTERN "C-COMPILE-FILE" X) INFILE) OK)))))) (WITH-OPEN-STREAM (INPUT-STREAM (FILE-RETRY-NEW-PATHNAME (INFILE FS:FILE-ERROR) (SEND INFILE :OPEN-CANONICAL-DEFAULT-TYPE ':LISP))) ;; The input pathname might have been changed by the user in response to an error. ;; Also, find out what type field was actually found. (SETQ INFILE (SEND INPUT-STREAM :PATHNAME)) (OR DONT-SET-DEFAULT-P (FS:SET-DEFAULT-PATHNAME INFILE FS:LOAD-PATHNAME-DEFAULTS)) (SETQ GENERIC-PATHNAME (SEND INFILE :GENERIC-PATHNAME)) (SETQ OUTFILE (MERGE-PATHNAMES-WITH-NEW-TYPE INFILE INPUT-STREAM OUTFILE (TARGET-BINARY-FILE-TYPE TARGET-PROCESSOR))) (WHEN-SUPPORTING-CROSS-COMPILATION (SETQ TARGET-PROCESSOR (PROCESSOR-TYPE-FOR-FILE OUTFILE))) ;; Get the file property list again, in case we don't have it already or it changed (FS:READ-ATTRIBUTE-LIST GENERIC-PATHNAME INPUT-STREAM) ;; Bind all the variables required by the file property list. (MULTIPLE-VALUE-BIND (VARS VALS) (FS:FILE-ATTRIBUTE-BINDINGS GENERIC-PATHNAME) (DECLARE (UNSPECIAL VARS)) (UNLESS (OR (AND (NULL VARS) (COMMON-LISP-ON-P)) (MEMBER ':COMMON-LISP VALS)) ; Common Lisp doesn't require an attribute line (DOLIST (X '((SI:*LISP-MODE* "Mode") (*PACKAGE* "Package") (*READ-BASE* "Base"))) (UNLESS (OR (MEMBER (FIRST X) VARS :TEST #'EQ) (AND (EQ (FIRST X) '*PACKAGE*) PACKAGE-SPEC)) (FORMAT T "~&~A not specified; assuming ~A." (SECOND X) (SYMBOL-VALUE (FIRST X)))))) (PROGV VARS VALS (LET* (( TARGET-FEATURES (COND ((EQ TARGET-PROCESSOR HOST-PROCESSOR) NIL) ((AND (EQ HOST-PROCESSOR ':EXPLORER) (MEMBER TARGET-PROCESSOR '(:CLM :ELROY :JUDY) :TEST #'EQ)) (LIST* TARGET-PROCESSOR :IEEE-FLOATING-POINT *FEATURES*) ) (T (CONS TARGET-PROCESSOR (SET-DIFFERENCE *FEATURES* '(:EXPLORER :CADR :LAMBDA)))) )) (SI:*INTERPRETER-ENVIRONMENT* NIL) (SI:*INTERPRETER-FUNCTION-ENVIRONMENT* NIL) ;; Uncomment the next line if cross-compilation is ever re-enabled. ;;(*TARGET-ENVIRONMENT* (ENSURE-TARGET-ENVIRONMENT TARGET-PROCESSOR)) (*COMPILE-FILE-ENVIRONMENT* (EXTEND-ENVIRONMENT :PARENT *TARGET-ENVIRONMENT*)) (*LOCAL-ENVIRONMENT* *COMPILE-FILE-ENVIRONMENT*)) (SETF (ENV-GLOBAL-ENV *COMPILE-FILE-ENVIRONMENT*) *COMPILE-FILE-ENVIRONMENT*) (WHEN-SUPPORTING-CROSS-COMPILATION (WHEN (EQ TARGET-PROCESSOR ':LAMBDA) ;; Lambda and Cadr are different only in the features list. (SETQ TARGET-PROCESSOR ':CADR) )) (UNWIND-PROTECT (WITH-OPEN-FILE (FASD-STREAM OUTFILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 16. :IF-EXISTS (IF (NUMBERP (SEND OUTFILE :VERSION)) :SUPERSEDE :NEW-VERSION)) (LOCKING-RESOURCES (SETQ OUTFILE (SEND FASD-STREAM :TRUENAME)) (FASD-INITIALIZE) (FASD-START-FILE) (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR) (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM #'QC-FILE-WORK-COMPILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC FILE-LOCAL-DECLARATIONS NIL T) (UNWIND-PROTECT (LET (( *POSSIBLE-SPECIAL-BINDINGS* NIL )) (ADVISE FDEFINE :AROUND LOAD-FOR-TARGET NIL (IF (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR) (EQ (CAR-SAFE (FIRST ARGLIST)) ':TARGET)) :DO-IT (APPLY #'CROSS-LOAD-FDEFINE ARGLIST) ) ) (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM #'QC-FILE-WORK-COMPILE LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC FILE-LOCAL-DECLARATIONS NIL T) ) (UNADVISE FDEFINE :AROUND LOAD-FOR-TARGET) ) ) ;; Output a record of the macros expanded and their current sxhashes. (WHEN QC-FILE-MACROS-EXPANDED (FASD-FORM `(SI:FASL-RECORD-FILE-MACROS-EXPANDED ',QC-FILE-MACROS-EXPANDED))) (FASD-END-WHACK) (FASD-END-FILE))) (CLEAN-UP-ENVIRONMENT *COMPILE-FILE-ENVIRONMENT*)) )))) ) (VALUES OUTFILE *RETURN-STATUS*) ) (DEFUN PROCESSOR-TYPE-FOR-FILE ( OUTFILE ) ;; Given an object file pathname, return the target processor corresponding to the file type. (CASE (SEND OUTFILE :CANONICAL-TYPE) ( :XFASL ':EXPLORER) ( :YFASL ':ELROY) ( :XLD ':ELROY) ((:QFASL :REL) (IF (EQ TARGET-PROCESSOR ':CADR) ':CADR ':LAMBDA) ) ( OTHERWISE TARGET-PROCESSOR) ) ) (defvar *output-version-prompt-timeout* 30. "How long to wait (in seconds) when prompting for an output file version number.") (DEFPARAMETER OUTPUT-VERSION-CHOICES #!Z ; FQUERY wants numbers instead of characters in release 2 '(((:SAME "Same version as input") #\S #\s) ((:NEWEST "Next higher version") #\N #\n #\H #\h) ((:NEW-PATH "New Pathname") #\P #\p) ((:DEFAULT "Default") #\D #\d #\NEWLINE #\SPACE))) (defconstant ask-version-format-string "Output file ~A already exists. ~&What would you like to do [~A in ~D seconds]? ") (DEFUN MERGE-PATHNAMES-WITH-NEW-TYPE (INPUT-PATHNAME INPUT-STREAM OUTFILE DEFAULT-TYPE) ;; Return a pathname object based on OUTFILE, defaulting unspecified fields ;; from INPUT-PATHNAME except for the type which defaults to DEFAULT-TYPE. ;; The version defaults in accordance with *OUTPUT-VERSION-BEHAVIOR* [q.v.]. ;; The :ASK- values cause the user to be prompted. The user can choose ;; to give a new pathname, take the same version number as the source file, ;; or take the next higher version number. If the user does not respond ;; inside of *OUTPUT-VERSION-PROMPT-TIMEOUT* seconds, the default ;; (SAME or HIGHER) behavior is used. ;; ;; 9/05/86 DNG - Original version separated from QC-FILE and enhanced to ;; use *OUTPUT-VERSION-BEHAVIOR* [for SPR 2166]. (LET* ((EXPLICIT-OUTPUT-VERSION NIL) (INPUT-VERSION NIL) (OUTPUT-PATHNAME (LET ((DEFAULT-VERSION (IF (EQ *OUTPUT-VERSION-BEHAVIOR* ':NEWEST) ':NEWEST (PROGN (SETQ INPUT-VERSION (SEND (SEND INPUT-STREAM :TRUENAME) :VERSION)) (IF (NUMBERP INPUT-VERSION) INPUT-VERSION ':NEWEST))))) (IF (NULL OUTFILE) (SEND INPUT-PATHNAME :NEW-PATHNAME :TYPE DEFAULT-TYPE :VERSION DEFAULT-VERSION) (LET ((OUTPATH (IF (PATHNAMEP OUTFILE) OUTFILE ;; default the host from the input file (FS:PARSE-PATHNAME OUTFILE NIL INPUT-PATHNAME)))) (WHEN (NUMBERP (SEND OUTPATH :VERSION)) (SETQ EXPLICIT-OUTPUT-VERSION T)) (FS:MERGE-PATHNAME-DEFAULTS OUTPATH (SEND INPUT-PATHNAME :NEW-PATHNAME :TYPE DEFAULT-TYPE :VERSION DEFAULT-VERSION) DEFAULT-TYPE (IF (STRING-EQUAL (SEND OUTPATH :NAME) (SEND INPUT-PATHNAME :NAME)) DEFAULT-VERSION ':NEWEST)) ) )))) (IF (AND (NOT EXPLICIT-OUTPUT-VERSION) (NUMBERP INPUT-VERSION) (NOT (MEMBER *OUTPUT-VERSION-BEHAVIOR* '(:SAME :NEWEST))) (EQL INPUT-VERSION (SEND OUTPUT-PATHNAME :VERSION))) (let* ((new-output-pathname (send output-pathname :new-version :newest)) (existing-pathname (probe-file new-output-pathname)) (newest-version (AND existing-pathname (send existing-pathname :version)))) (if (OR (NOT (NUMBERP NEWEST-VERSION)) (< newest-version input-version)) ;; no collision OUTPUT-PATHNAME ;; collision--do something special (FLET ((OUTPUT-VERSION-PROMPT (INPUT OUTPUT DEFAULT FORMAT-STRING &REST FORMAT-ARGS) (CASE (WITH-TIMEOUT ((* 60. *OUTPUT-VERSION-PROMPT-TIMEOUT*) :DEFAULT) (APPLY #'FQUERY `(:TYPE :TYI :CHOICES ,OUTPUT-VERSION-CHOICES) FORMAT-STRING FORMAT-ARGS)) (:SAME OUTPUT) (:NEWEST (SEND OUTPUT :NEW-VERSION :NEWEST)) (:NEW-PATH (PROMPT-AND-READ `(:PATHNAME :DEFAULTS ,OUTPUT :VERSION ,(SEND DEFAULT :VERSION)) "~&New output file for input file ~A: " INPUT)) (:DEFAULT (FORMAT *QUERY-IO* "Timeout--defaulting to ~A" DEFAULT) DEFAULT)))) (ccase *output-version-behavior* (:same output-pathname) ((:newest :higher) new-output-pathname) (:ask-higher (output-version-prompt input-pathname output-pathname new-output-pathname ask-version-format-string output-pathname #\N *output-version-prompt-timeout*) ) (:ask-same (output-version-prompt input-pathname output-pathname output-pathname ask-version-format-string output-pathname #\S *output-version-prompt-timeout*) ) )))) OUTPUT-PATHNAME))) (defun clean-up-environment (environment) ;; Called by QC-FILE at the end of compilation. ;; Call DELETED-FROM-ENVIRONMENT on each class object in the temporary environment. (let* ((frame (first (env-symbol-props environment))) (plist (getf frame ticlos:class-property '()))) (do ((tail plist (cddr tail))) ((endp tail)) (deleted-from-environment (second tail) environment))) (values)) (DEFUN PUTDECL-ALIST (FUNCTION-SPEC VALUE) ;; 3/16/89 DNG - Rewritten using environments. ;; 5/18/89 DNG - Fix storing of definition of list fspecs other than :PROPERTY. (unless (null *compile-file-environment*) (cond ((symbolp function-spec) (setf (first (env-functions *compile-file-environment*)) (list* (locf (symbol-function FUNCTION-SPEC)) value (first (env-functions *compile-file-environment*))))) ((and (eq (first function-spec) :property) (symbolp (second function-spec))) (setf (get-from-environment (second function-spec) (third function-spec) nil *compile-file-environment*) value)) (t (function-spec-putprop-in-environment function-spec value fdef-key *compile-file-environment*))) ) value) (defun file-local-def (function-spec) ;; 08/16/88 clm - New lookup function to see if FUNCTION-SPEC already ;; declared in FILE-LOCAL-DECLARATIONS-DEF-ALIST ;; 10/04/88 DNG - Rewritten using environments. ;; 3/17/89 DNG - Don't access global symbol properties. (cond ((atom function-spec) (get-from-frame-list (LOCF (SYMBOL-FUNCTION function-spec)) (env-functions *compile-file-environment*) nil)) ((and (eq (first function-spec) :property) (symbolp (second function-spec))) (get-from-environment (second function-spec) (third function-spec) nil *compile-file-environment* t)) (t (function-spec-get-from-environment function-spec fdef-key nil *compile-file-environment*))) ) (comment ; old way in release 5 (PROCLAIM '(INLINE PUTDECL-ALIST)) (DEFUN PUTDECL-ALIST (NAME VALUE) "To add an entry to the FILE-LOCAL-DECLARATIONS-DEF-ALIST" (SETF FILE-LOCAL-DECLARATIONS-DEF-ALIST (ACONS NAME VALUE FILE-LOCAL-DECLARATIONS-DEF-ALIST))) (proclaim '(inline file-local-def)) (defun file-local-def (function-spec) ;; 08/16/88 clm - New lookup function to see if FUNCTION-SPEC already ;; declared in FILE-LOCAL-DECLARATIONS-DEF-ALIST (if (symbolp function-spec) (cdr (assoc function-spec file-local-declarations-def-alist :test #'eq)) (cdr (assoc function-spec file-local-declarations-def-alist :test 'equal))) ) ) ; end comment ;Compile a source file, producing a QFASL file in the binary format. ;If QC-FILE-LOAD-FLAG is T, the stuff in the source file is left defined ;as well as written into the QFASL file. If QC-FILE-IN-CORE-FLAG is T, ;then rather than recompiling anything, the definitions currently in core ;are written out into the QFASL file. ;Note that macros and specials are put on LOCAL-DECLARATIONS to make them temporary. ;They are also sent over into the QFASL file. (DEFUN FASD-UPDATE-FILE (INFILE &OPTIONAL OUTFILE) (INHIBIT-STYLE-WARNINGS (QC-FILE INFILE OUTFILE NIL T))) ;This function does all the "outer loop" of the compiler. It is called ;by the editor as well as the compiler. ;INPUT-STREAM is what to compile. GENERIC-PATHNAME is for the corresponding file. ;FASD-FLAG is NIL if not making a QFASL file. ;PROCESS-FN is called on each form. ;QC-FILE-LOAD-FLAG, QC-FILE-IN-CORE-FLAG, and PACKAGE-SPEC are options. ;FILE-LOCAL-DECLARATIONS is normally initialized to NIL, ;but you can optionally pass in an initializations for it. (DEFUN COMPILE-STREAM (INPUT-STREAM GENERIC-PATHNAME FASD-FLAG PROCESS-FN QC-FILE-LOAD-FLAG QC-FILE-IN-CORE-FLAG PACKAGE-SPEC &OPTIONAL (FILE-LOCAL-DECLARATIONS NIL) IGNORE ; used to be READ-THEN-PROCESS-FLAG COMPILING-WHOLE-FILE-P OPERATION-TYPE) "This function does all the \"outer loop\" of the compiler, for file and editor compilation. Expressions to be compiled are read from INPUT-STREAM. The caller is responsible for handling any file attributes. GENERIC-PATHNAME is the file to record information for and use the attributes of. It may be NIL if compiling to core. FASD-FLAG is NIL if not making an object file. PROCESS-FN is called on each form. QC-FILE-LOAD-FLAG, QC-FILE-IN-CORE-FLAG, and PACKAGE-SPEC are options. FILE-LOCAL-DECLARATIONS is normally initialized to NIL, but you can optionally pass in an initializations for it. COMPILING-WHOLE-FILE-P should be T if you are processing all of the file." ;; 2/23/85 - Make sure :MODE is :ZETALISP or :COMMON-LISP, not just :LISP . ;; 2/27/85 - Record version number of the "Compiler" sub-system in the object file. ;; 2/28/85 - Test for starting new whack moved from here to QC-FILE-COMMON. [SPR 804] ;; Record outside value of OPTIMIZE switches in the object file. ;; 1/31/86 - Push pathname onto COLD-LOAD-FILES if it has COLD-LOAD attribute. ;; 4/24/86 - Set *LAST-ADDRESS-READ*. ;; 4/25/86 - Fix to use GLOBAL:READ instead of CLI:READ. ;; 6/18/86 - Modify to work when SI:GET-SYSTEM-VERSION is not defined. ;; 6/30/86 - Record the system name in the object file if different from "SYSTEM". ;; 8/08/86 - Use macro WITH-COMPILE-DRIVER-BINDINGS. ;; 9/11/86 - Warn when in Zetalisp mode but not using the ZLC package. ;; 9/26/86 - Check QC-FILE-CHECK-INDENTATION at each read instead of only at the ;; beginning so that it can be changed within the file. ;; When compiling in memory, read into a write-protected area. [SPR 405] ;; 10/08/86 - Suppress "end of data" messages in Eval Buffer. [SPR 1041] ;; 2/07/87 - Remove use of write-protected area for reading -- it was causing ;; more problems than it was solving. ;; 3/20/87 - Fix to not warn about not using ZLC package when GLOBAL is being used instead. ;; 7/22/87 - Read in SOURCE-CODE-AREA in QC-FILE as well as Compile Buffer; ;; eliminate use of *LAST-ADDRESS-READ*. ;; 4/13/88 DNG - Re-instate test for starting a new whack here as well as ;; in QC-FILE-COMMON in order to preferentially break between ;; top-level forms. [SPR 7234] ;; 7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST ;; 8/04/88 DNG - Bind SELF to NIL. ;; 1/03/89 DNG - Don't record font list in the object file. (Just a waste of space.) ;; 3/16/89 DNG - Don't need binding of FILE-LOCAL-DECLARATIONS-DEF-ALIST anymore. ;; 4/22/89 DNG - Include Scheme support: Warn if in Scheme mode without using the ;; Scheme package (or in Common Lisp mode without the LISP package). Fix ;; to expand top-level symbol defined by SCHEME:DEFINE-INTEGRABLE. (record-individual-time 'compile-stream (LET ((*PACKAGE* *PACKAGE*) (*READ-BASE* *READ-BASE*) (*PRINT-BASE* *PRINT-BASE*) (OPTIMIZE-SWITCH OPTIMIZE-SWITCH) FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST ( FILE-CONSTANTS-LIST NIL ) ( *BARF-DEFAULTS* NIL ) ( SELF NIL ) ; Prevent accidental references to the window the compiler was invoked from. FDEFINE-FILE-PATHNAME) (FILE-OPERATION-WITH-WARNINGS (GENERIC-PATHNAME (OR OPERATION-TYPE ':COMPILE) COMPILING-WHOLE-FILE-P) (COMPILER-WARNINGS-CONTEXT-BIND ;; Override the package if required. It has been bound in any case. (AND PACKAGE-SPEC (SETQ *PACKAGE* (FIND-PACKAGE PACKAGE-SPEC))) ;; Override the generic pathname (SETQ FDEFINE-FILE-PATHNAME (LET ((PATHNAME (AND (MEMBER ':PATHNAME (SEND INPUT-STREAM :WHICH-OPERATIONS) :TEST #'EQ) (SEND INPUT-STREAM :PATHNAME)))) (AND PATHNAME (SEND PATHNAME :GENERIC-PATHNAME)))) (WHEN (AND (NOT (NULL FDEFINE-FILE-PATHNAME)) SI:FILE-IN-COLD-LOAD (NOT (MEMBER FDEFINE-FILE-PATHNAME COLD-LOAD-FILES :TEST #'EQ))) (LET (( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA )) ;; Let function CHECK-COLD know that this file has the :COLD-LOAD attribute. (PUSH FDEFINE-FILE-PATHNAME COLD-LOAD-FILES) ) ) ;; Having bound the variables, process the file. (LET ((QC-FILE-IN-PROGRESS T) (UNDO-DECLARATIONS-FLAG (NOT QC-FILE-LOAD-FLAG)) (LOCAL-DECLARATIONS NIL) (OPEN-CODE-MAP-SWITCH OPEN-CODE-MAP-SWITCH) (RUN-IN-MACLISP-SWITCH RUN-IN-MACLISP-SWITCH) (OBSOLETE-FUNCTION-WARNING-SWITCH OBSOLETE-FUNCTION-WARNING-SWITCH) (ALL-SPECIAL-SWITCH ALL-SPECIAL-SWITCH) (SOURCE-FILE-UNIQUE-ID) (FASD-PACKAGE NIL)) ;; Process any Common Lisp declaration specifiers found in ;; the FILE-LOCAL-DECLARATIONS list. The CATCH is used to ;; suppress warnings from PROCLAIM about unrecognized declarations ;; since FILE-LOCAL-DECLARATIONS list can be used for other things too. (LET (( WARN-CATCHER 'FILE-LOCAL-DECLARATIONS )) (DOLIST ( DECL FILE-LOCAL-DECLARATIONS ) (CATCH WARN-CATCHER (if (eq (first decl) 'def) (setf (file-local-def (second decl)) (cddr decl)) (PROCLAIM DECL)) ))) (WHEN FASD-FLAG ;; Copy all suitable file properties into the fasl file ;; Suitable means those that are lambda-bound when you read in a file. (LET ((PLIST (COPY-LIST (SEND GENERIC-PATHNAME :PLIST)))) ;; Remove unsuitable properties (DO ((L (LOCF PLIST))) ((NULL (CDR L))) (IF (AND (NOT (NULL (GET (CADR L) 'FS:FILE-ATTRIBUTE-BINDINGS))) (NOT (EQ (CADR L) ':FONTS))) ; this doesn't affect the object. (SETQ L (CDDR L)) (RPLACD L (CDDDR L)))) ;; Make sure the package property is really the package compiled in ;; Must load object file into same package compiled in ;; On the other hand, if we did not override it ;; and the attribute list has a list for the package, write that list. (UNLESS (AND (NOT (ATOM (GETF PLIST :PACKAGE))) (STRING-EQUAL (PACKAGE-NAME *PACKAGE*) (CAR (GETF PLIST ':PACKAGE)))) (SETF (GETF PLIST ':PACKAGE) (INTERN (PACKAGE-NAME *PACKAGE*) PKG-KEYWORD-PACKAGE))) ;; Make sure :MODE is :ZETALISP or :COMMON-LISP, not just :LISP . (SETF (GETF PLIST ':MODE) (LISP-MODE)) (COND ((ZETALISP-ON-P) (COND ((LET ((L (PACKAGE-USE-LIST *PACKAGE*))) (NOT (OR (MEMBER ZETALISP-PACKAGE L :TEST #'EQ) ; uses ZLC (MEMBER SI:PKG-GLOBAL-PACKAGE L :TEST #'EQ) ; uses GLOBAL (EQ (FIND-SYMBOL "MEM") 'GLOBAL:MEM) ; gets the right symbols some other way ))) (WARN ':ZETALISP ':IMPLAUSIBLE "Warning: this file is in Zetalisp mode but package ~A doesn't use the ZLC package." (PACKAGE-NAME *PACKAGE*))) ;;%%% Later add test here to do automatic MAKE-SYSTEM of the ;;%%% Zetalisp compatibility subsystem if not already loaded. )) ((si:SCHEME-ON-P) (LOCALLY (DECLARE (SPECIAL SI:SCHEME-PACKAGE)) (UNLESS (OR (MEMBER SI:SCHEME-PACKAGE (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ) ; uses SCHEME ; or gets the right symbols some other way (EQ (FIND-SYMBOL "DEFINE") (FIND-SYMBOL "DEFINE" SI:SCHEME-PACKAGE))) (WARN 'si:SCHEME-ON-P ':IMPLAUSIBLE "Warning: this file is in Scheme mode but package ~A doesn't use the Scheme package." (PACKAGE-NAME *PACKAGE*))))) ((COMMON-LISP-ON-P) (UNLESS (OR (MEMBER *LISP-PACKAGE* (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ) ; uses LISP (EQ (FIND-SYMBOL "DEFUN") 'DEFUN)) ; gets the right symbols some other way (WARN 'COMMON-LISP-ON-P ':IMPLAUSIBLE "Warning: this file is in Common Lisp mode but package ~A doesn't use the Lisp package." (PACKAGE-NAME *PACKAGE*))))) (AND INPUT-STREAM (MEMBER ':TRUENAME (SEND INPUT-STREAM :WHICH-OPERATIONS) :TEST #'EQ) (SETQ SOURCE-FILE-UNIQUE-ID (SEND INPUT-STREAM :TRUENAME)) (SETF (GETF PLIST ':QFASL-SOURCE-FILE-UNIQUE-ID) SOURCE-FILE-UNIQUE-ID) ) ;; If a file is being compiled across directories, remember where the ;; source really came from. (AND FDEFINE-FILE-PATHNAME FASD-STREAM (LET ((OUTFILE (AND (MEMBER ':PATHNAME (SEND FASD-STREAM :WHICH-OPERATIONS) :TEST #'EQ) (SEND FASD-STREAM :PATHNAME)))) (WHEN OUTFILE (SETQ OUTFILE (SEND OUTFILE :GENERIC-PATHNAME)) (AND (NEQ OUTFILE FDEFINE-FILE-PATHNAME) (SETF (GETF PLIST ':SOURCE-FILE-GENERIC-PATHNAME) FDEFINE-FILE-PATHNAME))))) (MULTIPLE-VALUE-BIND (MAJOR MINOR) (AND (FBOUNDP 'SI:GET-SYSTEM-VERSION) (SI:GET-SYSTEM-VERSION)) (SETF (GETF PLIST ':COMPILE-DATA) (LIST USER-ID SI:LOCAL-PRETTY-HOST-NAME (AND (FBOUNDP 'TIME:GET-UNIVERSAL-TIME) (TIME:GET-UNIVERSAL-TIME)) MAJOR MINOR (LET (( PROPS NIL )) (SETF (GETF PROPS 'OPTIMIZE-SWITCH) OPTIMIZE-SWITCH) (WHEN (FBOUNDP 'SI:GET-SYSTEM-VERSION) (MULTIPLE-VALUE-BIND ( V1 V2 ) (SI:GET-SYSTEM-VERSION (IF (EQ 'VERSION 'COMPILER:VERSION) 'COMPILER 'COMPILER2)) (UNLESS (NULL V1) (SETF (GETF PROPS 'VERSION) (LIST V1 V2) ))) (UNLESS (STRING-EQUAL SI:*SYSTEM-NAME* "SYSTEM") (SETF (GETF PROPS 'SI:*SYSTEM-NAME*) SI:*SYSTEM-NAME*)) ) PROPS)))) ;; First thing in QFASL file must be property list ;; These properties wind up on the GENERIC-PATHNAME. (FASD-FILE-PROPERTY-LIST PLIST))) (QC-PROCESS-INITIALIZE) (WHEN (NULL (SYMBOL-VALUE 'SOURCE-CODE-AREA)) (MAKE-AREA :NAME 'SOURCE-CODE-AREA :REPRESENTATION :LIST :GC :DYNAMIC)) (WITH-COMPILE-DRIVER-BINDINGS (DO ((EOF (CONS NIL NIL)) (FORM)) (NIL) ;; Detect EOF by peeking ahead, and also get an error now ;; if the stream is wedged. We really want to get an error ;; in that case, not make a warning. (LET ((CH (SEND INPUT-STREAM :TYI))) (OR CH (RETURN)) (SEND INPUT-STREAM :UNTYI CH)) (setq si:premature-warnings (append si:premature-warnings si:premature-warnings-this-object)) (let ((si:premature-warnings nil)) (LET ((DEFAULT-CONS-AREA (IF (OR QC-FILE-LOAD-FLAG ; Compile Buffer (NOT (SI:AREA-TEMPORARY-P QCOMPILE-TEMPORARY-AREA))) ; TGC on SOURCE-CODE-AREA QCOMPILE-TEMPORARY-AREA)) (WARN-ON-ERRORS-STREAM INPUT-STREAM) (QC-FILE-READ-IN-PROGRESS FASD-FLAG) ;looked at by XR-#,-MACRO (SI:*MAXIMUM-READ-BUFFER-SIZE* 256) ;; Include the following after everything has been EXPORTed that should be. ;;(SI:*RESTRICT-INTERNAL-SYMBOLS* T) ) (WARN-ON-ERRORS ('READ-ERROR "Error in reading") (LET-IF TARGET-FEATURES ((*FEATURES* TARGET-FEATURES)) (record-individual-time 'read (SETQ FORM (IF QC-FILE-CHECK-INDENTATION (READ-CHECK-INDENTATION INPUT-STREAM EOF) (READ INPUT-STREAM NIL EOF))) ))) ) (setq si:premature-warnings-this-object si:premature-warnings)) (WHEN (EQ FORM EOF) (RETURN)) (LOOP WHILE (AND (SYMBOLP FORM) (SI:SCHEME-ON-P)) ;; Expand symbols defined by SCHEME:DEFINE-INTEGRABLE . DO (LET ((L (GET FORM 'INTEGRABLE '||))) (IF (EQ L '||) (RETURN) (PROGN (PUSHNEW FORM MACROS-EXPANDED :TEST #'EQ) (SETQ FORM L))))) ;; Start a new whack if FASD-TABLE is getting too big. A smaller threshold ;; is used here than in QC-FILE-COMMON because it is safer to break here ;; (less likely to have gensym references spanning the boundary). [SPR 7234] (WHEN (AND FASD-FLAG (>= (FASD-TABLE-LENGTH) (- QC-FILE-WHACK-THRESHOLD 1000))) (FASD-END-WHACK) ) (IF (AND (ATOM FORM) FASD-FLAG) (WARN 'ATOM-AT-TOP-LEVEL ':IMPLAUSIBLE "The atom ~S appeared at top level; this will do nothing at FASLOAD time." FORM) (FUNCALL PROCESS-FN FORM)) ) ; end of DO loop ;; Copy MACROS-EXPANDED to QC-FILE-MACROS-EXPANDED when appropriate. (MACROS-EXPANDED-DEBUG-INFO MACROS-EXPANDED) ))) ; end of COMPILER-WARNINGS-CONTEXT-BIND (WHEN (EQ OPERATION-TYPE ':EVAL) ;; When evaluating a Zmacs buffer, OBJECT-OPERATION-WITH-WARNINGS is not used, ;; so "end of data" messages are not meaningful, so suppress them. [SPR 1041] (SETQ si:PREMATURE-WARNINGS NIL)) )))) ;;; COMPILE-STREAM when called by QC-FILE calls this on each form in the file (DEFUN QC-FILE-WORK-COMPILE (FORM) ;; Maybe macroexpand in temp area. ;; 7/30/87 DNG - For in-memory compile, bind DEFAULT-CONS-AREA to QCOMPILE-TEMPORARY-AREA. (LET-IF (NOT (AND QC-FILE-LOAD-FLAG (SI:AREA-TEMPORARY-P QCOMPILE-TEMPORARY-AREA))) ((DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA)) ;; Macro-expand and output this form in the appropriate way. (COMPILE-DRIVER FORM #'QC-FILE-COMMON NIL))) ;; Common processing of each form, for QC-FILE, FASD-UPDATE-FILE, and FASL-UPDATE-STREAM. ;; TYPE is one of: ;; SPECIAL - Evaluate at compile time and load time. Does not need to be compiled. ;; DECLARE - Evaluate at compile time only. ;; MACRO - Evaluate at compile time and compile for load-time execution. ;; RANDOM - Compile for load-time execution. (DEFUN QC-FILE-COMMON (FORM TYPE) ;; 9/26/85 DNG - Fix to start a new whack when necessary. [SPR 804] ;;10/21/85 DNG - When the form is to be both evaluated and fasdumped, ;; do the fasdump first so that it does not assume the ;; environment created by evaluating it. [SPR 884] ;; 3/03/86 DNG - Use EVAL-FOR-TARGET instead of SI:EVAL1 so that functions ;; defined within an (EVAL-WHEN (COMPILE) ...) are installed in ;; the target environment. ;; 7/28/86 DNG - Merged QC-FILE-FORM into this function. ;; 7/30/86 DNG - Modified to use the new function COMPILE-TOP-LEVEL-FORM. ;; 8/16/86 DNG - Update FASD-PACKAGE when an IN-PACKAGE form is processed. ;; 1/16/87 DNG - Evaluate declarations even when QC-FILE-IN-CORE-FLAG is true. [SPR 2852] ;; 8/16/88 clm - Changed to call FILE-LOCAL-DEF to check if there are duplicate definitions. ;;10/26/88 DNG - Pass *LOCAL-ENVIRONMENT* to COMPILE-TIME-EVAL. ;; 3/17/89 DNG - Avoid double-definition warning on a type-expander. (DECLARE (SYMBOL TYPE)) (UNLESS (ATOM FORM) ;; Start a new whack if FASD-TABLE is getting too big. (WHEN (AND (NOT QC-FILE-LOAD-FLAG) FASD-STREAM (>= (FASD-TABLE-LENGTH) QC-FILE-WHACK-THRESHOLD) ) (FASD-END-WHACK) ) ;; If supposed to fasdump as well as eval, do so first. (WHEN (EQ TYPE 'SPECIAL) (QC-FILE-FASD-FORM FORM)) ;; Check for duplicate definitions before the new definition is pushed on FILE-LOCAL-DECLARATIONS. (LET (FUNCTION-SPEC) (WHEN (AND (MEMBER (FIRST FORM) '(FDEFINE FSET SI:FSET) :TEST #'EQ) (QUOTEP (SECOND FORM)) (file-local-def (SETQ FUNCTION-SPEC (second (second form)))) ;; The following check is needed for DEFTYPE, which does both a PUTDECL and DEFUN. (NOT (AND (EQ (CAR-SAFE FUNCTION-SPEC) ':PROPERTY) (EQ (THIRD FUNCTION-SPEC) 'SYS:TYPE-EXPANDER)))) (WARN 'NOTICE-FDEFINE ':IMPLAUSIBLE "~S is defined twice in this file." FUNCTION-SPEC) )) ;; If supposed to evaluate at compile time, do so now. (WHEN (MEMBER TYPE '(SPECIAL DECLARE MACRO)) (UNLESS (AND (EQ TYPE 'MACRO) QC-FILE-IN-CORE-FLAG) (COMPILE-TIME-EVAL FORM TYPE *LOCAL-ENVIRONMENT*) (WHEN (AND (EQ (FIRST FORM) 'IN-PACKAGE) (EQ TYPE 'SPECIAL)) ;; make sure the dumper and loader are using the same default package (SETQ FASD-PACKAGE *PACKAGE*)))) ;; Finally, compile the form. (UNLESS (MEMBER TYPE '(SPECIAL DECLARE)) (COMPILE-TOP-LEVEL-FORM FORM 'QFASL #'QC-FILE-FASD-FORM)))) (DEFUN COMPILE-TIME-EVAL (FORM TYPE &OPTIONAL ENVIRONMENT) ;; 8/08/86 DNG - Original [separated from QC-FILE-COMMON] ;; 9/26/86 DNG - Quick shortcut for QUOTE forms. ;; 10/22/86 DNG - Return T for FDEFINE. ;; 11/21/86 DNG - Avoid evaluating a DEFCONSTANT twice. ;; 2/06/87 DNG - Use SI:COPY-OBJECT-TREE instead of COPY-TREE so that documentation strings get copied. ;; 7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST ;; 8/16/88 clm - Use only FILE-LOCAL-DECLARATIONS-DEF-ALIST to keep track of DEFinitions ;; (no longer keep same info in FILE-LOCAL-DECLARATIONS). ;; 4/03/89 DNG - Bind UNDO-DECLARATIONS-FLAG to NIL when TYPE is DECLARE. (IF (QUOTEP FORM) (SECOND FORM) (WARN-ON-ERRORS ('COMPILE-TIME-EVALUATION-ERROR "Error in compile-time evaluation of ~S" FORM) (BLOCK EVAL (WHEN (AND UNDO-DECLARATIONS-FLAG (NOT (EQ TYPE 'DECLARE))) ;; Within an (EVAL-WHEN (EVAL COMPILE LOAD)...) in COMPILE-FILE. (COND ((EQ (FIRST FORM) 'FDEFINE) ;; Just push definition on FILE-LOCAL-DECLARATIONS. (LET (( FUNCTION-SPEC (EVAL-FOR-TARGET (SECOND FORM) ENVIRONMENT) ) ( DEFINITION (EVAL-FOR-TARGET (THIRD FORM) ENVIRONMENT) )) (WHEN (EQ (CAR-SAFE FUNCTION-SPEC) :PROPERTY) (PUTDECL (CADR FUNCTION-SPEC) (CADDR FUNCTION-SPEC) DEFINITION)) (setf (file-local-def function-spec) definition) (RETURN-FROM EVAL T))) ((AND (EQ (FIRST FORM) 'SI:DEFCONST-1) (FIFTH FORM)) ;; Temporary hack to avoid evaluating a DEFCONSTANT twice -- ;; once in DEFCONSTANT-OPT and again here as a result of the ;; EVAL-WHEN in the DEFCONSTANT macro. The EVAL-WHEN should be ;; removed because this has to be done by a pre-optimizer so that ;; it can ensure that the compile-time and load-time values are ;; the same. (RETURN-FROM EVAL (SECOND FORM))) )) ;; Else, actually evaluate the form. (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) (UNDO-DECLARATIONS-FLAG (AND UNDO-DECLARATIONS-FLAG (NOT (EQ TYPE 'DECLARE))))) (EVAL-FOR-TARGET (SI:COPY-OBJECT-TREE FORM T) ENVIRONMENT) ))))) ;Enable microcompilation (when it is requested). NIL turns it off always. (DEFCONSTANT *MICROCOMPILE-SWITCH* NIL) ; Micro-compiler is not currently supported -- DNG 4/25/85 ;Dump out a form to be evaluated at load time. ;Method of dumping depends on format of file being written. (DEFUN QC-FILE-FASD-FORM (FORM &OPTIONAL (OPTIMIZE T)) ;; 1/23/85 - Added call to COLD-CHECK. ;; 4/25/85 - Apply MACROEXPAND-ALL in files with Cold-Load attribute. ;; 3/03/86 - Bind *EVALHOOK* around macro expansion. ;; 7/29/86 - Move cold-load handling to COMPILE-DRIVER. ;; 8/01/86 - Default OPTIMIZE to T instead of NIL. ;; 1/15/87 - Give warning on undefined function used at top level. (UNLESS (CONSTANTP FORM) (WHEN (AND (CONSP FORM) (SYMBOLP (CAR FORM)) SI:OBJECT-WARNINGS-OBJECT-NAME (NOT (FBOUNDP (CAR FORM)))) (FUNCTION-REFERENCED (CAR FORM) SI:OBJECT-WARNINGS-OBJECT-NAME)) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (FASD-FORM FORM OPTIMIZE)))) (DEFUN COMPILE-FORM ( FORM ) "Compile a form which is given as a list rather than as text. Like EVAL, the form is evaluated and the result returned but any function definitions will be compiled." ;; 4/25/85 - Original version. This function was created because ;; RTMS needs it, but it may be useful elsewhere also. ;; 6/02/86 - Merged in COMPILE-FORM-1 as an internal function; fix to use ;; CLI:NAMED-LAMBDA for Common Lisp DEFUNs; eliminate use of ;; RPLACA on FUNCTION-CELL-LOCATION [SPR 1485]. ;; 8/01/86 - Use new function COMPILE-TOP-LEVEL-FORM. ;; 8/08/86 - Use WITH-COMPILE-DRIVER-BINDINGS. ;; 11/19/86 - Recognize that SOURCE-CODE-AREA is write-protected. ;; 2/07/87 - Use new function WRITE-PROTECTED-AREA-P . ;; 7/22/87 - Eliminate use of *LAST-ADDRESS-READ*. ;; 7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST ;; 10/31/88 DNG - Add binding for *COMPILE-FILE-ENVIRONMENT* and *LOCAL-ENVIRONMENT*. ;; 3/16/89 DNG - Don't need binding of FILE-LOCAL-DECLARATIONS-DEF-ALIST anymore. ;; 4/11/89 DNG - Use *EVAL instead of EVAL1. (DECLARE (VALUES VALUE ERROR-STATUS)) (LET (( *RETURN-STATUS* OK ) ( *COMPILE-FORM-VALUE* NIL )) (DECLARE (SPECIAL *COMPILE-FORM-VALUE*)) (LOCKING-RESOURCES-NO-QFASL (LET ((QC-FILE-LOAD-FLAG T) (QC-FILE-IN-CORE-FLAG NIL)) (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE) (COMPILER-WARNINGS-CONTEXT-BIND (LET (FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST FILE-LOCAL-DECLARATIONS (QC-FILE-IN-PROGRESS NIL) (UNDO-DECLARATIONS-FLAG NIL) (LOCAL-DECLARATIONS NIL) (*COMPILE-FILE-ENVIRONMENT* NIL) (*LOCAL-ENVIRONMENT* NIL)) (QC-PROCESS-INITIALIZE) (WITH-COMPILE-DRIVER-BINDINGS (COMPILE-DRIVER FORM #'(LAMBDA (FORM TYPE) (SETQ *COMPILE-FORM-VALUE* (IF (EQ TYPE 'SPECIAL) (*EVAL FORM) (COMPILE-TOP-LEVEL-FORM FORM 'COMPILE-TO-CORE #'*EVAL) ))) NIL)))))) ) (VALUES *COMPILE-FORM-VALUE* *RETURN-STATUS*) ) ) ;;; This is the heart of the M-X Fasl Update command. ;;; Reads from INPUT-STREAM using READ-FUNCTION (called with arguments like READ's) ;;; INFILE should be the name of the input file that INPUT-STREAM is reading from. ;;; OUTFILE is a pathname used to open an output file. (DEFUN FASL-UPDATE-STREAM (INFILE OUTFILE INPUT-STREAM READ-FUNCTION) ;; 4/08/85 DNG - Fix to handle file attributes. ;; 6/09/86 DNG - Use Common Lisp options on WITH-OPEN-FILE. ;; 8/11/86 DNG - Use the new QC-FILE-COMMON instead of FASL-UPDATE-FORM. ;; 10/09/86 DNG - Delete binding of LAST-ERROR-FUNCTION . ;; 1/16/87 DNG - Use WITH-COMPILE-DRIVER-BINDINGS; remove obsolete UNWIND-PROTECT. ;; 7/26/88 JHO - Added support for FILE-LOCAL-DECLARATIONS-DEF-ALIST ;; 10/31/88 DNG - Add binding for *COMPILE-FILE-ENVIRONMENT* and *LOCAL-ENVIRONMENT*. ;; 3/16/89 DNG - Don't need binding of FILE-LOCAL-DECLARATIONS-DEF-ALIST anymore. (DECLARE (IGNORE INFILE)) (LET ((QC-FILE-LOAD-FLAG NIL) (QC-FILE-IN-CORE-FLAG T) (DEFAULT-CONS-AREA DEFAULT-CONS-AREA) (QC-FILE-IN-PROGRESS T) (UNDO-DECLARATIONS-FLAG NIL) (LOCAL-DECLARATIONS NIL) (FILE-LOCAL-DECLARATIONS NIL) (OPTIMIZE-SWITCH OPTIMIZE-SWITCH) (OPEN-CODE-MAP-SWITCH OPEN-CODE-MAP-SWITCH) (RUN-IN-MACLISP-SWITCH RUN-IN-MACLISP-SWITCH) (OBSOLETE-FUNCTION-WARNING-SWITCH OBSOLETE-FUNCTION-WARNING-SWITCH) (ALL-SPECIAL-SWITCH ALL-SPECIAL-SWITCH) (SI:FDEFINE-FILE-DEFINITIONS NIL) (FASD-PACKAGE NIL) (*COMPILE-FILE-ENVIRONMENT* NIL) (*LOCAL-ENVIRONMENT* NIL) PLIST ) (LOCKING-RESOURCES (WITH-OPEN-FILE (FASD-STREAM OUTFILE :DIRECTION :OUTPUT :CHARACTERS NIL :BYTE-SIZE 16.) (FASD-INITIALIZE) (FASD-START-FILE) (QC-PROCESS-INITIALIZE) ;; First thing in QFASL file must be property list (SETQ PLIST (FS:READ-ATTRIBUTE-LIST NIL INPUT-STREAM)) ;; Bind all the variables required by the file property list. (MULTIPLE-VALUE-BIND (VARS VALS) (FS:FILE-ATTRIBUTE-BINDINGS (LOCF PLIST)) (PROGV VARS VALS ;; Make sure package is specified. (SETF (GETF PLIST ':PACKAGE) (INTERN (PACKAGE-NAME *PACKAGE*) PKG-KEYWORD-PACKAGE)) ;; Make sure :MODE is :ZETALISP or :COMMON-LISP, not just :LISP . (SETF (GETF PLIST ':MODE) (LISP-MODE)) (FASD-ATTRIBUTES-LIST PLIST) ; Write out the attribute list. (WITH-COMPILE-DRIVER-BINDINGS (DO ((EOF (CONS NIL NIL)) FORM) (NIL) ;; Read and macroexpand in temp area. (SETQ DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA) (LET ((QC-FILE-READ-IN-PROGRESS T)) (SETQ FORM (FUNCALL READ-FUNCTION INPUT-STREAM EOF))) (WHEN (EQ EOF FORM) (RETURN NIL)) (SETQ FORM (MACROEXPAND FORM)) (SETQ DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) ;; Output this form in the appropriate way. (COMPILE-DRIVER FORM #'QC-FILE-COMMON NIL))) (FASD-END-WHACK) (FASD-END-FILE)))) ))) ;(COMPILE-DRIVER form processing-function override-fn) should be used by anyone ;trying to do compilation of forms from source files, or any similar operation. ;It knows how to decipher DECLAREs, EVAL-WHENs, DEFUNs, macro calls, etc. ;It doesn't actually compile or evaluate anything, ;but instead calls the processing-function with two args: ; a form to process, and a flag which is one of these atoms: ; SPECIAL - QC-FILE should eval this and put it in the FASL file. ; UNDO-DECLARATIONS-FLAG, if on, should stay on for this. ; DECLARE - QC-FILE should eval this. ; DEFUN - QC-FILE should compile this and put the result in the FASL file. ; MACRO - This defines a macro. QC-FILE should record a declaration ; and compile it into the FASL file. ; RANDOM - QC-FILE should just put this in the FASL file to be evalled. ;Of course, operations other than QC-FILE will want to do different things ;in each case, but they will probably want to distinguish the same cases. ;That's why COMPILE-DRIVER will be useful to them. ;override-fn gets to look at each form just after macro expansion. ;If it returns T, nothing more is done to the form. If it returns NIL, ;the form is processed as usual (given to process-fn, etc.). ;override-fn may be NIL. (DEFUN COMPILE-DRIVER (OFORM PROCESS-FN OVERRIDE-FN &OPTIONAL COMPILE-TIME-TOO (TOP-LEVEL-P T)) ;; 8/01/84 DNG - updated from MIT patches 98.40 and 98.57. ;; 12/26/84 DNG - Save value of DEFCONSTANT in FILE-CONSTANTS-LIST. ;; 1/18/85 DNG - Use COMPILE-PROCLAIM. ;; 2/20/85 DNG - Evaluate saved value of DEFCONSTANT. ;; 10/23/85 DNG - Fix handling of top-level COMPILER-LET so that the bindings ;; are implicitely special. [SPR 837] ;; 1/16/86 DNG - Give warning on obsolete DEFUN syntax. ;; 1/27/86 DNG - Do style checking on random top-level forms. ;; 3/03/86 DNG - Fix so that an IMPORT within an EVAL-WHEN is fasdumped ;; before being evaluated [SPR 1204]; bind *EVALHOOK* to ;; #'EVAL-FOR-TARGET around macro expansion to use target definitions. ;; 3/18/86 DNG - Call CHECK-USED-BEFORE-DEFINED for DEFF-MACRO. ;; 5/19/86 DNG - Add special handling for EXPORT, IMPORT, etc. in cold-load. ;; 6/24/86 DNG - Fix to recognize PATCH-SOURCE-FILE in COMPILER package instead of COMPILER2. ;; 7/25/86 DNG - ;; 7/30/86 DNG - Evaluate COMPILATION-DEFINE at both compile and load time; always ;; try to evaluate the value of a DEFCONSTANT at compile time. ;; 8/07/86 DNG - Major changes to minimize differences between top-level forms and functions. ;; 8/15/86 DNG - Don't optimize when an override function is given [ie, eval buffer]. ;; 9/26/86 DNG - Added call to OBJECT-OPERATION-WITH-WARNINGS . ;; 11/21/86 DNG - Don't establish warnings context for a DEFPROP. ;; 2/11/87 DNG - Fix to not error on name starting with #\D but less that 3 characters. "Compile or evaluate a top-level form from a file or buffer." (WHEN (AND COMPILER-WARNINGS-CONTEXT (NULL SI:OBJECT-WARNINGS-OBJECT-NAME) (CONSP OFORM) (SYMBOLP (FIRST OFORM)) (CADR-SAFE OFORM) (SYMBOLP (SECOND OFORM)) (LET ((NAME (SYMBOL-NAME (FIRST OFORM)))) (AND (>= (LENGTH NAME) 3) (CHAR= (CHAR NAME 0) #\D) (CHAR= (CHAR NAME 1) #\E) (CHAR= (CHAR NAME 2) #\F))) (NOT (EQ (FIRST OFORM) 'DEFPROP))) ;; A definition form that ZMACS knows how to find, so use it as a reference point ;; for reporting any errors within it. (RETURN-FROM COMPILE-DRIVER (OBJECT-OPERATION-WITH-WARNINGS ((SECOND OFORM)) (COMPILE-DRIVER OFORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P)))) (LET ((FORM OFORM)) (WHEN (AND OVERRIDE-FN (FUNCALL OVERRIDE-FN FORM)) (RETURN-FROM COMPILE-DRIVER NIL)) (LET ((MACRO-CONS-AREA DEFAULT-CONS-AREA) (P1VALUE 'TOP-LEVEL-FORM)) (SETQ FORM (PRE-OPTIMIZE FORM T OVERRIDE-FN))) ; check style, expand macros, and optimize (WHEN (AND OVERRIDE-FN (NOT (EQ FORM OFORM)) (FUNCALL OVERRIDE-FN FORM)) (RETURN-FROM COMPILE-DRIVER NIL)) (IF (ATOM FORM) (FUNCALL PROCESS-FN FORM 'RANDOM) ;; If this was a top-level macro, supply a good guess ;; for the function-parent for any DEFUNs inside the expansion. (LET ((LOCAL-DECLARATIONS LOCAL-DECLARATIONS) (FN (FIRST FORM))) (COND ((AND (NEQ FORM OFORM) (SYMBOLP (CADR OFORM))) (PUSH `(FUNCTION-PARENT ,(CADR OFORM) ,(CAR OFORM)) LOCAL-DECLARATIONS)) ) (COND ((EQ FN 'EVAL-WHEN) (LET ((TIMES (SECOND FORM))) (UNLESS (AND (LISTP TIMES) (LOOP FOR TIME IN TIMES ALWAYS (MEMBER TIME '(GLOBAL:EVAL LOAD COMPILE CLI:EVAL #+compiler:debug Lisp:compile) :TEST #'EQ))) (WARN 'EVAL-WHEN ':IMPOSSIBLE "~S invalid EVAL-WHEN times; must be a list of EVAL, LOAD, and/or COMPILE." TIMES)) (LET* ((COMPILE (OR (MEMBER 'COMPILE TIMES :TEST #'EQ) #+compiler:debug (MEMBER 'Lisp:COMPILE TIMES :TEST #'EQ))) (LOAD (MEMBER 'LOAD TIMES :TEST #'EQ)) (EVAL (OR (MEMBER 'GLOBAL:EVAL TIMES :TEST #'EQ) (MEMBER 'CLI:EVAL TIMES :TEST #'EQ))) (EVAL-NOW (AND (OR COMPILE (AND COMPILE-TIME-TOO EVAL)) T))) (DOLIST (FORM1 (CDDR FORM)) (IF LOAD (COMPILE-DRIVER FORM1 PROCESS-FN OVERRIDE-FN EVAL-NOW NIL) (IF EVAL-NOW (FUNCALL PROCESS-FN FORM1 'DECLARE) (RETURN) )))))) ((EQ FN 'WITH-SELF-ACCESSIBLE) ; Why is this here??? (MAPC #'(LAMBDA (FORM) (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO NIL)) (CDDR FORM))) ((EQ FN 'PROGN) (MAPC #'(LAMBDA (FORM) (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P)) (CDR FORM))) ((AND (OR TOP-LEVEL-P COMPILE-TIME-TOO) (MEMBER FN '(SPECIAL UNSPECIAL COMPILATION-DEFINE MAKE-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT EXPORT UNEXPORT USE-PACKAGE UNUSE-PACKAGE IMPORT REQUIRE) :TEST #'EQ)) (COND ((AND SI:FILE-IN-COLD-LOAD (MEMBER FN '(EXPORT UNEXPORT IMPORT SHADOWING-IMPORT SHADOW USE-PACKAGE UNUSE-PACKAGE) :TEST #'EQ) (EQL (LENGTH FORM) 2)) ;; For cold-load files, these operations need an explicit package ;; argument because we can't be sure what *PACKAGE* will be at the ;; time the form is actually executed. (SETQ FORM (LIST (FIRST FORM) (SECOND FORM) (PACKAGE-NAME *PACKAGE*)))) ) (FUNCALL PROCESS-FN FORM 'SPECIAL)) ((EQ FN 'DECLARE) (COMPILE-DECLARE (CDR FORM) PROCESS-FN)) ((EQ FN 'PROCLAIM) (COMPILE-PROCLAIM (CDR FORM) PROCESS-FN)) ((EQ FN 'COMMENT) NIL) ((EQ FN 'COMPILER:PATCH-SOURCE-FILE) (COMPILE-DRIVER `(EVAL-WHEN (LOAD EVAL) (SETQ SI:PATCH-SOURCE-FILE-NAMESTRING ,(CADR FORM))) PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P) (MAPC #'(LAMBDA (FORM) (COMPILE-DRIVER FORM PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P)) (CDDR FORM)) (COMPILE-DRIVER `(EVAL-WHEN (LOAD EVAL) (SETQ SI:PATCH-SOURCE-FILE-NAMESTRING NIL)) PROCESS-FN OVERRIDE-FN COMPILE-TIME-TOO TOP-LEVEL-P)) ((EQ FN 'COMPILER-LET) (*EVAL `(COMPILER-LET ,(CADR FORM) (COMPILE-DRIVER '(PROGN . ,(CDDR FORM)) ',PROCESS-FN ',OVERRIDE-FN ',COMPILE-TIME-TOO ',TOP-LEVEL-P)))) (COMPILE-TIME-TOO ; EVAL-WHEN (COMPILE LOAD) (FUNCALL PROCESS-FN FORM 'MACRO)) (T ; EVAL-WHEN (LOAD) (FUNCALL PROCESS-FN FORM 'RANDOM)) )))) NIL) (DEFUN COMPILE-TOP-LEVEL-FORM ( FORM LAP-MODE EVAL-FN &OPTIONAL (PROCESSING-MODE 'MACRO-COMPILE)) ;; 7/30/86 DNG - Original. ;; 8/14/86 DNG ;; 8/15/86 DNG - Fully compile the form if it has more than one local variable. ;; 8/23/86 DNG - New optional argument PROCESSING-MODE. ;; 9/05/86 DNG - Shortcut for SETQ. ;; 10/01/86 DNG - COMPILAND-BREAKOFF-COUNT replaced by COMPILAND-CHILDREN. ;; 10/03/86 DNG - Modify local variable count to not include deleted variables. ;; 10/11/86 DNG - Don't leave random forms to be evaluated in write-protected area. ;; 1/16/87 DNG - When QC-FILE-IN-CORE-FLAG check COMPILED-FUNCTION-P and ;; FEF-FLAVOR-NAME before skipping compilation. ;; 1/21/87 DNG - Call COMPILATION-DEFINE for top-level dummy functions. ;; 5/05/87 DNG - Fix SPR 4544 and 4508. ;; 6/17/87 DNG - Don't create gensym function names in temporary area. [SPR 5063] ;; 3/17/89 DNG - Pass environment to MACROEXPAND-ALL. ;; 4/21/89 DNG - Don't need to compile TICLOS:ENSURE-GENERIC-FN. ;; 4/22/89 DNG - Modified to handle Scheme mode. (DECLARE (UNSPECIAL LAP-MODE)) (COND ((OR (ATOM FORM) (MEMBER (FIRST FORM) '( QUOTE DEFPROP REMPROP SPECIAL ) :TEST #'EQ) (AND (OR (MEMBER (FIRST FORM) '(SI:DEFVAR-1 SI:DEFCONST-1 TICLOS:ENSURE-GENERIC-FN) :TEST #'EQ) (AND (EQ (FIRST FORM) 'SETQ) (NULL (CDDDR FORM)))) (CONSTANTP (THIRD FORM)))) ;; shortcut to save time for some common trivial forms (FUNCALL EVAL-FN (ENABLE-WRITE FORM))) ((AND (EQ (FIRST FORM) 'FDEFINE) (QUOTEP (SECOND FORM)) (EQ (CAR-SAFE (THIRD FORM)) 'FUNCTION) (MEMBER (CAR-SAFE (SECOND (THIRD FORM))) '(GLOBAL:LAMBDA CLI:LAMBDA GLOBAL:SUBST CLI:SUBST GLOBAL:NAMED-LAMBDA NAMED-LAMBDA GLOBAL:NAMED-SUBST NAMED-SUBST MACRO) :TEST #'EQ) (OR (EQ (FOURTH FORM) T) (AND (CONSTANTP (FOURTH FORM)) (EVAL (FOURTH FORM)))) (NOT (FIFTH FORM))) ;; Special shortcut for (FDEFINE 'name #'(LAMBDA ...) T) ;; which is what most function-defining macros expand into. (LET ((NAME (SECOND (SECOND FORM))) DEF) (IF (AND QC-FILE-IN-CORE-FLAG (SETQ DEF (SI:FDEFINITION-SAFE NAME T)) (OR (COMPILED-FUNCTION-P DEF) (AND (CONSP DEF) (EQ (CAR DEF) 'MACRO) (COMPILED-FUNCTION-P (CDR DEF)))) (NULL (SI:FEF-FLAVOR-NAME DEF)) ; no SELF-MAP addressing used ) ;; Just dump the current definition. (FUNCALL EVAL-FN `(FDEFINE ,(SECOND FORM) ',DEF . ,(CDDDR FORM))) ;; Else compile the function. (record-individual-time 'qc-translate-function (QC-TRANSLATE-FUNCTION NAME (SECOND (THIRD FORM)) PROCESSING-MODE LAP-MODE))) NAME)) (T ;; arbitrary form -- run it through pass 1 of the compiler to check ;; for errors, expand macros, optimize, and collect information for ;; deciding how it should be handled. (LET ( RESULT IFORM NLOCAL ) (record-individual-time 'compile-top-level-form (IF (NULL *CURRENT-COMPILAND*) (SETQ *CURRENT-COMPILAND* (MAKE-COMPILAND)) (FILL (THE COMPILAND *CURRENT-COMPILAND*) NIL)) (LET ((CC *CURRENT-COMPILAND*)) (DECLARE (TYPE COMPILAND CC)) (SETF (COMPILAND-DEFINITION CC) (IF (SI:SCHEME-ON-P) `(LAMBDA () (SI:WITH-SCHEME-SEMANTICS (INHIBIT-STYLE-WARNINGS ,FORM))) `(LAMBDA () (INHIBIT-STYLE-WARNINGS ,FORM))) (COMPILAND-DECLARATIONS CC) LOCAL-DECLARATIONS (COMPILAND-OPTIMIZE CC) OPTIMIZE-SWITCH (COMPILAND-CHILDREN CC) NIL (COMPILAND-NESTING-LEVEL CC) 0) (SETQ RESULT (QC-TRANSLATE-FUNCTION NIL CC PROCESSING-MODE LAP-MODE NIL T)))) (IF (AND (NOT (NULL RESULT)) (OR (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES RESULT) (> (COMPILAND-EXPRESSION-SIZE RESULT) 30.) (> (SETQ NLOCAL (COUNT 'FEF-ARG-INTERNAL-AUX (THE LIST (COMPILAND-ALLVARS RESULT)) :KEY #'VAR-KIND :TEST #'EQ)) 1) (AND (COMPILAND-CHILDREN RESULT) (NEQ LAP-MODE 'COMPILE-TO-CORE) (OR SI:FILE-IN-COLD-LOAD ; Genasys can't handle anonymous FEFs [SPR 4508] (DOLIST (CHILD (COMPILAND-CHILDREN RESULT) NIL) (UNLESS (NULL (COMPILAND-CHILDREN CHILD)) ;; QLAPP can't properly handle nested functions in ;; QFASL-NO-FDEFINE mode. [SPR 4544] (RETURN T))))) (AND (NULL (SETQ IFORM (AND (= NLOCAL 0) (CATCH 'NO (PREPARE-COMPILED-FORM-FOR-EVALUATION (COMPILAND-EXP2 RESULT)) )))) (NOT (NULL (COMPILAND-CHILDREN RESULT)))))) ;; Finish compiling the dummy function and then call it. (LET (( NAME (LET ( #+LispM (SI:*GENSYM-PREFIX* "F") (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (GENSYM) ))) (SETF (COMPILAND-FUNCTION-SPEC RESULT) NAME) (WHEN (NULL (COMPILAND-FUNCTION-NAME RESULT)) (SETF (COMPILAND-FUNCTION-NAME RESULT) NAME)) (UNLESS (EQ LAP-MODE 'COMPILE-TO-CORE) (COMPILATION-DEFINE NAME)) (record-individual-time 'qc-translate-function (QC-TRANSLATE-FUNCTION NAME RESULT PROCESSING-MODE LAP-MODE)) (SETF (COMPILAND-FUNCTION-SPEC RESULT) NIL) ; for TOP-LEVEL-DUMMY-FUNCTION-P (FUNCALL EVAL-FN `(,NAME))) (IF (NULL IFORM) ;; Evaluate the source form. (PROGN #+compiler:debug (when (and compiler-verbose (string-equal user-id "GRAY")) (let ((*print-length* 8) (*print-level* 3)) (format t "~%[eval original form: ~S" form))) (FUNCALL EVAL-FN (IF (AND SI:FILE-IN-COLD-LOAD (NOT (EQ LAP-MODE 'COMPILE-TO-CORE))) (LET ((*EVALHOOK* #'EVAL-FOR-TARGET)) (MACROEXPAND-ALL FORM *LOCAL-ENVIRONMENT*)) (ENABLE-WRITE FORM)))) ;; Evaluate the partially compiled form. (FUNCALL EVAL-FN IFORM) )) )))) (DEFUN PREPARE-COMPILED-FORM-FOR-EVALUATION (X) ;; Given a Lisp form that has been processed by P1, return a modified form ;; suitable for EVAL, or THROW to NO if it contains something that can't be ;; EVALed. This is only called by COMPILE-TOP-LEVEL-FORM. ;; 8/04/86 DNG - Original. ;; 8/14/86 DNG - Add handling for DONT-OPTIMIZE. ;; 8/15/86 DNG - Watch out for sub-primitives that can't be evaluated. ;; 8/28/86 CLM - Add handling for "E'd args. ;; 9/02/86 DNG - Fix to return correct value for DEFCONST-1. ;; 9/05/86 DNG - Accept special forms AND, OR, and SETQ; delete the check ;; for the P2 property which is made obsolete by the check on QUOTES-ANY-ARGS. ;; 9/19/86 DNG - Because of change in QUOTES-ANY-ARGS, now need to check SPECIAL-FORM-P also. ;; 10/03/86 DNG - Permit PROGN and MULTIPLE-VALUE-LIST; remove QUOTE from T ;; and NIL; don't use destructive modification since we might have ;; to give up and finish compiling the code. ;; 10/11/86 DNG - Don't write-protect constants in top-level forms. ;; 12/17/88 DNG - Abort on a local generic function breakoff. ;; 1/25/89 DNG - Add handling for %LOAD-TIME-VALUE . (IF (ATOM X) X (LET ((FN (CAR X))) (COND ((EQ FN 'QUOTE) (LET ((VALUE (SECOND X))) (IF (CONSP VALUE) (ENABLE-WRITE X) (IF (AND (SYMBOLP VALUE) (NEQ VALUE NIL) (NEQ VALUE T) (NOT (KEYWORDP VALUE))) X VALUE)))) ((EQ FN 'FUNCTION) X) ((EQ FN 'LOCAL-REF) (THROW 'NO NIL)) ((EQ FN 'BREAKOFF-FUNCTION) (IF (CDDR X) ; a local generic function (THROW 'NO NIL) (LIST BREAKOFF-FUNCTION-MARKER (SECOND X)))) ((EQ FN 'THE-EXPR) (PREPARE-COMPILED-FORM-FOR-EVALUATION (EXPR-FORM X))) ((EQ FN 'COND) (CONS 'COND (LOOP FOR CLAUSE IN (CDR X) COLLECT (LOOP FOR E IN CLAUSE COLLECT (PREPARE-COMPILED-FORM-FOR-EVALUATION E))))) ((AND (EQ FN 'DONT-OPTIMIZE) (NULL (CDDR X))) (PREPARE-COMPILED-FORM-FOR-EVALUATION (SECOND X))) ((NOT (SYMBOLP FN)) #+compiler:debug (warn 'PREPARE-COMPILED-FORM-FOR-EVALUATION :bug "Invalid expression ~S in ~S." x 'PREPARE-COMPILED-FORM-FOR-EVALUATION) (THROW 'NO NIL)) ((EQ FN '%LOAD-TIME-VALUE) (IF (BOUNDP 'FASD-STREAM) ;; convert to evaluate at load time instead of run time `(QUOTE (,EVAL-AT-LOAD-TIME-MARKER . ,(SECOND X))) (CONS 'LOAD-TIME-VALUE (CDR X)))) ((AND (NOT (FBOUNDP FN)) (OR (GET-OPCODES FN) (GET FN 'P2))) ;; sub-primitive not defined for evaluator (THROW 'NO NIL)) ((NULL (CDR X)) X) ((AND (OR (QUOTES-ANY-ARGS FN) (SPECIAL-FORM-P FN)) (NOT (MEMBER FN '(AND OR SETQ PROGN *CATCH CATCH MULTIPLE-VALUE-LIST) :TEST #'EQ))) (COND ((EQ FN 'SI:DEFVAR-1) (IF (CDDR X) (LIST* FN (SECOND (SECOND X)) (SECOND (THIRD X)) (CDDDR X)) (LIST FN (SECOND (SECOND X))))) ((EQ FN 'SI:DEFCONST-1) (LIST* FN (SECOND (SECOND X)) (PREPARE-COMPILED-FORM-FOR-EVALUATION (THIRD X)) (CDDDR X))) (T (THROW 'NO NIL)))) (T (CONS FN (LOOP FOR A IN (CDR X) COLLECT (PREPARE-COMPILED-FORM-FOR-EVALUATION A)))))))) (DEFUN FASD-BREAKOFF-FUNCTION (CONS) ;; 10/18/86 - Use name |anonymous| instead of (:INTERNAL NIL 0). ;; 2/10/87 - Added special handling for macros. ;; 4/23/87 - Fix to correctly record in the object file the second and ;; subsequent references to the function. [SPR 4903] ;; 1/25/89 DNG - Correct BYTE arguments - octal instead of decimal. ;; 3/16/89 DNG - Use new function FASD-INDEX. (LET* (( COMPILAND (SECOND CONS) ) ( INDEX (GETF (COMPILAND-PLIST COMPILAND) 'FASL-TABLE-INDEX))) (IF INDEX (PROGN ; If this FEF already dumped, just reference it in the FASL-TABLE. (FASD-INDEX INDEX) INDEX) (SETF (GETF (COMPILAND-PLIST COMPILAND) 'FASL-TABLE-INDEX) (PROGN (FIX-BREAKOFF-NAME COMPILAND) (IF (COMPILAND-MACRO-FLAG COMPILAND) ;; Need to cons on the macro flag here instead of in QLAPP ;; in case this object is supposed to be an element of a list. (PROGN (SETF (COMPILAND-MACRO-FLAG COMPILAND) NIL) (FASD-CONSTANT `(QUOTE (MACRO . ,CONS)))) (QC-TRANSLATE-FUNCTION NIL COMPILAND 'MACRO-COMPILE 'QFASL-NO-FDEFINE))))))) (DEFMACRO BREAKOFF-MARKER-MACRO (COMPILAND) ;; 2/10/87 - Use new function FIX-BREAKOFF-NAME. `(QUOTE ,(OR (GETF (COMPILAND-PLIST COMPILAND) 'FEF) (SETF (GETF (COMPILAND-PLIST COMPILAND) 'FEF) (PROGN (FIX-BREAKOFF-NAME COMPILAND) (QC-TRANSLATE-FUNCTION NIL COMPILAND 'MACRO-COMPILE 'COMPILE-TO-CORE)))) )) (FDEFINE BREAKOFF-FUNCTION-MARKER (FDEFINITION 'BREAKOFF-MARKER-MACRO)) (DEFUN FIX-BREAKOFF-NAME (COMPILAND) ;; 2/10/87 DNG - Original version separated from FASD-BREAKOFF-FUNCTION. (LET (( NAME (COMPILAND-FUNCTION-NAME COMPILAND) )) (WHEN (AND (CONSP NAME) (EQ (FIRST NAME) ':INTERNAL) (EQ (SECOND NAME) 'NIL) (NUMBERP (THIRD NAME))) (MULTIPLE-VALUE-BIND ( LAMBDA-NAME NAMEDP ) (FUNCTION-NAME (COMPILAND-DEFINITION COMPILAND)) (SETF (COMPILAND-FUNCTION-NAME COMPILAND) (IF NAMEDP LAMBDA-NAME ; non-symbol function spec ;; Else we don't have any meaningful name for it. '|anonymous|)))) (SETF (COMPILAND-FUNCTION-SPEC COMPILAND) NIL))) (DEFUN COMPILE-DECLARE (DECL-LIST PROCESS-FN) ;; 1/18/85 DNG - Added warning message. ;; 1/16/86 DNG - Use COMMON-LISP-ON-P instead of LISP-MODE. (WHEN (COMMON-LISP-ON-P) (WARN 'DECLARE ':OBSOLETE "DECLARE used at top level in a file is obsolete; use EVAL-WHEN or PROCLAIM, as appropriate." ) ) (MAPC #'(LAMBDA (DECL) (FUNCALL PROCESS-FN DECL (IF (MEMBER (CAR DECL) '(SPECIAL UNSPECIAL :SPECIAL :UNSPECIAL) :TEST #'EQ) 'SPECIAL 'DECLARE) )) DECL-LIST)) (DEFUN COMPILE-PROCLAIM ( DECL-LIST PROCESS-FN ) ;; 1/18/85 DNG - Original. ;; 2/03/86 DNG - Issue warning on missing quote. ;; 3/03/86 DNG - Use EVAL-FOR-TARGET instead of SI:EVAL1. ;; 9/26/86 DNG - Use COMPILE-TIME-EVAL instead of EVAL-FOR-TARGET to warn on errors. ;;10/26/88 DNG - Pass environment to COMPILE-TIME-EVAL. (DOLIST ( DECL DECL-LIST ) (WHEN (AND (CONSP DECL) (MEMBER (FIRST DECL) '(SPECIAL UNSPECIAL OPTIMIZE INLINE NOTINLINE DECLARATION) :TEST #'EQ)) (WARN 'COMPILE-PROCLAIM :IGNORABLE-MISTAKE "(PROCLAIM (~A ...)) should be (PROCLAIM '(~A ...))." (FIRST DECL) (FIRST DECL)) (SETQ DECL (LIST 'QUOTE DECL))) (LET (( X (COMPILE-TIME-EVAL DECL 'SPECIAL *LOCAL-ENVIRONMENT*) )) (IF (AND (CONSP X) (EQ (FIRST X) 'OPTIMIZE) ) (DECLARE-OPTIMIZE (REST X)) (FUNCALL PROCESS-FN `(PROCLAIM ,DECL) 'SPECIAL) ) ) ) ) (DEFPROP PATCH-SOURCE-FILE T SI:MAY-SURROUND-DEFUN) (DEFUN PATCH-SOURCE-FILE ("E SI:PATCH-SOURCE-FILE-NAMESTRING &REST BODY) ;; Evaluate the forms within the binding of special variable PATCH-SOURCE-FILE-NAMESTRING . ;; 4/11/89 Use *EVAL instead of EVAL1. (MAPC #'*EVAL BODY)) ;;; ---- Optimizers and style checkers for forms usually used at top level. ---- (DEFUN (:PROPERTY DEFF-MACRO STYLE-CHECKER) (FORM) (WHEN (TOP-LEVEL-DUMMY-FUNCTION-P) (CHECK-USED-BEFORE-DEFINED (SECOND FORM) "macro"))) (ADD-OPTIMIZER DEFCONSTANT DEFCONSTANT-OPT) (DEFUN DEFCONSTANT-OPT (FORM &AUX SYMBOL) ;; 08/09/86 Original. [previously part of COMPILE-DRIVER] ;; 10/03/86 Don't wrap DONT-OPTIMIZE around the new form. ;; 1/25/89 Special handling for LOAD-TIME-VALUE . ;; 3/17/89 Pass environment to EVAL-FOR-TARGET. ;; 4/25/89 Store value in interpreter environment so that EVALHOOK and ;; EVAL-FOR-TARGET don't have to be used. (WHEN (AND (TOP-LEVEL-DUMMY-FUNCTION-P) UNDO-DECLARATIONS-FLAG (SYMBOLP (SETQ SYMBOL (SECOND FORM))) (CDDR FORM) (NOT (EQ SYMBOL (CAAR FILE-CONSTANTS-LIST)))) ; haven't already done this (LET ((EXP (THIRD FORM))) (UNLESS (AND (NOT (AND QC-FILE-IN-PROGRESS (NOT QC-FILE-LOAD-FLAG) (CONSP EXP) (OR (EQ (CAR EXP) 'LOAD-TIME-VALUE) (LOAD-TIME-EVAL-P EXP 0) ))) (WARN-ON-ERRORS ('COMPILE-TIME-EVALUATION-ERROR "Error evaluating ~S" FORM) ;; Try to compute the value now. (LET (( VALUE (EVAL-FOR-TARGET EXP *LOCAL-ENVIRONMENT*) )) ;; Save value of constant for use by P1 or SYMEVAL-FOR-TARGET . (PUSH (CONS SYMBOL VALUE) FILE-CONSTANTS-LIST) ;; Save value for use by EVAL. (SETF (GETF (FIRST (ENV-VARS *COMPILE-FILE-ENVIRONMENT*)) (LOCF (SYMBOL-VALUE SYMBOL))) VALUE) (SETF (GET-FROM-ENVIRONMENT SYMBOL 'SYSTEM-CONSTANT NIL *COMPILE-FILE-ENVIRONMENT*) T) (WHEN (AND (OR (NUMBERP VALUE) (SYMBOLP VALUE) (CHARACTERP VALUE) ) (NOT (CONSTANTP EXP))) ;; Eligible for value substitution; make sure it has the same value ;; at load time as at compile time. (SETQ FORM (LIST* (FIRST FORM) SYMBOL `(QUOTE ,VALUE) (CDDDR FORM))))) T)) ;; Else can't compute value now; disable substitution until loaded. (PUTPROP-FOR-TARGET SYMBOL NIL 'SYSTEM-CONSTANT) )) ) FORM ) (ADD-OPTIMIZER FDEFINE NOTICE-FDEFINE) (ADD-OPTIMIZER FSET NOTICE-FDEFINE) (UNLESS (EQ 'FSET 'SI:FSET) (ADD-OPTIMIZER SI:FSET NOTICE-FDEFINE) (SETF (GET 'SI:FSET 'EVAL-FOR-TARGET) (GET 'FSET 'EVAL-FOR-TARGET))) (ADD-OPTIMIZER TICLOS:ENSURE-GENERIC-FN NOTICE-FDEFINE) ; 10/17/88 DNG (ADD-OPTIMIZER TICLOS:ENSURE-GENERIC-FUNCTION NOTICE-FDEFINE) ; 10/17/88 DNG (ADD-OPTIMIZER TICLOS:MAKE-READER NOTICE-FDEFINE) ; 5/2/89 DNG (ADD-OPTIMIZER TICLOS:MAKE-WRITER NOTICE-FDEFINE) ; 5/2/89 DNG ;; This can't be a style checker because it needs to be applied to macro expansions. ;; It can't be a P1 handler because it needs to apply to all FDEFINEs, even if not compiled. ;; Therefore, it is implemented as a pre-optimizer even though it doesn't really optimize. (DEFUN NOTICE-FDEFINE (FORM) ;; 8/11/86 - Original. ;; 8/12/86 - Move "defined twice" warning to QC-FILE-COMMON. (WHEN (AND (QUOTEP (SECOND FORM)) QC-FILE-IN-PROGRESS (TOP-LEVEL-DUMMY-FUNCTION-P *CURRENT-COMPILAND*) (NOT QC-FILE-LOAD-FLAG)) (COMPILATION-DEFINE (SECOND (SECOND FORM)))) FORM) (DEFUN (:PROPERTY EVAL-WHEN P1) (FORM) ;; 8/04/86 DNG - Original. (UNLESS (TOP-LEVEL-DUMMY-FUNCTION-P *CURRENT-COMPILAND*) (WARN 'EVAL-WHEN ':IGNORABLE-MISTAKE "EVAL-WHEN used within a function is not meaningful.")) (LET (( RESULT-FORMS NIL )) (DECLARE (LIST RESULT-FORMS)) (COMPILE-DRIVER FORM #'(LAMBDA (FORM TYPE) (DECLARE (SYMBOL TYPE)) (UNLESS (EQ TYPE 'DECLARE) (PUSH (P1 FORM) RESULT-FORMS)) (WHEN (MEMBER TYPE '(SPECIAL DECLARE MACRO)) (COMPILE-TIME-EVAL FORM TYPE *LOCAL-ENVIRONMENT*))) NIL NIL NIL) (CONS 'PROGN (NREVERSE RESULT-FORMS)))) (ADD-OPTIMIZER SI:DEFVAR-1 DEFVAR-OPT) (DEFUN DEFVAR-OPT (FORM) ;; 8/06/86 DNG - Original. (LET ((VALUE (THIRD FORM))) (IF (CONSTANTP VALUE) FORM ;; Enable compilation of the value expression. (LET ((SYMBOL (SECOND FORM))) `(PROGN (AND (SI:DEFVAR-OK-TO-SET-P ',SYMBOL ,(FOURTH FORM)) (SET ',SYMBOL ,VALUE)) ',SYMBOL))))) (ADD-OPTIMIZER DEFVAR SUPPRESS-VAR-DOC) (ADD-OPTIMIZER DEFPARAMETER SUPPRESS-VAR-DOC) (ADD-OPTIMIZER DEFCONSTANT SUPPRESS-VAR-DOC) (ADD-OPTIMIZER DEFCONST SUPPRESS-VAR-DOC) (DEFUN SUPPRESS-VAR-DOC (FORM) ;; 9/30/86 - Original. (IF (AND (FOURTH FORM) ; has documentation-string *SUPPRESS-DEBUG-INFO* (NOT (EXTERNAL-SYMBOL-P (SECOND FORM))) (NULL (CDDDDR FORM))) ; not too many args ;; strip off the documentation string (LIST (FIRST FORM) (SECOND FORM) (THIRD FORM)) FORM))