LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030326. :SYSTEM-TYPE :LOGICAL :VERSION 10. :TYPE "LISP" :NAME "DEFS" :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 2758302361. :AUTHOR "REL3" :LENGTH-IN-BYTES 50657. :LENGTH-IN-BLOCKS 50. :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) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;; Copyright (C) 1980, Massachusetts Institute of Technology.;;;;   *-----------------------------------------------------------*;;;;   |          --  TI Explorer Lisp Compiler  --                |;;;;   |  This file contains definitions of variables, structures, |;;;;   |  macros, etc. that are used in more than one phase of the |;;;;   |  compiler but are not included in the minimal kernel.   |;;;;   *-----------------------------------------------------------*;;; Feb. 1984 - File "SYS;QCDEFS" - Version 98 from MIT via LMI.;;; July 1984 - TI modifications to support OPTIMIZE declarations, properly;;;               initialize some fasdump variables for compiler re-entrancy;;;               (bug 147), and minor changes in support of new optimizations.;;; 08/06/84 DNG - From MIT patch 98.47, add new macro definitions ;;;               DEFOPTIMIZER and DEFCOMPILER-SYNONYM.  The new macro definition;;;               for ADD-OPTIMIZER has not been included since there seems to be;;;               no reason for it to be a macro instead of a function and because;;;               the macro version builds the optimizers list in reverse order;;;               which is not correct.;;; 08/06/84 DNG - From MIT patch 98.50, update EXTRACT-DECLARATIONS-RECORD-MACROS;;;               and add (DEFVAR LOCAL-FUNCTION-MAP).;;; 09/05/84 DNG - Add some more documentation strings.;;; 09/10/84 DNG - Add *RETURN-STATUS* etc.;;; 11/15/84 DNG - Add HOST-PROCESSOR, TARGET-PROCESSOR, COMPILING-FOR-EXPLORER-P .;;; 12/07/84 DNG - Add LOAD-FOR-TARGET and EVAL-FOR-TARGET.;;; 12/26/84 DNG - Make LOCKING-RESOURCES unconditional to fix bug 594;;;;                added declaration for FILE-CONSTANTS-LIST.;;;  1/16/85 DNG - Define :CROSS-LOAD transformation for DEFSYSTEM.;;;  1/23/85 DNG - Add DEFSTRUCT for EXPR.;;;  2/05/85 DNG - Modify package handling in LOAD-FOR-TARGET.;;;  2/08/85 DNG - New function INIT-SYSTEM-VAR-PROPERTIES .;;;  2/15/85 DNG - Moved LOGDIF to here from QCP1.;;;  3/08/85 DNG - SYMEVAL-FOR-TARGET and EVAL-FOR-TARGET check FILE-CONSTANTS-LIST.;;;  4/23/85 DNG - Work-around ARRAY-INITIALIZE bug [856]; make HOST-PROCESSOR;;;   a constant; add doc string to variable WARN-ON-ERRORS.;;;  4/26/85 DNG - Improve indentation error message in WARN-ON-ERRORS-CONDITION-HANDLER.;;;  7/10/85 DNG - Began changes for release 3.  Renamed from "SYS;QCDEFS" to "COMPILER;DEFS".;;;  9/23/85 DNG - Moved a few variables from QCFILE to here.;;; 12/07/85 DNG - Moved a few variables from here to P1DEFS; moved EXPORT declarations;;;   to here from SYS:SYS2;EXPORT.;;;  2/01/86 DNG - Moved some DEFVARs to here from the FASD file.;;;  3/24/86 DNG - Converted from Zetalisp to Common Lisp.;;;  4/18/86 DNG - Define constants COMMON-LISP-PACKAGE and ZETALISP-PACKAGE.;;;  4/24/86 DNG - Dummy definition of LAMBDA-MACRO-EXPAND.;;;  5/28/86 DNG - Delete obsolete variable FUNCTION-BEING-PROCESSED.;;;  6/21/86 DNG - Variable LOCAL-MACROS replaced by *LOCAL-ENVIRONMENT*.;;;  8/04/86 DNG - Moved EVAL-AT-LOAD-TIME-MARKER from file DEFS to MINDEFS.;;;  8/08/86 DNG - Structure COMPILAND replaces COMPILER-QUEUE-ENTRY.;;;  8/09/86 DNG - Variable INSIDE-QC-TRANSLATE-FUNCTION deleted; test COMPILER-QUEUE instead.;;;  9/17/86 DNG - Deleted dummy warnings definitions moved to file WARNDEFS.;;; 10/18/86 DNG - Moved EXTRACT-DECLARATIONS-RECORD-MACROS to file P1FUNS.;;;  2/06/87 DNG - Modify FASD-HASH-TABLE parameters to reduce re-hashing.;;;  2/07/87 DNG - SOURCE-CODE-AREA is no longer write-protected.;;;  2/16/87 DNG - Add COMPILAND-INITIAL-ENVIRONMENT-VARS .;;;  4/04/87 DNG - Fixes to COMPILER-TEMPS-RESOURCE .(EXPORT '(OK WARNINGS ERRORS FATAL ABORTED))  ; status value names;;; The following macro is used to surround temporary code which is only;;; used for debugging the compiler so that the debug code will be;;; automatically excluded from the object of the released version.#+compiler:debug(DEFMACRO IF-DEBUG (&BODY BODY) `(PROGN . ,BODY)) #-compiler:debug(DEFMACRO IF-DEBUG (&BODY BODY) (DECLARE (IGNORE BODY)) 'NIL) ; discard debug code(EVAL-WHEN (EVAL LISP:COMPILE LOAD)  (DEFPROP IF-DEBUG T SI:MAY-SURROUND-DEFUN) )(DEFCONSTANT CONTINUE-MESSAGE "Continue anyway.")(DEFCONSTANT ASSERT-FORMAT "Compiler bug - failed assertion ~S")(DEFMACRO DEBUG-ASSERT (TEST-FORM &OPTIONAL PLACES &REST ARGS)  ;; Like ASSERT except that it is only used for debugging and becomes a no-op  ;; in the final release build.  Also, it permits continuing and returns true  ;; if the condition passes or nil if it failed. [ASSERT always returns NIL.]  ;;  9/11/86 DNG - Original.  (DECLARE (ARGLIST TEST-FORM &OPTIONAL PLACES FORMAT-STRING &REST FORMAT-ARGS))  #-compiler:debug  (PROGN TEST-FORM PLACES ARGS T)  #+compiler:debug  (LET ((REPORTER  (COND (PLACES `(ASSERT ,TEST-FORM ,PLACES . ,ARGS))(ARGS `(CERROR CONTINUE-MESSAGE . ,ARGS))(T `(CERROR CONTINUE-MESSAGE ASSERT-FORMAT ',TEST-FORM)))))    `(COND (,TEST-FORM T)   (T ,REPORTER NIL))))(DEFSUBST LOGDIF (A B)  (BOOLE 4 A B))  ; logical difference -- A and not B#+Elroy ; dummy routine -- lambda macros no longer supported in release 3.(DEFSUBST LAMBDA-MACRO-EXPAND (FUNCTION) FUNCTION) #+Elroy(DEFSUBST LAMBDA-MACRO-CALL-P (OBJECT) (DECLARE (IGNORE OBJECT)) NIL)(DEFSUBST BOOLEAN-FUNCTION-P (FUNCTION-NAME)  ;; Does the function return only T or NIL?  ;; The FUNCTION-RESULT-TYPE property is set in file TYPEOPT.  (EQ (GET FUNCTION-NAME 'FUNCTION-RESULT-TYPE)      'T-OR-NIL))(DEFVAR QCOMPILE-TEMPORARY-AREA NIL   "Area for compilation itself (within QC-TRANSLATE-FUNCTION) to cons in.") ;; Use DEFVAR to avoid creating the area more than once.;; The actual initialization is done in COMPILE-STREAM .(DEFVAR SOURCE-CODE-AREA NIL  "The compiler reads its input into this area when compiling in memory.")(PROCLAIM '(INLINE WRITE-PROTECTED-AREA-P ENABLE-WRITE))(DEFUN WRITE-PROTECTED-AREA-P (AREA-NUMBER)  (OR (EQ AREA-NUMBER MACRO-COMPILED-PROGRAM)      (EQ AREA-NUMBER SI:DEBUG-INFO-AREA)      ;;(EQ AREA-NUMBER SOURCE-CODE-AREA)      ))(DEFUN ENABLE-WRITE (LIST) LIST)(comment ; deleted 2/7/87(DEFUN ENABLE-WRITE (LIST)  ;; copy list if necessary so that it is not write-protected.  (IF (EQ (%AREA-NUMBER LIST) SOURCE-CODE-AREA)      (COPY-TREE LIST)    LIST))) ; end comment(DEFCONSTANT GENERATING-MICRO-COMPILER-INPUT-P NIL   "This is T if the compiler is generating macro-code to pass to the micro compiler.In that case, the code is generated a little differentlyso as to lead to more optimal microcode.(Actually, it can fail to be valid macrocode, in little ways).") (DEFVAR FUNCTION-TO-BE-DEFINED NIL   "Function spec to be defined as the result of the current compilation.") (DEFVAR NAME-TO-GIVE-FUNCTION NIL   "This is the function spec to put in the name of the fef produced by the compilation.Usually this is the same as FUNCTION-TO-BE-DEFINED.") (DEFPARAMETER COMPILER-VERBOSE NIL   "T means print name of each function when its compilation begins.") (DEFPARAMETER HOLDPROG T   "If nil, the lap instructions are typed out on the terminalinstead of being saved up for lap.") ;This is non-nil if we are supposed to compile;direct accesses to instance variables of SELF.;Its value then is (flavor-name (special-instance-var-names...) instance-var-names...)(DEFVAR SELF-FLAVOR-DECLARATION NIL) ;; Ordered list of instance variables for the mapping table.  This variable is;; initialized and tested in QCOMPILE0, and set in P2-SOURCE.(DEFVAR SELF-FLAVOR-MAPPED-VARIABLES)  #|;BARF-SPECIAL-LIST is a list of all variables automatically declared special;by the compiler.  Those symbols are special merely by virtue of being on;this list, which is bound for the duration of the compilation;(for the whole file, whole editor buffer, or just the one function in COMPILE).;All users of QC-TRANSLATE-FUNCTION MUST bind this variable.;NOTE!! This list must not be CONSed in a temporary area!!  It lives across; whack boundaries.(DEFVAR BARF-SPECIAL-LIST NIL "List of symbols automatically made special in this file.") |#;This is like BARF-SPECIAL-LIST but only lists those symbols;used in the function now being compiled.;If a variable used free is not on this list, it gets a new warning;even though it may already be special because it is on BARF-SPECIAL-LIST.;So there is a new warning for each function that uses the symbol.(DEFVAR THIS-FUNCTION-BARF-SPECIAL-LIST NIL   "List of symbols used free in this function but not declared special.These are the symbols that have been warned about for this function.") ;If this is not NIL, there is no warning about using an undeclared free variable.;This is for compiling DEFSUBSTs, which often refer to free variables.;That's ok if you intend them only for expansion.(DEFVAR INHIBIT-SPECIAL-WARNINGS NIL) ;SPECIAL-PKG-LIST is a list of packages all of whose symbols should be special.(DEFVAR SPECIAL-PKG-LIST (LIST (FIND-PACKAGE "FONTS")))(DEFCONSTANT COMMON-LISP-PACKAGE (SYMBOL-PACKAGE 'CLI:LAMBDA))(DEFCONSTANT ZETALISP-PACKAGE (SYMBOL-PACKAGE 'GLOBAL:LAMBDA))(DEFCONSTANT KERNEL-PACKAGE (FIND-PACKAGE "SI"))(DEFSTRUCT (OPTIMIZE-SWITCHES (:TYPE :FIXNUM) :COPIER      (:CONSTRUCTOR NIL)      (:CONC-NAME NIL) (:ALTERANT NIL) (:PREDICATE NIL))  "Common Lisp OPTIMIZE declaration"  (( OPT-SPEED-OR-SPACE #o2004 1)   ( OPT-SPEED #o1404 1 )   ( OPT-SPACE #o1004 1 )   ( OPT-COMPILATION-SPEED #o0404 1 )   ( OPT-SAFETY #o0004 1 )   ));; define my own constructer because I keep having all kinds of trouble with the ;; one that defstruct creates.  -- DNG 10/8/86(DEFSUBST MAKE-OPTIMIZE-SWITCHES ()   #x11111) ; all values default to 1(DEFVAR OPTIMIZE-SWITCH (MAKE-OPTIMIZE-SWITCHES)   "current optimization levels from OPTIMIZE declarations") (ADD-INITIALIZATION "OPTIMIZE-SWITCH"    '(SETQ OPTIMIZE-SWITCH (MAKE-OPTIMIZE-SWITCHES))    '(:LOGIN))(DEFUN SPEED-OVER-SAFETY-P (); used by flavor system   (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))) (DEFUN OPTIMIZE-STATUS ()  "Report the current values of the OPTIMIZE switches.The value returned is in the form of a declaration specifier sothat one can do:  (SETQ SAVE-OPT (COMPILER:OPTIMIZE-STATUS))  ...  (PROCLAIM SAVE-OPT) ; restores previous optimization values"  (LIST 'OPTIMIZE(LIST 'SPEED (OPT-SPEED OPTIMIZE-SWITCH))(LIST 'SPACE (OPT-SPACE OPTIMIZE-SWITCH))(LIST 'SAFETY (OPT-SAFETY OPTIMIZE-SWITCH))(LIST 'COMPILATION-SPEED (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))))     ;; QCMP-OUTPUT is an ART-Q-LIST array into which the;; lap-instructions are stored by pass 2.(DEFVAR QCMP-OUTPUT) ;MACRO-COMPILE or MICRO-COMPILE.(DEFVAR QC-TF-PROCESSING-MODE) ;; QC-TF-OUTPUT-MODE deleted 8/9/86 -- now just a local variable in QC-TRANSLATE-FUNCTION.;PEEP-ENABLE, if T, means that the peephole optimizer should be used.(DEFVAR PEEP-ENABLE T "When not NIL enables use of the peephole optimizer.") ;FUNCTIONS-REFERENCED is a list of all functions referred to in the file being;compiled, and not defined in the world.  Each element has as its CAR the;name of the function, and as its CDR a list of the names of the functions;which referenced it.(DEFVAR FUNCTIONS-REFERENCED) ;;;   ------------------;;; Compiler switches:  set these with (EVAL-WHEN (COMPILE) (SETQ ...));;; These are reinitialized in QC-PROCESS-INITIALIZE;This, if T, causes MAP, etc. to be open-coded.  It is normally T.(DEFVAR OPEN-CODE-MAP-SWITCH T   "When not nil, the compiler will open-code calls to MAP, MAPC, MAPCAR, etc.") ;This, if T, causes a check to be made for the use of a local variable;as a function to be called, meaning funcall.  This should be set to T;only for compiling old-fashioned Maclisp code.(DEFVAR ALLOW-VARIABLES-IN-FUNCTION-POSITION-SWITCH NIL   "When true, allows old-fashioned MacLisp function callusing a variable as the first element of a form.") ;This, if T, makes all variables special.(DEFVAR ALL-SPECIAL-SWITCH NIL   "When true, causes all variables to be compiled as special variables.The only purpose of this is compatibility with the old Zetalisp interpreter.") ;This, if T (as it usually is), warns the user if any obsolete;Maclisp functions are used.(DEFVAR OBSOLETE-FUNCTION-WARNING-SWITCH T   "When not nil, the compiler will warn about use of obsolete functions.") ;This, if T, warns the user if he does anything that clearly;cannot work in Maclisp.(DEFVAR RUN-IN-MACLISP-SWITCH NIL   "When not nil, the compiler will warn about things that can't work in Maclisp.") ;This, if T, prevents warnings about a lot of stylistic losses.(DEFVAR INHIBIT-STYLE-WARNINGS-SWITCH NIL   "When NIL, enables the compiler to warn about bad programming style.") ;;;   ------------------;Counts number of lexical closures we had to make.(DEFVAR LEXICAL-CLOSURE-COUNT) (DEFVAR WARN-CATCHER NIL)   ; if not nil, WARN will THROW back to this tag instead  ;  of reporting an error.(DEFPARAMETER OK 0 "Second value returned by compiler when no problems found.") (DEFPARAMETER WARNINGS 10 "Second value returned by compiler when warning messages were issued.") (DEFPARAMETER ERRORS 20 "Second value returned by compiler when errors were found.") (DEFPARAMETER FATAL 30 "Second value returned by compiler when fatal errors encountered.") (DEFPARAMETER ABORTED 40 "Second value returned by compiler when unable to generate any object.") (DEFVAR *RETURN-STATUS* OK)  ; The error status to be returned.(DEFVAR COMPILING-COMMON-LISP T) ; set by QCOMPILE0 if Common Lisp function being compiled(DEFVAR COLD-LOAD-FILES NIL) ; Files known to be in the cold load; used by CHECK-COLD.;;======================#-compiler:debug(DEFMACRO RECORD-ELAPSED-TIME (ID &BODY BODY); dummy version; real one below  `(PROGN     ,ID     ,@BODY)) #-compiler:debug(DEFMACRO RECORD-INDIVIDUAL-TIME (ID &BODY BODY); dummy version; real one below  `(PROGN     ,ID     ,@BODY)) #+compiler:debug(PROGN ; execution time measurement added 1/10/85(DEFPARAMETER CURRENT-TIMER '(NIL . 0)) (DEFVAR TIMER-START-TIME 0)(DEFPARAMETER TIMERS (LIST CURRENT-TIMER) "A-list of ids and execution times.")(DEFMACRO RECORD-ELAPSED-TIME (ID &BODY BODY)  `(LET ((START-TIME (TIME)))     (PROG1       (PROGN . ,BODY)       (LET* ((DELTA (TIME-DIFFERENCE (TIME) START-TIME))      (TEM (ASSOC ,ID TIMERS :TEST #'EQ))) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))   (IF (NULL TEM)       (PUSH (CONS ,ID DELTA) TIMERS)     (INCF (CDR TEM) DELTA)))))))(DEFUN START-TIMER (ID)  (DECLARE (OPTIMIZE SPEED))  (UNLESS (EQ ID (CAR CURRENT-TIMER))    (LET ((DELTA (TIME-DIFFERENCE (TIME) TIMER-START-TIME)))      (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))(INCF (CDR CURRENT-TIMER) DELTA)(WHEN (NULL (SETQ CURRENT-TIMER (ASSOC ID TIMERS :TEST #'EQ)))  (PUSH (SETQ CURRENT-TIMER (CONS ID 0)) TIMERS))))    (SETQ TIMER-START-TIME (TIME))))(DEFMACRO RECORD-INDIVIDUAL-TIME (ID &BODY BODY)  `(LET ((OLD-ID (CAR CURRENT-TIMER)))     (PROG2 (START-TIMER ,ID)    (PROGN . ,BODY)       (START-TIMER OLD-ID))))(DEFUN RESET-TIMERS ()  (SETQ TIMERS (LIST (CONS NIL 0)))  (VALUES))(DEFUN PRINT-TIMERS (&OPTIONAL (STREAM T))  (SETQ TIMERS (SORT TIMERS #'> :KEY #'CDR))  (LET ((TOTAL-TIME 0))    (DOLIST (X TIMERS)      (UNLESS (NULL (CAR X))(INCF TOTAL-TIME (CDR X))))    (DOLIST (X TIMERS)      (LET ((NAME (CAR X)) (COUNT (CDR X)))(UNLESS (NULL NAME)  (FORMAT STREAM "~&~8,2F sec [~2D%] in ~A"  (/ COUNT INTERNAL-TIME-UNITS-PER-SECOND)  (ROUND (* 100 COUNT) TOTAL-TIME) NAME))))    (FORMAT STREAM "~&~8,2F seconds total."    (/ TOTAL-TIME INTERNAL-TIME-UNITS-PER-SECOND)))  (VALUES))(DEFUN TIMEIT (&QUOTE FORM)  "Evaluate FORM and tell how much time spent in each part of the compiler."  (LET (TIMERS)    (RESET-TIMERS)    (SI:EVAL1 (IF (EQ (CAR-SAFE FORM) 'QUOTE)  (SECOND FORM)FORM))    (PRINT-TIMERS))))   ; end of IF-DEBUG;;======================(DEFMACRO LOCKING-RESOURCES (&BODY BODY)  "Allocate a temporary area, QCMP-OUTPUT and fasd tables for this process."  ;; 12/26/84 DNG - Remove IF from around the USING-RESOURCE, making it unconditional.  ;;    The old way failed to allocate the fasd table if a form such  ;;    as DUMP-FORMS-TO-FILE was executed by a Compile Buffer.  Each  ;;    call to LOCKING-RESOURCES surrounds code that will write a complete  ;;    fasl file, so it needs its own set of fasd tables even if another  ;;    compilation happens to be in progress to a different file.  `(USING-RESOURCE (TEMPS COMPILER-TEMPS-RESOURCE)     (LET ((QCOMPILE-TEMPORARY-AREA (FIRST TEMPS))   (FASD-HASH-TABLE (SECOND TEMPS))   (FASD-EVAL-HASH-TABLE (THIRD TEMPS))   (QCMP-OUTPUT (FOLLOW-STRUCTURE-FORWARDING (FOURTH TEMPS)))   (FASD-TYO-BUFFER-ARRAY (FIFTH TEMPS))   FASD-PACKAGE   FASD-TABLE-CURRENT-INDEX)       (DECLARE (SPECIAL FASD-PACKAGE FASD-TABLE-CURRENT-INDEX FASD-TYO-BUFFER-ARRAY))       (RESET-TEMPORARY-AREA QCOMPILE-TEMPORARY-AREA)       (CLRHASH FASD-HASH-TABLE)       (CLRHASH FASD-EVAL-HASH-TABLE)       (SETF (FILL-POINTER QCMP-OUTPUT) 0)       (PROG1 (PROGN . ,BODY)      (RESET-TEMPORARY-AREA QCOMPILE-TEMPORARY-AREA)      (CLRHASH FASD-HASH-TABLE)      (CLRHASH FASD-EVAL-HASH-TABLE)      (ARRAY-INITIALIZE QCMP-OUTPUT NIL))))) (DEFMACRO LOCKING-RESOURCES-NO-QFASL (&BODY BODY)  "Allocate a temporary area and a QCMP-OUTPUT for this process.Use this when compiling to core.Does not set up fasd tables, to save time."  ;;  5/19/86 DNG - Add check for INSIDE-QC-TRANSLATE-FUNCTION so that recursive  ;;calls to COMPILE do not use the same output array.  [SPR 2235]  ;;  8/09/86 DNG - Test COMPILER-QUEUE instead of INSIDE-QC-TRANSLATE-FUNCTION.  `(FLET ((LOCKING-RESOURCES-BODY NIL ,@BODY))     (IF (AND QCOMPILE-TEMPORARY-AREA      (NULL COMPILER-QUEUE)) ; not already within QC-TRANSLATE-FUNCTION (LOCKING-RESOURCES-BODY)       (USING-RESOURCE (TEMPS COMPILER-TEMPS-RESOURCE) (LET ((QCOMPILE-TEMPORARY-AREA (FIRST TEMPS))       (FASD-HASH-TABLE NIL)       (FASD-EVAL-HASH-TABLE NIL)       (QCMP-OUTPUT (FOLLOW-STRUCTURE-FORWARDING (FOURTH TEMPS))))   (RESET-TEMPORARY-AREA QCOMPILE-TEMPORARY-AREA)   (SETF (FILL-POINTER QCMP-OUTPUT) 0)   (PROG1 (LOCKING-RESOURCES-BODY)  (RESET-TEMPORARY-AREA QCOMPILE-TEMPORARY-AREA)  (ARRAY-INITIALIZE QCMP-OUTPUT NIL))))))) (DEFRESOURCE TEMP-AREA-RESOURCE ()  ;;  4/04/87 DNG - Original.  :FREE-LIST-SIZE 10.  :CONSTRUCTOR    (MAKE-AREA :NAME (GENTEMP "COMPILATION-AREA-" SI:PKG-COMPILER-PACKAGE)       :GC :TEMPORARY)  :CLEANUP NIL)(DEFRESOURCE COMPILER-TEMPS-RESOURCE ()  ;;  2/06/87 DNG - Modify options on the FASD-HASH-TABLE to reduce the number of  ;;re-hashes needed on DUMP-FORMS-TO-FILE of very large data structures.  ;;  4/03/87 DNG - Reduce FASD-HASH-TABLE re-hash threshold from 70% to 50% for  ;;efficiency [SPR 4539] and increase the initial size from 14000 to 19600.  ;;  4/04/87 DNG - Split out area creation as a separate resource so that the  ;;arrays can be reclaimed on FULL-GC without losing the area numbers. [SPR 4509,4581]  :FREE-LIST-SIZE 10.  :CONSTRUCTOR   (LIST (ALLOCATE-RESOURCE 'TEMP-AREA-RESOURCE) ; temporary area         ;; FASD-HASH-TABLE -- big enough to very rarely need re-hashing in ;;COMPILE-FILE.  After one re-hash it can hold more than the FASL ;;table and after three re-hashes it can hold more than the 16-bit ;;limit on FASL table indexes. (MAKE-HASH-TABLE :TEST #'EQ :HASH-FUNCTION NIL  :SIZE 19600. ; enough for COMPILE-FILE of about 3000 lines  :REHASH-SIZE 2.0s0 :REHASH-THRESHOLD 0.5s0  :AREA WORKING-STORAGE-AREA) (MAKE-HASH-TABLE :TEST #'EQUAL :SIZE 256 :AREA WORKING-STORAGE-AREA) (MAKE-ARRAY 1536 :AREA WORKING-STORAGE-AREA          :TYPE 'ART-Q-LIST  :LEADER-LIST '(0)  :ADJUSTABLE T) (MAKE-ARRAY 512 :ELEMENT-TYPE '(UNSIGNED-BYTE 16)         :LEADER-LENGTH 1         :AREA WORKING-STORAGE-AREA) )  :CLEANUP #'(LAMBDA (&REST ARGS)       (APPLY #'SI:REINITIALIZE-RESOURCE ARGS)       (DEALLOCATE-WHOLE-RESOURCE 'TEMP-AREA-RESOURCE)) );Flag when compiler warnings are being saved for a higher level, like MAKE-SYSTEM(DEFVAR COMPILER-WARNINGS-CONTEXT NIL) (DEFMACRO COMPILER-WARNINGS-CONTEXT-BIND (&BODY BODY)  "Bind some variables used for compiler warnings."  ;; 10/09/86 DNG - Delete bindings of LAST-ERROR-FUNCTION and BARF-SPECIAL-LIST .  (LET ((TOP-LEVEL-P-VAR (GENSYM)))    `(LET ((,TOP-LEVEL-P-VAR (NOT COMPILER-WARNINGS-CONTEXT)))       (LET-IF ,TOP-LEVEL-P-VAR       ((COMPILER-WARNINGS-CONTEXT T)(FUNCTIONS-REFERENCED NIL)#| (BARF-SPECIAL-LIST NIL) |#) (PROG1   (PROGN . ,BODY)   (COND (,TOP-LEVEL-P-VAR  (PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED)))))))) (DEFUN FUNCTION-REFERENCED-P (FUNCTION)  (ASSOC FUNCTION FUNCTIONS-REFERENCED :TEST #'EQUAL)) (DEFUN COMPILATION-DEFINE (FUNCTION-SPEC)  "Record that a definition of FUNCTION-SPEC has been compiled."  ;;  3/14/86 DNG - Set target property.  ;;  5/15/86 DNG - Don't bother setting the :COMPILATION-DEFINED property  ;;unless it really provides useful information.  (WHEN (AND (SYMBOLP FUNCTION-SPEC)     (OR (NOT (FBOUNDP FUNCTION-SPEC)) (NOT (EQ (GET-FOR-TARGET FUNCTION-SPEC :SOURCE-FILE-NAME)  FDEFINE-FILE-PATHNAME))))    (SETF (GET-TARGET-PROPERTY FUNCTION-SPEC :COMPILATION-DEFINED)  (OR FDEFINE-FILE-PATHNAME T)))) (DEFUN COMPILATION-DEFINEDP (FUNCTION-SPEC)  "T if the function spec is defined or a definition of it has been compiled.Always returns T if function spec is not a symbol."  ;;  3/04/86 DNG - Use FBOUNDP-FOR-TARGET instead of FDEFINEDP.  ;;  3/14/86 DNG - Alternate handling when *DEFAULT-DEFS-FROM-HOST* is false.  ;;  3/18/86 DNG - Fix for when *DEFAULT-DEFS-FROM-HOST* is true.  ;;  8/29/86 DNG - Consider a function type declaration to be a definition.  (IF (OR *DEFAULT-DEFS-FROM-HOST* (EQ TARGET-PROCESSOR HOST-PROCESSOR))      (OR (CONSP FUNCTION-SPEC)  (AND FUNCTION-SPEC (SYMBOLP FUNCTION-SPEC)       (OR (FBOUNDP-FOR-TARGET FUNCTION-SPEC)   (NOT (MEMBER (GET-FOR-TARGET FUNCTION-SPEC :COMPILATION-DEFINED)'(NIL :UNDEFINED):TEST #'EQ))   (LISTP (GETDECL FUNCTION-SPEC 'FUNCTION-ARG-TYPES :UNDEFINED)))))    (OR (DECLARED-DEFINITION FUNCTION-SPEC)(AND (SYMBOLP FUNCTION-SPEC)     (GET-TARGET-PROPERTY FUNCTION-SPEC :COMPILATION-DEFINED))))) (DEFVAR INLINE-DECLARATIONS NIL)  ; local INLINE and NOTINLINE declarations    ; a list of entries of the form (fname . inline) or (fname . notinline);;; ---  State variables used in compiling a file or buffer  ---    (DEFVAR QC-FILE-IN-PROGRESS NIL "T while inside COMPILE-STREAM.") (DEFVAR QC-FILE-READ-IN-PROGRESS NIL  "T while inside READ within COMPILE-STREAM.")(DEFVAR QC-FILE-LOAD-FLAG :UNBOUND   "True when the results of compilation are being immediately installed in memoryinstead of just written to a file.") (DEFVAR QC-FILE-RECORD-MACROS-EXPANDED NIL   "T if within QC-FILE; tells compiler to record macros expanded on QC-FILE-MACROS-EXPANDED.") (DEFVAR QC-FILE-MACROS-EXPANDED :UNBOUND   "Within QC-FILE, a list of all macros expanded.The elements are macro names or lists (macro-name sxhash).") (DEFVAR QC-FILE-CHECK-INDENTATION T   "T => check the indentation of input expressions to detect missing closeparens.This assumes that only top-level forms begin with a \"(\" in the first columnunless surrounded by a form with the SI:MAY-SURROUND-DEFUN property.") ;;; Queue of functions to be compiled.;;; Any internal lambdas are put on the queue;;; so that they get compiled after the containing function.(DEFVAR COMPILER-QUEUE NIL   "List of pending functions to be compiled inside QC-TRANSLATE-FUNCTION.Each element is a COMPILER-QUEUE-ENTRY.") #+compiler:debug(DEFCONSTANT *COMPILE-DRIVER-MACROS* NIL) ; temporary until everything recompiled.(DEFMACRO WITH-COMPILE-DRIVER-BINDINGS (&BODY BODY)  ;; Initialize special variables used by PRE-OPTIMIZE within COMPILE-DRIVER.  ;;  8/08/86 - Original.  ;;  8/13/86 - Removed use of *COMPILE-DRIVER-MACROS*.  ;;  8/15/86 - Move binding of P1VALUE to COMPILE-DRIVER.  ;;  3/07/87 - Bind VARS.  `(LET ((MACROS-EXPANDED NIL) (LOCAL-FUNCTIONS NIL) (*LOCAL-ENVIRONMENT* NIL) (COMPILING-COMMON-LISP (COMMON-LISP-ON-P)) (*CURRENT-COMPILAND* NIL) (VARS NIL) ; referenced by TYPE-PREDICATE-STYLE and AND-OR-STYLE )     . ,BODY));;; Special variable bindings do not get un-done when the machine crashes and ;;; is warm-booted.  Therefore, the following function is run at warm boot time ;;; to reset some critical status variables used by the compiler.(ADD-INITIALIZATION "Compiler warm boot" '(COMPILER-WARM-BOOT) '(:WARM)) (DEFUN COMPILER-WARM-BOOT ()  ;;  5/28/86 DNG - Reset ERROR-MESSAGE-HOOK; merge function QC-FILE-RESET into  ;;this one; don't reset TARGET-PROCESSOR when constant.  ;;  6/30/86 DNG - Reset SI:FILE-IN-COLD-LOAD to NIL.  ;;  7/09/86 DNG - Reset 1-IF-LIVE-CODE to 1.  ;;  8/08/86 DNG - Reset QC-FILE-RECORD-MACROS-EXPANDED to NIL.  ;;  8/09/86 DNG - Reset COMPILER-QUEUE instead of INSIDE-QC-TRANSLATE-FUNCTION.  ;;  9/19/86 DNG - Reset DONT-PROPAGATE-INTO-LOOP.  ;;  9/24/86 DNG - Reset *OVERLAP-CANDIDATES*.  ;;  9/26/86 DNG - Reset WARN-CATCHER.  ;; 10/06/86 DNG - Reset FASD-TARGET.  ;; 10/08/86 DNG - Call SI:WARNINGS-WARM-BOOT .  (DEALLOCATE-WHOLE-RESOURCE 'COMPILER-TEMPS-RESOURCE)  (SETQ QCOMPILE-TEMPORARY-AREA NIL)  (SETQ COMPILER-QUEUE NIL)  (SETQ COMPILER-WARNINGS-CONTEXT NIL)  (SETQ ERROR-MESSAGE-HOOK NIL)  (SETQ SI:FILE-IN-COLD-LOAD NIL)  (LOCALLY (DECLARE (SPECIAL 1-IF-LIVE-CODE DONT-PROPAGATE-INTO-LOOP *OVERLAP-CANDIDATES*)) ; declared in P1DEFS    (SETQ 1-IF-LIVE-CODE 1)    (SETQ DONT-PROPAGATE-INTO-LOOP 0)    (SETQ *OVERLAP-CANDIDATES* T))  (SETQ WARN-CATCHER NIL)  ;; The following used to be in function QC-FILE-RESET.  (SETQ QC-FILE-IN-PROGRESS NIL)  (SETQ UNDO-DECLARATIONS-FLAG NIL)  (SETQ QC-FILE-READ-IN-PROGRESS NIL)  (SETQ LOCAL-DECLARATIONS NIL)  (SETQ FILE-SPECIAL-LIST NILFILE-UNSPECIAL-LIST NIL)  (SETQ FILE-CONSTANTS-LIST NIL)  (SETQ INLINE-DECLARATIONS NIL)  (SETQ FILE-LOCAL-DECLARATIONS NIL)  (SETQ OPTIMIZE-SWITCH (MAKE-OPTIMIZE-SWITCHES))  #.(UNLESS (GET-FOR-TARGET 'TARGET-PROCESSOR 'SYSTEM-CONSTANT)      '(SETQ TARGET-PROCESSOR HOST-PROCESSOR) )  #+compiler:debug  (SETQ *DEFAULT-DEFS-FROM-HOST* T*BARF-DEFAULTS* NIL)  ;; -- end of old QC-FILE-RESET  (SETQ QC-FILE-RECORD-MACROS-EXPANDED NIL)  (SET 'FASD-TARGET HOST-PROCESSOR)  (WHEN (FBOUNDP 'SI:WARNINGS-WARM-BOOT)    (SI:WARNINGS-WARM-BOOT))  NIL   );Inside WARN-ON-ERRORS, this is bound to the TYPE arg to pass to WARN;when an error happens.(DEFVAR ERROR-WARNING-TYPE :UNBOUND "Holds the WARNING-TYPE arg inside a WARN-ON-ERRORS.") ;This is a list of a format-string and some args, whose purpose is;to describe the context in which an error generated a warning.;For example, it might be ("Error expanding macro ~S" LOSING-MACRO).(DEFVAR ERROR-WARNING-ARGS NIL   "Holds the WARNING-FORMAT-STRING and WARNING-ARGS args inside a WARN-ON-ERRORS.") ;T to enable the WARN-ON-ERRORS feature.(DEFVAR WARN-ON-ERRORS T   "Set true for the compiler to write warning messages instead of entering the debuggerwhen errors occur in reading, macro expansion, or constant folding.Set to NIL if you want to use the debugger to examine such an error.") (DEFVAR WARN-ON-ERRORS-STREAM NIL "Non-NIL => this is stream that read errors are happening on.") ;Use this macro to turn errors into compiler warnings.;Used around reading, macroexpanding, etc.(DEFMACRO WARN-ON-ERRORS ((WARNING-TYPE WARNING-FORMAT-STRING . WARNING-ARGS) &BODY BODY)  "Execute the body, arranging to make a warning if any error happens.WARNING-TYPE, WARNING-FORMAT-STRING and WARNING-ARGSare used to create those warnings, together with the error message."  ;; 10/09/86 DNG - Catch condition CLI:ERROR instead of ZLC:ERROR.  `(CATCH 'WARN-ON-ERRORS     (CONDITION-RESUME-IF T   '(ERROR WARN-ON-ERRORS T ("Continue with compilation.")   (LAMBDA (&REST IGNORE)     (THROW 'WARN-ON-ERRORS NIL)))       (LET ((ERROR-WARNING-TYPE ,WARNING-TYPE)     (ERROR-WARNING-ARGS (LIST ,WARNING-FORMAT-STRING ,@WARNING-ARGS))) (CONDITION-BIND ((ERROR 'WARN-ON-ERRORS-CONDITION-HANDLER))   ,@BODY))))) (DEFUN WARN-ON-ERRORS-CONDITION-HANDLER (CONDITION)  ;;  4/26/85 DNG - Add message telling how to disable indentation checking to  ;;   help people porting un-indented code from brand S.  ;;  6/30/86 DNG - Modified to be able to load before the ZWEI package exists.  ;;  8/09/86 DNG - Use new operation :MARK-ERROR-POSITION.  ;;  9/19/86 DNG - When compiling in a buffer, let undefined package go into  ;;error handler.  [SPR 2004 and 2132]  ;;  9/25/86 DNG - Bind *PRINT-LENGTH* and *PRINT-LEVEL* .  ;;  9/26/86 DNG - Remove redundant "Warning:" message; add check of WARN-CATCHER.  (WHEN WARN-CATCHER    ;; Warn is going to throw when it is called, so do it now to avoid    ;; writing an incomplete error message.    (THROW WARN-CATCHER 'ERROR))  (LET* ((CONDITION-NAMES (SEND CONDITION :CONDITION-NAMES)) (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) (*PRINT-LENGTH* 5) (*PRINT-LEVEL* 3))    (IF SI:OBJECT-WARNINGS-OBJECT-NAME(PROGN (SI:MAYBE-PRINT-OBJECT-WARNINGS-HEADER)       (FORMAT T "~%")       (APPLY #'FORMAT T ERROR-WARNING-ARGS))      (PRINT-ERROR-WARNING-HEADER))    (UNLESS EH:ERRSET-STATUS      (COND((AND (MEMBER 'PACKAGE-NOT-FOUND CONDITION-NAMES :TEST #'EQ)      (SEND CONDITION :PROCEED-TYPE-P :NO-ACTION)      QC-FILE-IN-PROGRESS      QC-FILE-LOAD-FLAG) ;; When compiling in a buffer, let undefined package go into error handler. NIL)((AND (MEMBER 'PARSE-ERROR CONDITION-NAMES :TEST #'EQ)      (SEND CONDITION :PROCEED-TYPE-P :NO-ACTION)) (WARN 'READ-ERROR :ERROR "~A" (SEND CONDITION :REPORT-STRING)) #+Elroy (UNLESS (NULL WARN-ON-ERRORS-STREAM)   ;; save position in ZMACS register "."   (SEND WARN-ON-ERRORS-STREAM :SEND-IF-HANDLES :MARK-ERROR-POSITION)) #-Elroy (LET (BP REG)   (WHEN WARN-ON-ERRORS-STREAM     (SETQ BP (SEND WARN-ON-ERRORS-STREAM :SEND-IF-HANDLES :READ-BP)))   (AND BP(SETQ REG (ZWEI:MAKE-REGISTER-NAME #\.))(NOT (GET REG 'ZWEI:POINT))(PROGN  (FORMAT T "~&~%Position of this error saved in ZWEI register \".\".~@     ~5TIn Zmacs use Control-X J, Then enter \".\" to get there.~%")  (ZWEI:SAVE-POSITION-IN-REGISTER REG BP)))) (WHEN (AND (MEMBER 'MISSING-CLOSEPAREN CONDITION-NAMES :TEST #'EQ)    QC-FILE-CHECK-INDENTATION)   (FORMAT T "~&~%If you are not following the convention that only top-level formsbegin with a \"(\" in the first column, you can suppress thiserror by setting variable ~S to NIL.~%" 'QC-FILE-CHECK-INDENTATION)) :NO-ACTION)(T (RECORD-WARNING NIL :ERROR NIL "~A" (APPLY #'FORMAT NIL ERROR-WARNING-ARGS)) ;; Make a string now, in case the condition object points at data ;; that is in a temporary area. (WARN ERROR-WARNING-TYPE :ERROR "~A" (SEND CONDITION :REPORT-STRING)) (WHEN (AND WARN-ON-ERRORS    (NOT (MEMBER 'PDL-OVERFLOW CONDITION-NAMES :TEST #'EQ))    (NOT (SEND CONDITION :DANGEROUS-CONDITION-P))    (NOT (SEND CONDITION :DEBUGGING-CONDITION-P)))   (FORMAT T "~&TO DEBUG THIS, recompile with ~S set to NIL." 'WARN-ON-ERRORS)   'WARN-ON-ERRORS)))))) (DEFUN PRINT-ERROR-WARNING-HEADER ()  ;;  9/25/86 DNG - Limit the amount printed.  (LET ((*PRINT-LENGTH* 4) (*PRINT-LEVEL* 2))    (FORMAT T "~%<< ~A >>" (APPLY #'FORMAT NIL ERROR-WARNING-ARGS))))(DEFSTRUCT (COMPILAND (:ALTERANT NIL) (:PREDICATE NIL) (:COPIER NIL) )  "Describes a single function which is being compiled."  ;;  7/09/86 - Original version, replacing COMPILER-QUEUE-ENTRY.  ;; 10/01/86 - Field BREAKOFF-COUNT replaced with CHILDREN.  ;; Description of the function to be compiled:  (FUNCTION-SPEC NIL :DOCUMENTATION "Function spec to define once compilation is done.")  (FUNCTION-NAME NIL :DOCUMENTATION"Function spec to record in the FEF as its name.")  (DEFINITIONNIL :TYPE LIST :DOCUMENTATION "Lambda expression to compile.")  ;; The lexical environment of the function:  (PARENTNIL ; :TYPE (OR COMPILAND NULL):DOCUMENTATION "Lexical parent function.")  (DECLARATIONSNIL :TYPE LIST :DOCUMENTATION"Declarations in effect from containing function.")  (INHERITED-VARS NIL :TYPE LIST :DOCUMENTATION"List of variables [as VAR structures] accessible through containing function.")  (INHERITED-GOTAGSNIL :TYPE LIST)  (INHERITED-PROGDESCSNIL :TYPE LIST)  (INHERITED-RETPROGDESC NIL :TYPE (OR PROGDESC NULL))  (INHERITED-LOCAL-FUNCTIONS NIL :TYPE LIST)  (INHERITED-LOCAL-MACROS NIL :TYPE LIST)  (NESTING-LEVEL 0 :TYPE (UNSIGNED-BYTE 12.))  ;; Data filled in as the function is compiled:  (ARGLISTNIL :TYPE LIST :DOCUMENTATION "The argument list with any &AUX vars removed.")  (FLAVORNIL :TYPE LIST :DOCUMENTATION "Flavor name and instance variables.")  (SELF-MAP-NEEDED NIL :TYPE SYMBOL)  (OPTIMIZEOPTIMIZE-SWITCH :TYPE OPTIMIZE-SWITCHES)  (EXP2NIL :TYPE LIST :DOCUMENTATION"Function body expression after processing by pass 1.")  (LL2NIL :TYPE LIST :DOCUMENTATION"Function lambda-list for pass 2.")  (ARG-VARSNIL :TYPE LIST) ; VARS for P2SBIND of function arguments  (CHILDRENNIL :TYPE LIST :DOCUMENTATION "List of breakoff function compilands")  (VARIABLES-USED-IN-LEXICAL-CLOSURES NIL :TYPE LIST)  (MAX-LEXICAL-CLOSURE-COUNT 0 :TYPE FIXNUM)  (ALLVARSNIL :TYPE LIST)  (FREEVARSNIL :TYPE LIST)  (USED-VAR-SET    0 :TYPE INTEGER)  (ALTERED-VAR-SET 0 :TYPE INTEGER)  (LOCAL-MAPNIL :TYPE LIST)  (ARG-MAPNIL :TYPE LIST)  (LOCAL-FUNCTION-MAP NIL :TYPE LIST)  (LLOCBLOCK0 :TYPE FIXNUM :DOCUMENTATION "Length of local variable block.")  (EXPRESSION-SIZE 0 :TYPE FIXNUM)  (PLISTNIL :TYPE LIST) ; miscellaneous flags  (DEBUG-INFONIL :TYPE (OR SI:DEBUG-INFO-STRUCT LIST); At the end of pass 1, this contains an A-list of declarations which; are to be included in the debug info.  Pass 2 constructs the; actual debug-info structure and stores it here.     )  (DOCUMENTATION NIL :TYPE (OR NULL STRING))  (MACROS-EXPANDED NIL :TYPE LIST)  (USE-COUNT 1 :TYPE FIXNUM)  )(DEFSUBST COMPILAND-MACRO-FLAG   (X) (GETF (COMPILAND-PLIST X) 'MACRO))(DEFSUBST COMPILAND-SUBST-FLAG   (X) (GETF (COMPILAND-PLIST X) 'SUBST))(DEFSUBST COMPILAND-SPECIAL-FLAG (X)  "T means the function has bound a special variable.This information goes into the FEF."  (GETF (COMPILAND-PLIST X) 'SPECIAL))(DEFSUBST COMPILAND-LEXICAL-CLOSURE-FLAG (X) (GETF (COMPILAND-PLIST X) 'LEXICAL-CLOSURE))(DEFSUBST COMPILAND-INITIAL-ENVIRONMENT-VARS (COMPILAND)  ;; Variables which have been initialized before the first lexical closure is  ;; created.  Since all the closures made by the current FEF share the same  ;; environment, which is created at the time the first lexical closure is  ;; made, only variables in this list are eligible to have their values copied  ;; out to the environment instead of using an indirect pointer.  ;; Set in BREAKOFF and (:PROPERTY %LABELS P1); tested in PASS2.  ;;  2/13/87 - Original.  (GETF (COMPILAND-PLIST COMPILAND) 'COMPILAND-INITIAL-ENVIRONMENT-VARS))(DEFVAR *CURRENT-COMPILAND* :UNBOUND "The function currently being compiled.")(PROCLAIM '(TYPE COMPILAND *CURRENT-COMPILAND*)) #-compiler:debug(PROCLAIM '(INLINE TOP-LEVEL-DUMMY-FUNCTION-P))(DEFUN TOP-LEVEL-DUMMY-FUNCTION-P (&OPTIONAL (COMPILAND *CURRENT-COMPILAND*))  ;; Returns true for a dummy function created by COMPILE-TOP-LEVEL-FORM.  (OR (NULL COMPILAND)      (NULL (COMPILAND-FUNCTION-SPEC COMPILAND)) ));;; Variables data bases:;Bound (local or special) variables are described by two lists of variable descriptors:;VARS, which describes only variables visible from the current point of compilation,;and ALLVARS, which describes all variables seen so far in the current compilation.(DEFVAR VARS) ;ALLVARS is passed to lap to allocate slots, while VARS is used on both passes;for figuring out what to do with a variable.(DEFVAR ALLVARS) ;In addition, FREEVARS is a list of all special variables referred to free.(DEFVAR FREEVARS) ;ARG-MAP and LOCAL-MAP are given the arg map and local map for the debugging info.;This is done by ASSIGN-LAP-ADDRESSES, so that special vars that get a slot;can be put in the map even though their places in it will not be recogizable;from their lap addresses.(DEFVAR ARG-MAP) (DEFVAR LOCAL-MAP) (DEFVAR LOCAL-FUNCTION-MAP) ;Each element of VARS or ALLVARS describes one variable, and is called a VAR or a "home". ;VARS can also contain elements that represent local SPECIAL declarations;and do not mean that any binding has taken place.  These have FEF-ARG-FREE as the KIND,;FEF-SPECIAL as the TYPE, and the variable as the LAP-ADDRESS. ;A VAR has these components: (DEFSTRUCT (VAR (:CONC-NAME VAR-) (:CALLABLE-CONSTRUCTORS NIL)(:ALTERANT NIL) (:PREDICATE NIL)(:COPIER NIL) (:TYPE :LIST))  ;;The variable's name.  ;;If this is the gensym variable that is used to implement  ;;a local (FLET) function, then the name has a LOCAL-FUNCTION-NAME property  ;;which is the symbol actually defined as a function in the FLET.  NAME  ;;The KIND is one of  ;; (FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-KEY FEF-ARG-REST FEF-ARG-AUX FEF-ARG-INTERNAL-AUX)  ;;KIND can also be FEF-ARG-FREE  ;;for the entry pushed by a local SPECIAL declaration.  KIND  ;;The TYPE is either FEF-LOCAL or FEF-SPECIAL.  TYPE  ;;Number of times variable is used, not counting binding and initialization.  ;;A value of NIL means the variable never appears, while a value of 0 means it  ;;appears in the source but the value is not actually used.  (USE-COUNT NIL)  ;;(ARG n) for an argument, (LOCAL n) for a local, (SPECIAL symbol) for a special variable.  LAP-ADDRESS  ;;Describes how the variable should be initted on binding.  ;;See below for how to interpret this field.  INIT  ;;FEF-QT-QT for &QUOTE arg, otherwise FEF-QT-EVAL.  EVAL  ;;List of additional FEF-... symbols serving as flags about this variable.  ;;FEF-ARG-FUNCTIONAL means it is an &FUNCTIONAL arg.  ;;FEF-ARG-SPECIFIED-FLAG means it is the specified-p variable of an optional arg.  ;;FEF-ARG-USED-IN-LEXICAL-CLOSURES means that lexical closures refer free to this variable.  ;;FEF-ARG-NOT-ALTERED means there are no assignments to the variable after its initial binding.  ;;Lap will add the values of these symbols into the ADL word for the variable.  MISC  ;;Declarations pertaining to this variable.  DECLARATIONS  ;;Another VAR, the one whose slot this one shares;; or NIL if there is none.  OVERLAP-VAR  ;;The function this variable belongs to.  (COMPILAND *CURRENT-COMPILAND* :TYPE COMPILAND)  ) (DEFSUBST LOOKUP-VAR (NAME &OPTIONAL (VAR-TABLE VARS))  "Return the structure describing the variable named by the symbol NAMEor NIL if no such variable is in the table."  ;;  1/31/86 - Original version.  (ASSOC NAME VAR-TABLE :TEST #'EQ)) #-Elroy ; ADL values - not used in release 3(progn(DEFPARAMETER FEF-ARG-KEY FEF-ARG-AUX)(DEFPARAMETER FEF-ARG-SPECIFIED-FLAG 0) (DEFPARAMETER FEF-ARG-USED-IN-LEXICAL-CLOSURES 0))        ;The INIT is of the form ( <type> <data> . <arg-supplied-flag home>);The arg-supplied-flag name is the home of FOOP in &OPTIONAL (FOO NIL FOOP).;It appears only for optional arguments which have such a flag.;If there is none, the cddr of INIT will be nil.;The type is of of several symbols starting with "FEF-INI-", that;signify one of the ways of initializing the variable.;FEF-INI-COMP-C indicates that compiled code will be used to;do the initialization.  It is the most general.  The other types;exist to make special cases more efficient.  They are:;FEF-INI-NONENo initialization (for a local variable which should be nil).;FEF-INI-SELFInitialize to self (for special variable).;FEF-INI-NILInitialize to NIL (for special variable).;FEF-INI-PNTRInitialize to a constant.  <data> is that constant.;FEF-INI-C-PNTRInitialize to the contents of a location.  <data> points to it.;FEF-INI-EFF-ADRInitialize to the contents of an "effective address".;This is used to copy the value of a previous arg or local variable.;<data> specifies which one, using an instruction source field;which will specify the arg block or the local block, plus offset.;FEF-INI-OPT-SAFor an optional variable with a complicated default value.;<data> specifies a starting address inside the function;which is where to start if the argument IS supplied.;It follows the code used to compute and store the default value.;FEF-INI-COMP-CIndicates that the variable will be initialized by the;compiled code of the function.;;;- IN GENERAL -;;;INTERNAL VARIABLES ARE BOUND BY INTERNAL LAMBDA'S AND PROGS;;;OTHERS ARE BOUND AT ENTRY TIME;;;ALL INTERNAL VARIABLES ARE INITIALIZED BY CODE;;;ARG VARIABLES ARE NEVER INITIALIZED;;;OPTIONAL AND AUX VARIABLES ARE INITIALIZED AT BIND TIME;;;IF POSSIBLE OTHERWISE BY CODE;;;THIS "POSSIBILITY" IS DETERMINED AS FOLLOWS:;;;INITIALLY, IT IS POSSIBLE;;;IT REMAINS POSSIBLE UNTIL YOU COME TO A VARIABLE;;;INITIALIZED TO A FCTN, AT WHICH POINT IT IS NO LONGER POSSIBLE;;;IF VAR TO BE INITIALIZED BY CODE, CODE 0 (SPECIAL) OR;;;1 (LOCAL) IS USED IN INITIALIZATION FLD#+Grind(DEFUN (:PROPERTY LOCAL-REF SI:GRIND-MACRO) (EXP LOC &OPTIONAL GRINDER)  ;; Grinder handler for local variable references in intermediate Lisp code  ;; within the compiler.  This is to prevent endless recursion when displaying  ;; compiler data with the debugger.  (DECLARE (IGNORE GRINDER))  (LET ((A EXP) B)    (IF (AND (CONSP A) (EQ (FIRST A) 'LOCAL-REF) (CONSP (SETQ B (SECOND A))) (REST2 B))(SI::GRIND-STANDARD-FORM `(LOCAL-REF (,(FIRST B) *** ,@(CDDR A))) LOC)      (SI::GRIND-STANDARD-FORM EXP LOC)))) ;GO tag data base.;The variable GOTAGS contains an alist describing all the tags;of TAGBODYs the code we are currently compiling is contained in.;Each element of GOTAGS is a GOTAG, as defined below.;In addition, each BLOCK puts one GOTAG on the list.;That is the block's rettag, which we jump to to return from the block.(DEFVAR GOTAGS) ;ALLGOTAGS is a list of all prog-tags defined so far in the current function,;whether the progs defining them contain the current one or not.;The elements are atoms (the actual tags).;This list is not inherited from the lexically containing function.;ALLGOTAGS is used to determine when the lap-tag of a new tag must be different;from the user-specified prog-tag.(DEFVAR ALLGOTAGS) (DEFSTRUCT (GOTAG  (:TYPE :LIST) (:CONC-NAME GOTAG-)   (:CONSTRUCTOR NIL) (:CALLABLE-CONSTRUCTORS NIL)   (:ALTERANT NIL) (:PREDICATE NIL) (:COPIER NIL))  ;; Actual tag name that the user used.  ;; For rettags of blocks, it's a gensym.  PROG-TAG  ;; Tag name to use for LAP.  May be the same.  LAP-TAG  ;; Pdl level we are supposed to have at that point in the code.  ;; Used to tell how many words to pop when you branch.  PDL-LEVEL  ;; Pointer to the element of PROGDESCS for the BLOCK or TAGBODY that generated this GOTAG.  PROGDESC  ;; T if this tag used in internal lambdas.  ;; The PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG of our GOTAG-PROGDESC  ;; will also be non-NIL in that case.  USED-IN-LEXICAL-CLOSURES-FLAG  ;; Nuber of times the tag is referenced.  USE-COUNT) (DEFMACRO MAKE-GOTAG (&OPTIONAL PROG-TAG LAP-TAG PDL-LEVEL PROGDESC)  `(LIST ,PROG-TAG ,LAP-TAG ,PDL-LEVEL ,PROGDESC NIL 0)) (DEFVAR PROGDESCS :UNBOUND   "The elements describe the active BLOCK, LET and TAGBODY constructs, innermost first.Each element is a PROGDESC structure.") (DEFSTRUCT (PROGDESC (:TYPE :LIST) ; so ASSQ can be used for lookup     (:CONC-NAME PROGDESC-)     (:CALLABLE-CONSTRUCTORS NIL) (:ALTERANT NIL)     (:PREDICATE NIL) (:COPIER NIL) )  "Describes one element of PROGDESCS."  ;;  7/09/86 - New fields USED-BIT and COMPILAND replace ENTRY-LEXICAL-CLOSURE-COUNT  ;;and EXIT-LEXICAL-CLOSURE-COUNT.  ;;  9/16/86 - New field CATCH-TAG.  (NAME NIL :DOCUMENTATION"Name of this block, or (TAGBODY) or (LET).\(TAGBODY) is used for PROGDESCs for TAGBODY forms,\(LET) is used for PROGDESCs for variable binding forms,a symbol is used for BLOCKs.")  (RETTAG NIL :DOCUMENTATION  "Tag to branch to to exit this construct.  Used for blocks only.The rettag is followed, if necessary, by code to transfer theblock's value from its IDEST to the actual destination.")  (IDEST NIL :DOCUMENTATION "Destination to compile contents of block with, on pass 2.Used for blocks only.");;  holds saved value of P1VALUE during pass 1.  (M-V-TARGET NIL :DOCUMENTATION      "Value of M-V-TARGET around this block.Says whether the block's caller wants multiple values.  Used for blocks only.If it is NIL, only one value is wanted.If it is MULTIPLE-VALUE-LIST, then the block should reallyreturn the list of the values that RETURN wants to return.If it is THROW or RETURN, the block should do the hairy thingsto pass all but the last value to the frame that is going to get them,then return the last value on the stack.If it is a number, the block should return that many values on the stack.")  (PDL-LEVEL NIL :DOCUMENTATION     "The <pdl-level> is the pdl level at entry to the construct,which is also the level in between statements in the construct.Used in all PROGDESCs, for blocks, binding forms and TAGBODYs.")  (NBINDS NIL :DOCUMENTATION  "Number of special bindings to unbind at exit from the construct.Can also be a list containing the number to unbind, which meansthat in addition an unknown number of BINDs will be doneand therefore UNBIND-TO-INDEX must be used to unbind themto a specpdl pointer saved at the beginning of the construct.")  (VARS NIL :DOCUMENTATION "Value of VARS at entry to this block.")  (USED-BIT 0 :DOCUMENTATION "Bit mask to be or-ed into ALTERED-VAR-SET on reference to this block.")  (COMPILAND *CURRENT-COMPILAND*) ; the function this block belongs to  (USED-IN-LEXICAL-CLOSURES-FLAG NIL :DOCUMENTATION    "For blocks, non-NIL if any lexical closure within this block tries to RETURN from it.The actual value is a list of referencing compilands.")  (CATCH-TAG NIL :TYPE SYMBOL :DOCUMENTATION    "For blocks, a variable whose value is the CATCH tag for a non-local return.")  (UNDO-PDL-LEVEL NIL :DOCUMENTATION    "The <undo-pdl-level> is the pdl level at entry to the undo forms of an UNWIND-PROTECT.")  ) (DEFVAR RETPROGDESC :UNBOUND   "PROGDESC element for the block that plain RETURN should return from, or NIL if none.") ;;; ----------(DEFSTRUCT (EXPR (:TYPE LIST) (:CONC-NAME NIL) (:CALLABLE-CONSTRUCTORS NIL) (:ALTERANT NIL) (:PREDICATE NIL) (:COPIER NIL))  ;; Annotated expression created by P1-WITH-ANNOTATION.  See the  ;; comments there for more details.  ;;(THE-EXPR <form> <used> <altered> <optimize> <type>)  ;; 1/23/85 - Original version.  ;; 3/10/86 - Include field EXPR-TYPE.  ;;10/11/86 - Add field EXPR-DEST.  (EXPR-OP 'THE-EXPR)  EXPR-FORM       ; The result of applying P1 to the source form.  EXPR-USED       ; The set of local variables whose values are referenced in the form.  EXPR-ALTERED       ; The set of local variables whose values are altered in the form.  EXPR-OPTIMIZE       ; Holds the local value of the optimization switches.  (EXPR-TYPE 'UNKNOWN) ; Type specifier of the data type of the value of form.  (EXPR-DEST P1VALUE)  )(DEFVAR LOCAL-FUNCTIONS :UNBOUND   "Alist of elements (local-function-name vars-entry function-definition)It records, for each local function name (defined by FLET or LABELS)the local variable in which the function definition actually lives.")   ;;  6/21/86 - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.(DEFVAR *LOCAL-ENVIRONMENT* NIL  "Environment for MACROEXPAND to use during compilation.This contains the definitions of local macros defined by MACROLET.Local functions that are not macros have NIL recorded as their definitions.Such local functions are present only to record that they shadowmore global definitions of the same function names.");;;   --- Variables used in writing binary object files  ---;;;;;;   These used to be in file QCFASD but were moved here because they;;;   are referenced in files FILE and LAP.(DEFVAR FASD-TABLE-CURRENT-INDEX NIL "Allocating index for runtime fasl table") (DEFVAR FASD-HASH-TABLE NIL "FASD time hash table") (DEFVAR FASD-EVAL-HASH-TABLE NIL "FASD time hash table for self ref pointers") (DEFVAR FASD-TYO-BUFFER-ARRAY(MAKE-ARRAY 512. :ELEMENT-TYPE '(UNSIGNED-BYTE 16.) :LEADER-LENGTH 1)) (DEFVAR FASD-STREAM) (DEFVAR FASD-PACKAGE) ;The package in which the fasl file will presumably be loaded(SETF (GET EVAL-AT-LOAD-TIME-MARKER 'OPTIMIZERS)      '(EXECUTION-CONTEXT-EVAL-WARNING)) (DEFUN EXECUTION-CONTEXT-EVAL-WARNING (FORM)  (WARN 'LOAD-TIME-EVAL :IMPOSSIBLE "Load-time eval (#,~S) not inside quoted structure"(CDR FORM))  (EVAL-FOR-TARGET (CDR FORM)));If this uninterned symbol is seen as the car of a list, the cadr of the;list is a compiland structure which will be compiled.(DEFVAR BREAKOFF-FUNCTION-MARKER (COPY-SYMBOL 'BREAKOFF-FUNCTION-MARKER NIL));This is an a-list of special markers that may exist in the car of a cons;and the function to fasdump such conses.  A typical thing for such a;a function to do is to call FASD-EVAL1 on some suitable form.(DEFPARAMETER FASD-MARKERS-ALIST   (LIST (CONS EVAL-AT-LOAD-TIME-MARKER 'FASD-EVAL-AT-LOAD-TIME) (CONS BREAKOFF-FUNCTION-MARKER 'FASD-BREAKOFF-FUNCTION)));This is an a-list of area numbers and functions to fasdump conses in that;area.  The function is treated just as for fasd-markers.(DEFVAR FASD-MAGIC-AREAS-ALIST NIL)  V PARENT-ALLVARS))(SETF (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES PARENT)      USED-IN-LEX))      (DOLIST (V OVERLAPPED-ALLVARS)(LET ((OVERLAPS (VAR-OVERLAP-VAR V)))  (IF (EQ (VAR-COMPILAND OVERLAPS) CHILD)      (PUSH V CHILD-ALLVARS)    (IF (MEMBER OVERLAPS PHANTOM-VARS :TEST #'EQ)(SETF (VAR-LAP-ADDRESS V) (VAR-LAP-ADDRESS OVERLAPS))      (PUSH V PARENT-ALLVARS)))))      (SETF (COMPILAND-FREEVARS CHILD) (COMPILAND-FREEVARS PARENT))      (SETF (COMPILAND-ALLVARS CHILD)    (NCONC CHILD-ALLVARS SPECIAL-VARS (COMP