LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030340. :SYSTEM-TYPE :LOGICAL :VERSION 14. :TYPE "LISP" :NAME "FILE" :DIRECTORY ("REL3-SOURCE" "COMPILER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758302477. :AUTHOR "REL3" :LENGTH-IN-BYTES 68620. :LENGTH-IN-BLOCKS 68. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              ;-*- Mode:Common-Lisp; Package:COMPILER2; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(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) 1980 Massachusetts Institute of Technology.;;; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;;;;   *-----------------------------------------------------------*;;;;   |           --  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.;;; 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.")#+MIT(DEFVAR QC-FILE-REL-FORMAT NIL  "T means COMPILE-STREAM writes a REL file.If QC-FILE-REL-FORMAT-OVERRIDE is NIL (as it initially is), the file's attribute list can override this variable.If the :FASL file attribute's value is :REL, a REL file is made.If the value is :FASL, a QFASL file is made.If there is no :FASL attribute, the global value of this variable decides.");;; Note: :REL files don't seem to be used anymore, so all references to them ;;;       should be removed if no one finds a need for them in first release.;;;         -- D.N.G.  Dec. 1984#+MIT(DEFVAR QC-FILE-REL-FORMAT-OVERRIDE NIL  "T means ignore the :FASL attribute in the file's attribute list.The global value of QC-FILE REL-FORMAT controls the output file format.")(DEFVAR QC-FILE-FILE-GROUP-SYMBOL :UNBOUND  "Within COMPILE-STREAM, holds the generic-pathname of the input file.");The package we compiled in is left here by COMPILE-STREAM.;But that doesn't appear to be true now??(DEFVAR QC-FILE-PACKAGE)(DEFVAR TARGET-FEATURES NIL) ; *FEATURES* list for the target machine (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*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.  :TARGET is the name of the machine for which code will be generated.  :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 thesecond is a status code equal to one of the following constants:COMPILER:OK, COMPILER:WARNINGS, COMPILER:ERRORS, or COMPILER:FATAL."  ;;  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-PACKAGE    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 )      #+MIT (QC-FILE-REL-FORMAT QC-FILE-REL-FORMAT))  "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.  (DECLARE (VALUES OUTFILE STATUS)) (record-individual-time 'qc-file  (WHEN-SUPPORTING-CROSS-COMPILATION    (WHEN (NULL TARGET-PROCESSOR)      (SETQ TARGET-PROCESSOR HOST-PROCESSOR)      #-Explorer      (IF-IN-LAMBDA (SETQ TARGET-PROCESSOR ':LAMBDA))      ))  ;; 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    #-MIT    (TARGET-BINARY-FILE-TYPE TARGET-PROCESSOR)    #+MIT    (IF (OR (NEQ TARGET-PROCESSOR HOST-PROCESSOR)    (NOT (FBOUNDP 'SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE)))(TARGET-BINARY-FILE-TYPE TARGET-PROCESSOR)      (SI:PATHNAME-DEFAULT-BINARY-FILE-TYPE GENERIC-PATHNAME))))    (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)    #+MIT    (OR QC-FILE-REL-FORMAT-OVERRIDE(CASE (SEND GENERIC-PATHNAME :GET ':FASL)  (:REL (SETQ QC-FILE-REL-FORMAT T))  (:FASL (SETQ QC-FILE-REL-FORMAT NIL))  (NIL)  (T (FERROR NIL "File property FASL value not FASL or REL in file ~A"     GENERIC-PATHNAME))))    ;; 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")     (#+Elroy *PACKAGE* #-Elroy PACKAGE "Package")     (#+Elroy *READ-BASE* #-Elroy IBASE "Base")))  (UNLESS (OR (MEMBER (FIRST X) VARS :TEST #'EQ)      (AND (EQ (FIRST X) #+Elroy '*PACKAGE* #-Elroy '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   #-Explorer   (IF (EQ SI:PROCESSOR-TYPE-CODE '#.SI:LAMBDA-TYPE-CODE)       ':LAMBDA     HOST-PROCESSOR)   #+Explorer   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))(WHEN-SUPPORTING-CROSS-COMPILATION  (WHEN (EQ TARGET-PROCESSOR ':LAMBDA)    ;; Lambda and Cadr are different only in the features list.    (SETQ TARGET-PROCESSOR ':CADR) ))(COND #+MIT      (QC-FILE-REL-FORMAT       (LET ((FASD-STREAM NIL)) ;REL compiling doesn't work the same way (LOCKING-RESOURCES   (QFASL-REL:DUMP-START)   (COMPILE-STREAM INPUT-STREAM GENERIC-PATHNAME FASD-STREAM #'QC-FILE-WORK-COMPILE   LOAD-FLAG IN-CORE-FLAG PACKAGE-SPEC   FILE-LOCAL-DECLARATIONS NIL T)   ;; Output a record of the macros expanded and their current sxhashes.   (WHEN QC-FILE-MACROS-EXPANDED     (QFASL-REL:DUMP-FORM       `(SI:FASL-RECORD-FILE-MACROS-EXPANDED  ',QC-FILE-MACROS-EXPANDED)))   (LET ((*PACKAGE* QC-FILE-PACKAGE))     (QFASL-REL:WRITE-REL-FILE OUTFILE)))))      (T       (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)))))))))  )  (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)));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. (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 )FDEFINE-FILE-PATHNAME*LAST-ADDRESS-READ*)  (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     (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 (NOT (NULL (GET (CADR L) 'FS:FILE-ATTRIBUTE-BINDINGS))) (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))   (WHEN (AND (COMPILING-FOR-V2)      (NOT (COMMON-LISP-ON-P)))     (COND #+Elroy   ((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*)))   #+compiler:debug   ; %%% temporary 6/18/86 %%%   ((OR (EQ *PACKAGE* KERNEL-PACKAGE)SI:FILE-IN-COLD-LOAD)    (WARN ':ZETALISP ':IMPLAUSIBLE  "Warning: this kernel file is still in Zetalisp."))   ;;%%% Later add test here to do automatic MAKE-SYSTEM of the   ;;%%% Zetalisp compatibility subsystem if not already loaded.   ))   (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*)) )   (UNLESS (COMPILING-FOR-EXPLORER-P)     (SETF (GETF PROPS 'NEW-DESTINATIONS) T) )   PROPS))))   ;; First thing in QFASL file must be property list   ;; These properties wind up on the GENERIC-PATHNAME.   (COND #+MIT (QC-FILE-REL-FORMAT  (QFASL-REL#:DUMP-FILE-PROPERTY-LIST    GENERIC-PATHNAME    PLIST)) (T  (FASD-FILE-PROPERTY-LIST PLIST)))))       (QC-PROCESS-INITIALIZE)       (WHEN (AND (NULL (SYMBOL-VALUE 'SOURCE-CODE-AREA)) QC-FILE-LOAD-FLAG) (MAKE-AREA :NAME 'SOURCE-CODE-AREA :REPRESENTATION :LIST    :GC :DYNAMIC #| :READ-ONLY T |# ))       (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 ((#-Elroy READ-AREA  #+Elroy DEFAULT-CONS-AREA  (IF QC-FILE-LOAD-FLAG SOURCE-CODE-AREA QCOMPILE-TEMPORARY-AREA)) ;;(SI:%INHIBIT-READ-ONLY QC-FILE-LOAD-FLAG) (WARN-ON-ERRORS-STREAM INPUT-STREAM) (QC-FILE-READ-IN-PROGRESS FASD-FLAG)   ;looked at by XR-#,-MACRO #+Elroy (SI:*MAXIMUM-READ-BUFFER-SIZE* 256) ;; Include the following after everything has been EXPORTed that should be. ;;#+Elroy ;;(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)))   )))     (SETF *LAST-ADDRESS-READ*   #-Elroy (CONS-IN-AREA READ-AREA NIL READ-AREA)   #+Elroy (CONS DEFAULT-CONS-AREA NIL))     (SETF (CDR *LAST-ADDRESS-READ*)   (%REGION-NUMBER *LAST-ADDRESS-READ*)) )   (setq si:premature-warnings-this-object si:premature-warnings)) (WHEN (EQ FORM EOF) (RETURN)) (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.  (LET-IF (NOT QC-FILE-LOAD-FLAG) ((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]  (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.    (WHEN (AND (MEMBER (FIRST FORM) '(FDEFINE FSET SI:FSET) :TEST #'EQ)       (QUOTEP (SECOND FORM)))      (LET ((FUNCTION-NAME (SECOND (SECOND FORM))))(DOLIST (X FILE-LOCAL-DECLARATIONS)  (WHEN (AND (EQ (FIRST X) 'DEF)     (EQUAL (SECOND X) FUNCTION-NAME))    (WARN 'NOTICE-FDEFINE ':IMPLAUSIBLE "~S is defined twice in this file."  FUNCTION-NAME)    (RETURN)))))    ;; 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 NIL)(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      #+MIT (IF QC-FILE-REL-FORMAT 'REL 'QFASL)      #-MIT '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.  (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))   (PUSH `(DEF ,FUNCTION-SPEC . ,DEFINITION) FILE-LOCAL-DECLARATIONS)   (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))  (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))      (COND #+MIT    (QC-FILE-REL-FORMAT (QFASL-REL:DUMP-FORM FORM OPTIMIZE))    (T (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 returnedbut 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 .  (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)  *LAST-ADDRESS-READ*)      (LET (( EXP-AREA (%AREA-NUMBER FORM) ))(IF (WRITE-PROTECTED-AREA-P EXP-AREA)    (SETF *LAST-ADDRESS-READ* (CONS EXP-AREA (%REGION-NUMBER FORM)))  (SETF *LAST-ADDRESS-READ* (CONS-IN-AREA EXP-AREA NIL EXP-AREA)(CDR *LAST-ADDRESS-READ*)(%REGION-NUMBER *LAST-ADDRESS-READ*))))      (QC-PROCESS-INITIALIZE)      (WITH-COMPILE-DRIVER-BINDINGS(COMPILE-DRIVER  FORM  #'(LAMBDA (FORM TYPE)      (SETQ *COMPILE-FORM-VALUE*    (IF (EQ TYPE 'SPECIAL)(SI:EVAL1 FORM)      (COMPILE-TOP-LEVEL-FORM FORM 'COMPILE-TO-CORE #'SI:EVAL1) )))  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.  (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)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))      #-Elroy   ; not needed anymore because DEFSTRUCT handles this itself.      ((MEMBER (CAR OFORM) '(GLOBAL:DEFSTRUCT CLI:DEFSTRUCT) :TEST #'EQ)       (PUSH `(FUNCTION-PARENT ,(IF (SYMBOLP (CADR OFORM)) (CADR OFORM) (CAADR 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 SHADOWUSE-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)       (SI:EVAL1 `(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.  (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) :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:SUBSTGLOBAL:NAMED-LAMBDA NAMED-LAMBDAGLOBAL: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) `(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 (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"))      (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))      (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 &QUOTE'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.  (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) (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))((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]  (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.  (COND ((>= INDEX (LSH 1 20)) (FASD-START-GROUP NIL 2 FASL-OP-LARGE-INDEX) (FASD-NIBBLE (LDB (BYTE 10 20) INDEX)) (FASD-NIBBLE (LDB (BYTE 20 0) INDEX)))(T (FASD-START-GROUP NIL 1 FASL-OP-INDEX)  (FASD-NIBBLE 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.  (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) ))      (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 (&QUOTE SI:PATCH-SOURCE-FILE-NAMESTRING &REST BODY)  ;; Evaluate the forms within the binding of special variable PATCH-SOURCE-FILE-NAMESTRING .  (MAPC #'SI:EVAL1 BODY));;;  ---- Optimizers and style checkers for forms usually used at top level.  ----#-Elroy (progn ; a macro in release 3(ADD-OPTIMIZER LOCALLY EXPAND-LOCALLY)(DEFUN EXPAND-LOCALLY (FORM)  ;; Don't expand LOCALLY into PROGN at top-level in COMPILE-DRIVER.  ;; This way, we protect DECLAREs inside the LOCALLY  ;; from being treated as top-level DECLARE, which would be erroneous.  ;; The LOCALLY form will just be executed as a random form.  `(LET () . ,(CDR FORM))))(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)  ;; 08/09/86 Original. [previously part of COMPILE-DRIVER]  ;; 10/03/86 Don't wrap DONT-OPTIMIZE around the new form.   (WHEN (AND (TOP-LEVEL-DUMMY-FUNCTION-P)     UNDO-DECLARATIONS-FLAG     (SYMBOLP (SECOND FORM))     (CDDR FORM)     (NOT (EQ (SECOND FORM) (CAAR FILE-CONSTANTS-LIST)))) ; haven't already done this    (UNLESS      (WARN-ON-ERRORS ('COMPILE-TIME-EVALUATION-ERROR       "Error evaluating ~S" FORM);; Try to compute the value now.(LET (( VALUE (EVAL-FOR-TARGET (THIRD FORM)) ))  ;; Save value of constant for use by P1 or SYMEVAL-FOR-TARGET .  (PUSH (CONS (SECOND FORM) VALUE)FILE-CONSTANTS-LIST)  (WHEN (AND (OR (NUMBERP VALUE) (SYMBOLP VALUE) (CHARACTERP VALUE) )     (NOT (CONSTANTP (THIRD FORM))))    ;; Eligible for value substitution; make sure it has the same value    ;; at load time as at compile time.    (SETQ FORM (LIST* (FIRST FORM) (SECOND FORM) `(QUOTE ,VALUE) (CDDDR FORM)))))T)      ;; Else can't compute value now; disable substitution until loaded.      (PUTPROP-FOR-TARGET (SECOND FORM) 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)));; 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 (OR (CONSTANTP VALUE)    (NOT (COMPILING-FOR-V2)))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 DEFVARSUPPRESS-VAR-DOC)(ADD-OPTIMIZER DEFPARAMETERSUPPRESS-VAR-DOC)(ADD-OPTIMIZER DEFCONSTANTSUPPRESS-VAR-DOC)(ADD-OPTIMIZER DEFCONSTSUPPRESS-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))#-Elroy(progn;;;********************************************************;;;The following optimizers are temporary until these forms;;;are redefined as macros.;;;********************************************************(ADD-OPTIMIZER DEFUN DEFUN-OPT)(DEFUN DEFUN-OPT (FORM)  (LET ((NAME (SECOND FORM)))    (LET ((FV (SI:PROCESS-DEFUN-BODY NAME (CDDR FORM))))      (IF (COMMON-LISP-ON-P)  (SETQ FV (CONS 'NAMED-LAMBDA (CDR FV)))(SETQ FV (CONS 'GLOBAL:NAMED-LAMBDA (CDR FV))))      `(PROGN (FDEFINE ',NAME (FUNCTION ,FV) T)      ',NAME) )))(ADD-OPTIMIZER DEFSUBST DEFSUBST-OPT)(DEFUN DEFSUBST-OPT (FORM)  (LET ((NAME (SECOND FORM)))    (LET ((FV (SI:PROCESS-DEFUN-BODY NAME (CDDR FORM) T)))      (SETQ FV (CONS (IF (COMMON-LISP-ON-P) 'NAMED-SUBST       'GLOBAL:NAMED-SUBST)     (CDR FV)))      `(PROGN (FDEFINE ',NAME (FUNCTION ,FV) T)      ',NAME) )))(ADD-OPTIMIZER DEFF DEFF-EXPAND)(DEFUN DEFF-EXPAND (FORM)  (LET ((FUNCTION-SPEC (SECOND FORM))(DEFINITION (THIRD FORM)))    `(PROGN (FDEFINE ',function-spec ,definition T)    ',function-spec)))(ADD-OPTIMIZER DEF DEF-EXPAND)(DEFUN DEF-EXPAND (FORM)  (LET ((FUNCTION-SPEC (SECOND FORM))(DEFINING-FORMS (CDDR FORM)))    `(PROGN (SI:RECORD-SOURCE-FILE-NAME ',FUNCTION-SPEC)    ,@DEFINING-FORMS    (EVAL-WHEN (LISP:COMPILE) (COMPILER:COMPILATION-DEFINE ',FUNCTION-SPEC))    ',FUNCTION-SPEC ) ))(DEFPROP DEF T SI:MAY-SURROUND-DEFUN)(ADD-OPTIMIZER DEFF-MACRO DEFF-MACRO-EXPAND)(DEFUN DEFF-MACRO-EXPAND (FORM)  (LET ((FUNCTION-SPEC (SECOND FORM))(DEFINITION (THIRD FORM)))    `(EVAL-WHEN (EVAL LISP:COMPILE LOAD)       (FDEFINE ',function-spec ,definition T)       ',function-spec)))(ADD-OPTIMIZER MACRO MACRO-EXPAND)(DEFUN MACRO-EXPAND (FORM)  (LET ((FUNCTION-SPEC (SECOND FORM))(DEF (CDDR FORM)))    (LET* ((function-spec (SI:STANDARDIZE-FUNCTION-SPEC function-spec))   (fv (SI:PROCESS-DEFUN-BODY function-spec def))   (def (CONS 'MACRO (IF (COMMON-LISP-ON-P) (CONS 'NAMED-LAMBDA (CDR FV))       fv))))      `(PROGN (FDEFINE ',function-spec (FUNCTION ,def) t)      ',function-spec)))));;;  9/30/86 DNG - Moved functions BARF and WARN to file COMPILE.(COMPILAND-FLAVOR COMPILAND)   (COMPILAND-SELF-MAP-NEEDED COMPILAND)) )    (AND (SYMBOLP FUNCTION-TO-BE-DEFINED) (FBOUNDP FUNCTION-TO-BE-DEFINED) (SETQ OLD-DEF (FDEFINITION FUNCTION-TO-BE-DEFINED)) ;; When a name that used to be a macro or subst is redefined ;; as a function, need to remember the new definition in order ;; to shadow the old one that is still in the global environment. (OR (EQ (CAR-SAFE OLD-DEF) 'MACRO)     (MEMBER (FIRST (LET-UNLESS-CONSTANT (#+Elroy (TARGET-PROCESSOR    HOST-PROCESSOR))      (INTERPRETED-DEF OLD-DEF)))     '(GLOBAL:SUBST GLOBAL:NAMED-SUBST       CLI:SUBST NAMED-SUBST)     :TEST #'EQ) ) )    );; Was definition already saved by an (EVAL-WHEN (COMPILE)...)?       (NOT (AND (EQ (FIRST (FIRST FILE-LOCAL-DECLARATIONS)) 'DEF) (EQUAL (SECOND (FIRST FILE-LOCAL-DECLARATIONS)) FUNCTION-TO-BE-DEFINED))))       ;; Save definition for function MAYBE-INTEGRATE to pick up later.  