LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030320. :SYSTEM-TYPE :LOGICAL :VERSION 15. :TYPE "LISP" :NAME "COMPILE" :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 2758302284. :AUTHOR "REL3" :LENGTH-IN-BYTES 80381. :LENGTH-IN-BLOCKS 79. :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 top level of the compiler for     |;;;;   |  compiling each function.  [Higher level routines for     |;;;;   |  compiling files and streams are in "COMPILER;FILE".]   |;;;;   *-----------------------------------------------------------*;;;  5/01/85 DNG - Last change for Explorer release 1.0.;;;  6/26/85 DNG - Minor modifications to improve speed of compilation.;;;  7/11/85 DNG - Allow re-using the stack space of lexical closures.;;;  7/13/85 DNG - For release 3, this file separated out of QCP1.;;; 11/16/85 DNG - Generate new debug-info structure for release 3.;;; 12/19/85 DNG - Fix :INTERNAL-FEF-OFFSETS in rel 3 debug info.;;;  4/05/86 DNG - Converted from Zetalisp to Common Lisp.;;;  8/08/86 DNG - Major redesign.;;;  9/30/86 DNG - Change CLI:NAMED-LAMBDA to NAMED-LAMBDA because it needs to;;;be in the TICL package instead of LISP.;;; 10/01/86 DNG - COMPILAND-BREAKOFF-COUNT replaced by COMPILAND-CHILDREN.;;; 10/18/86 DNG - Allow functions with more than 64 local variables.;;; 12/22/86 DNG - Updates to EXTEND-LOCAL-VARIABLES and BREAKOFF .;;; 12/30/86 DNG - Fix UNCOMPILE.;;;  2/16/87 DNG - Set COMPILAND-INITIAL-ENVIRONMENT-VARS in BREAKOFF.;;;  2/18/87 DNG - Fix BUILD-DEBUG-INFO for the *SUPPRESS-DEBUG-INFO* option.;;;  3/07/87 DNG - Clear QCMP-OUTPUT array to facilitate GC.;;;  3/17/87 DNG - Fix BREAKOFF for ephemeral lexical closure criteria.;;;  4/09/87 DNG - Fix QCOMPILE2 for SPR 4751.;Initialize all global variables and compiler switches, and make sure;that some built in variables are known to be special;(logically, the cold load would contain SPECIAL properties for them,;but this function is how they actually get put on).;; 08/15/84 DNG - change value of SPECIAL property from T to the;;                name of this function for documentation purposes.;; 09/12/84 DNG - re-do properties if currently T so that P1 can distinguish;;                machine-dependent constants from DEFCONSTANT constants.;;                This is a temporary measure until the general problem ;;                of cross-compilation is resolved.;; 02/08/85 DNG - Removed initialization of SPECIAL and SYSTEM-CONSTANT;;                properties for system variables -- this is now done;;                by function INIT-SYSTEM-VAR-PROPERTIES in file QCDEFS.;; 09/23/85 DNG - Commented out initialization of some undefined variables.;; 05/28/86 DNG - Remove obsolete variable FUNCTION-BEING-PROCESSED.(DEFUN QC-PROCESS-INITIALIZE NIL  (SETQ HOLDPROG T)  (COMMENT "These don't seem to be used anymore"   (SETQ MC-HOLDPROG T)   (SETQ ULAP-DEBUG NIL)   (SETQ LAP-DEBUG NIL)   (SETQ MS-HOLDPROG T)   (SETQ MSLAP-DEBUG NIL) )  (SETQ OPEN-CODE-MAP-SWITCH T)  (SETQ ALLOW-VARIABLES-IN-FUNCTION-POSITION-SWITCH NIL)  (SETQ ALL-SPECIAL-SWITCH NIL)  (SETQ OBSOLETE-FUNCTION-WARNING-SWITCH T)  (SETQ RUN-IN-MACLISP-SWITCH NIL)  (SETQ INHIBIT-STYLE-WARNINGS-SWITCH NIL) );; Compile a function which already has an interpreted definition,;; or define it to a newly supplied definition's compilation.;; If the definition is one which is legal but cannot meaningfully;; be compiled, we just leave it unchanged.(DEFUN COMPILE (NAME &OPTIONAL LAMBDA-EXP #+compiler:debug target#+compiler:debug (mode 'compile-to-core))  "Compile the definition of NAME,or its previous interpreted definition if it is already compiled.If LAMBDA-EXP is supplied, it is compiled and made the definition of NAME.If NAME is NIL, LAMBDA-EXP is compiled and the result is just returned."  ;;  07/09/85 DNG - When passing a NAMED-LAMBDA to COMPILE-LAMBDA,  ;;                 use the name of the NAMED-LAMBDA as the FEF name.  ;;  11/02/85 DNG - Simplify by using FDEFINITION-SAFE and INTERPRETED-DEF.  ;;   3/31/86 DNG - Bind TARGET-PROCESSOR for PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED.  (DECLARE (VALUES NAME ERROR-STATUS))  (IF (NULL NAME)      (COMPILE-LAMBDA LAMBDA-EXP      (MULTIPLE-VALUE-BIND ( LAMBDA-NAME NAMEDP )  (FUNCTION-NAME LAMBDA-EXP)(IF NAMEDP LAMBDA-NAME (GENSYM)) ) )   (LET (( *RETURN-STATUS* OK ))    (LOCKING-RESOURCES-NO-QFASL      (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE);; need to bind TARGET-PROCESSOR here for PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED.       (let-unless-constant ( #+compiler:debug ( target-processor (validate-target target) ))  #+compiler:debug target        (COMPILER-WARNINGS-CONTEXT-BIND          (LET (TEM FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST FILE-LOCAL-DECLARATIONS)            (QC-PROCESS-INITIALIZE)            (COND (LAMBDA-EXP)                  ((AND (SETQ TEM (SI:FDEFINITION-SAFE NAME T))(SETQ TEM (INTERPRETED-DEF TEM)))   (SETQ LAMBDA-EXP TEM) )                  (T (FERROR NIL "Can't find LAMBDA expression for ~S" NAME)))            (LET ((INHIBIT-FDEFINE-WARNINGS T))              #-compiler:debug (COMPILE-1 NAME LAMBDA-EXP)      #+compiler:debug (COMPILE-1 NAME LAMBDA-EXP 'MACRO-COMPILE NAME  target-processor mode)      ))))))     (VALUES NAME *RETURN-STATUS*))))(DEFUN COMPILE-1 (NAME LAMBDA-EXP &OPTIONAL (PROCESSING-MODE 'MACRO-COMPILE)                  (NAME-FOR-FUNCTION NAME)  #+compiler:debug (TARGET HOST-PROCESSOR)  #-compiler:debug &AUX (LAP-MODE 'COMPILE-TO-CORE))  "Compile LAMBDA-EXP and define NAME, while already inside the compiler environment.NAME-FOR-FUNCTION is recorded as the name of the compiled function (the default is NAME).PROCESSING-MODE is how to compiler: COMPILER:MACRO-COMPILE or COMPILER:MICRO-COMPILE."  (DECLARE (UNSPECIAL LAP-MODE))  (SETQ LAMBDA-EXP (LAMBDA-MACRO-EXPAND LAMBDA-EXP))  (COND ((ATOM LAMBDA-EXP)         (FDEFINE NAME LAMBDA-EXP T))        ((OR (MEMBER (CAR LAMBDA-EXP)     '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA GLOBAL:SUBST GLOBAL:NAMED-SUBST       CLI:LAMBDA NAMED-LAMBDA CLI:SUBST NAMED-SUBST)     :TEST #'EQ)              (AND (EQ (CAR LAMBDA-EXP) 'MACRO)                  (CONSP (CDR LAMBDA-EXP))                  (MEMBER (CADR LAMBDA-EXP)  '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA    CLI:LAMBDA NAMED-LAMBDA)  :TEST #'EQ))) (LET-UNLESS-CONSTANT (( TARGET-PROCESSOR HOST-PROCESSOR )       #+compiler:debug ( HOLDPROG T )       ( FILE-CONSTANTS-LIST NIL ) )   #+compiler:debug target   #+compiler:debug   (when-supporting-cross-compilation     (unless (eq target host-processor)       (setq target-processor target)       (when (eq lap-mode 'compile-to-core) (setq holdprog nil))))   (record-individual-time 'qc-translate-function     (QC-TRANSLATE-FUNCTION NAME LAMBDA-EXP PROCESSING-MODE LAP-MODE    NAME-FOR-FUNCTION) ) ))        (T (FDEFINE NAME LAMBDA-EXP T))))(DEFUN COMPILE-LAMBDA (LAMBDA-EXP &OPTIONAL NAME (PROCESSING-MODE 'MACRO-COMPILE))  "Compile the function LAMBDA-EXP and return a compiled-function object.That compiled function will record NAME as its name,but we do not actually define NAME."  ;; 11/17/86 DNG - Suppress "while compiling end of data" message.  (DECLARE (ARGLIST LAMBDA-EXP &OPTIONAL NAME))  (DECLARE (VALUES COMPILED-FUNCTION ERROR-STATUS))  (LET ( TEM (*RETURN-STATUS* OK) )    (LOCKING-RESOURCES-NO-QFASL      (FILE-OPERATION-WITH-WARNINGS (T ':COMPILE)(COMPILER-WARNINGS-CONTEXT-BIND  (LET (FILE-SPECIAL-LIST FILE-UNSPECIAL-LIST FILE-LOCAL-DECLARATIONS(INHIBIT-FDEFINE-WARNINGS T))    (QC-PROCESS-INITIALIZE)    (COMPILE-1 `(:LOCATION ,(LOCF TEM)) LAMBDA-EXP PROCESSING-MODE NAME)    )  ;; "end of data" messages are not meaningful here, so suppress them.  (SETQ SI:PREMATURE-WARNINGS NIL))))    (VALUES TEM *RETURN-STATUS*)));; Restore the saved old interpreted definition of a function on which;; COMPILE was used.(DEFUN UNCOMPILE (FUNCTION-SPEC &OPTIONAL DONT-UNENCAPSULATE)  "Replaces compiled definition of FUNCTION-SPEC with interpreted definition.If the interpreted function which was compiled is known,installs that as the definition in place of the compiled one."  ;; 11/02/85 DNG - Use function INTERPRETED-DEF instead of looking at  ;;                debug-info directly.  ;; 12/30/86 DNG - Rewritten using COMPILEDP instead of INTERPRETED-DEF in  ;;order to avoid calling FDEFINE when the function was not  ;;compiled to begin with.  [SPR 2905]  (LET ((COMPILED (COMPILEDP FUNCTION-SPEC DONT-UNENCAPSULATE)))    (COND ((CONSP COMPILED)   (FDEFINE FUNCTION-SPEC COMPILED (NOT DONT-UNENCAPSULATE) T))  ((NULL COMPILED)   "Not compiled")  (T "No interpreted definition recorded"))))(EVAL-WHEN ( EVAL LISP:COMPILE LOAD )  (COMPILATION-DEFINE 'MICRO-COMPILE)) ; suppress "undefined function" warning on call below(DEFUN QC-TRANSLATE-FUNCTION (FUNCTION-SPEC EXP QC-TF-PROCESSING-MODE QC-TF-OUTPUT-MODE      &OPTIONAL (NAME-FOR-FUNCTION FUNCTION-SPEC) PASS-1-ONLY)  "Compile one function.  All styles of the compiler come through here.QC-TF-PROCESSING-MODE should be MACRO-COMPILE or MICRO-COMPILE.QC-TF-OUTPUT-MODE is used by LAP to determine where to put the compiled code. It is COMPILE-TO-CORE for making an actual FEF; QFASL, REL, or QFASL-NO-FDEFINE to simply dump a FEF without trying to define a function.EXP is the lambda-expression.NAME-FOR-FUNCTION is what the fef's name field should say; if omitted, FUNCTION-SPEC is used for that too.In MACRO-COMPILE mode, the return value is the value of QLAPP for the first function."  ;;  7/15/85 - Don't call PEEP when HOLDPROG is NIL.  ;;  2/01/86 - Moved binding of some special variables from QCOMPILE0 to around its call.  ;;  3/13/86 - Bind *BARF-DEFAULTS* to NIL.  ;;  4/25/86 - Set *LAST-ADDRESS-READ* if not already set by COMPILE-STREAM.  ;;  5/06/86 - Fix to allow EXP in DEBUG-INFO-AREA.  ;;  5/24/86 DNG - Split out CHECK-FOR-UNUSED-VARIABLES as a separate function.  ;;  5/28/86 DNG - Use a lexical closure instead of a dynamic closure for ERROR-MESSAGE-HOOK.  ;;  6/21/86 DNG - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.  ;;  7/10/86 DNG - Revised to use COMPILAND structure instead of COMPILER-QUEUE-ENTRY.  ;;  7/30/86 DNG - New argument PASS-1-ONLY.  ;;  9/24/86 DNG - Modify "give up" handling to skip the rest of the queue.  ;;  9/25/86 DNG - Removed the second call to OBJECT-OPERATION-WITH-WARNINGS because it was  ;;masking warnings recorded by the call in BREAKOFF.  ;; 11/14/86 DNG - Watch out for write-protected area SOURCE-CODE-AREA.  ;;  2/07/87 DNG - Use new function WRITE-PROTECTED-AREA-P .  ;;  3/07/87 DNG - Clear QCMP-OUTPUT array to facilitate GC.  (OBJECT-OPERATION-WITH-WARNINGS (NAME-FOR-FUNCTION)    (LET* ((DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA)   (ERROR-MESSAGE-HOOK     ;; Note: this function cannot reference special variables because     ;; it will be executed by the error handler in a different stack group.     ;; Construct a lexical closure over the function name.     (AND NAME-FOR-FUNCTION  #'(LAMBDA ()      (FORMAT T "Error occurred while compiling ~S"      NAME-FOR-FUNCTION))))   COMPILER-QUEUE   (WARN-CATCHER NIL)   (COMPILING-COMMON-LISP (COMMON-LISP-ON-P))   (VAL NIL)   (THIS-FUNCTION-BARF-SPECIAL-LIST NIL)   (GIVE-UP-NAME NAME-FOR-FUNCTION)   ( *BARF-DEFAULTS* NIL )   (*LAST-ADDRESS-READ* *LAST-ADDRESS-READ*))      (IF (ARRAYP EXP)  (SETQ COMPILER-QUEUE (CONS EXP NIL))(PROGN  (SETQ COMPILER-QUEUE(CONS (MAKE-COMPILAND :FUNCTION-SPEC FUNCTION-SPEC:FUNCTION-NAME NAME-FOR-FUNCTION:DEFINITION    EXP:DECLARATIONS  LOCAL-DECLARATIONS)      NIL))  (WHEN (NULL *LAST-ADDRESS-READ*) ; unless already set in COMPILE-STREAM    (LET (( EXP-AREA (%AREA-NUMBER EXP) ))      (IF (WRITE-PROTECTED-AREA-P EXP-AREA)  (SETF *LAST-ADDRESS-READ* (CONS EXP-AREA (%REGION-NUMBER EXP)))(SETF *LAST-ADDRESS-READ* (CONS-IN-AREA EXP-AREA NIL EXP-AREA)      (CDR *LAST-ADDRESS-READ*)      (%REGION-NUMBER *LAST-ADDRESS-READ*)))))  ))      (LOOP ; for each FEF to be generated(WHEN (NULL COMPILER-QUEUE) (RETURN))(LET* ((CURRENT (FIRST COMPILER-QUEUE))       (*CURRENT-COMPILAND* CURRENT)       (OPTIMIZE-SWITCH (COMPILAND-OPTIMIZE CURRENT))       )  (SETQ NAME-FOR-FUNCTION (COMPILAND-FUNCTION-NAME CURRENT))  (UNLESS (EQ (CAR-SAFE NAME-FOR-FUNCTION) ':INTERNAL)    (SETQ GIVE-UP-NAME NAME-FOR-FUNCTION))  (progn ;OBJECT-OPERATION-WITH-WARNINGS (NAME-FOR-FUNCTION)    (MULTIPLE-VALUE-BIND ( NIL ERROR-CAUGHT )      (CATCH-ERROR-RESTART (ERROR "Give up on compiling ~S" GIVE-UP-NAME);;;;Pass 1;;(WHEN (OR (COMPILAND-EXP2 CURRENT) ; pass 1 already done  (LET (( VARS NIL )( VAR-BIT (ASH (MAX SPECIAL-VAR-BIT DATA-ALTERATION-BIT) 1) )( ALTERED-VAR-SET 0 )( USED-VAR-SET 0 )( PROPAGATE-VAR-SET 0 )( SUBST-VAR-SET 0 )( LOCAL-FUNCTIONS NIL )( *LOCAL-ENVIRONMENT* NIL )( PROGDESCS NIL )( RETPROGDESC NIL )( GOTAGS NIL )( 1-IF-LIVE-CODE 1 )( FILE-LOCAL-DECLARATIONS FILE-LOCAL-DECLARATIONS )( MACRO-CONS-AREA (IF (EQ QC-TF-OUTPUT-MODE 'COMPILE-TO-CORE)      BACKGROUND-CONS-AREA    DEFAULT-CONS-AREA) ) ; for PRE-OPTIMIZE)    (UNLESS (LISTP (COMPILAND-FUNCTION-SPEC CURRENT)) ; non-NIL symbol      (PUSH `(DEF ,(COMPILAND-FUNCTION-SPEC CURRENT)  . ,(COMPILAND-DEFINITION CURRENT))     FILE-LOCAL-DECLARATIONS))    (LET ((RESULT (QCOMPILE1 CURRENT)))  ; do pass 1 on top-level function      (SETF (COMPILAND-USED-VAR-SET CURRENT) USED-VAR-SET)      (SETF (COMPILAND-ALTERED-VAR-SET CURRENT) ALTERED-VAR-SET)      (IF PASS-1-ONLY ; return partially compiled result  (PROGN (SETQ VAL CURRENT) (SETQ PASS-1-ONLY NIL) ; only applies to first queue entry NIL) ; don't do pass 2 yetRESULT) )))  ;; pass 1 succeded; continue.  ;;  ;;Pass 2  ;;  (QCOMPILE2 CURRENT)   ; pass 2 on sub-function  (WHEN HOLDPROG    ;;    ;;Peephole optimizer    ;;    (WHEN (AND PEEP-ENABLE       (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)   (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))       (NEQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE))      (record-individual-time 'peep(PEEP QCMP-OUTPUT (COMPILAND-FUNCTION-SPEC CURRENT))))    ;;    ;;QLAPP    ;;    (COND ((EQ QC-TF-PROCESSING-MODE 'MACRO-COMPILE)   (LET* ((LAP-CODE (G-L-P QCMP-OUTPUT))  (LAP-RESULT    (record-individual-time 'qlapp      (IF (EQ QC-TF-OUTPUT-MODE 'BOTH)  (PROGN    (QLAPP LAP-CODE 'QFASL)    (QLAPP LAP-CODE 'COMPILE-TO-CORE))(QLAPP LAP-CODE QC-TF-OUTPUT-MODE)))))     (UNLESS VAL (SETQ VAL LAP-RESULT))))  ((EQ QC-TF-PROCESSING-MODE 'MICRO-COMPILE)   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))     (MICRO-COMPILE (G-L-P QCMP-OUTPUT) QC-TF-OUTPUT-MODE)))  #+compiler:debug  (T (BARF QC-TF-PROCESSING-MODE "invalid compile mode" 'BARF))  )    ) ; end HOLDPROG  (UNLESS (SI:AREA-TEMPORARY-P DEFAULT-CONS-AREA)    ;; When TGC is in use, clear out the active portion of this    ;; array as soon as we are finished with it so that the    ;; contents can be garbage-collected.    (ARRAY-INITIALIZE QCMP-OUTPUT NIL)    (SETF (FILL-POINTER QCMP-OUTPUT) 0))  NIL))      (WHEN ERROR-CAUGHT(WHEN (< *RETURN-STATUS* FATAL)  (SETQ *RETURN-STATUS* FATAL));; If compilation of a function is aborted, then can't meaningfully;; continue compiling its children, so return out of the loop.(RETURN) )    )))(POP COMPILER-QUEUE)) ; end of LOOP      VAL)))(DEFUN COMPILE-NOW-OR-LATER (NAME LAMBDA-EXP)  "Compile LAMBDA-EXP and define NAME, either now or on exit from the compiler.If not within the compiler, it is done now.Otherwise, it is done as soon as it is safe."  ;; The only currently known use of this is in the SETF file.  ;;  6/26/86 DNG - Revised to use COMPILAND structure instead of COMPILER-QUEUE-ENTRY.  ;;  8/09/86 DNG - Test COMPILER-QUEUE instead of INSIDE-QC-TRANSLATE-FUNCTION.  (IF COMPILER-QUEUE      (PUSH-END (MAKE-COMPILAND   :FUNCTION-SPEC NAME  :FUNCTION-NAME NAME  :DEFINITION LAMBDA-EXP)COMPILER-QUEUE)    (COMPILE NAME LAMBDA-EXP)));We expect that DEFAULT-CONS-AREA has been bound to QCOMPILE-TEMPORARY-AREA.;The compiler does ALL consing in that temporary area unless it specifies otherwise.(DEFUN QCOMPILE1 (COMPILAND)  ;; 7/09/86 DNG - Function QCOMPILE0 split into QCOMPILE1 and QCOMPILE2 and  ;;re-designed around COMPILAND structure.  ;; 7/29/86 DNG - Given (LAMBDA (...) (BLOCK <name> ...)) use <name> as the FEF name.  ;; 8/20/86 DNG - Fix setting of COMPILING-COMMON-LISP.  ;; 8/27/86 DNG - Re-set TOP-LEVEL-DECLARATIONS after P1AUX.  ;; 9/02/86 DNG - Change for NAMED-LAMBDA debug info to be a plist instead of alist.  ;; 9/16/86 DNG - Deleted use of CHECK-FOR-UNUSED-VARIABLES [now handled by VARIABLE-WRAPUP].  ;;10/18/86 DNG - Permit tail recursion elimination of local functions.  ;;11/18/86 DNG - Use EXTRACT-DECLARATIONS-RECORD-MACROS instead of EXTRACT-DECLARATIONS.  (DECLARE (OPTIMIZE (SPACE 2) (SPEED 1)))  (LET  ((EXP1 (COMPILAND-DEFINITION COMPILAND)) BODY (FUNCTION-TO-BE-DEFINED (COMPILAND-FUNCTION-SPEC COMPILAND)) (NAME-TO-GIVE-FUNCTION  (COMPILAND-FUNCTION-NAME COMPILAND)) ALLGOTAGS (ALLVARS NIL) (FREEVARS NIL) ;;(DEAD-CODE-SKIPPED NIL) LL ; lambda list AGAIN-TAG  ; tag for Tail Recursion Elimination to loop back to TRE-ARGS   ; argument list for Tail Recursion Elimination (without &AUX vars). DOCUMENTATION EXPR-DEBUG-INFO ( MAX-LEXICAL-CLOSURE-COUNT 0 ) ;; List of all macros found in this function, for the debugging info. (MACROS-EXPANDED NIL) (SELF-FLAVOR-DECLARATION (COMPILAND-FLAVOR COMPILAND)) ;; Set to T during pass 1 if any SELF-REFs are present in the function. (SELF-REFERENCES-PRESENT NIL) (SELF-FLAVOR-MAPPED-VARIABLES NIL) (EXPRESSION-SIZE 0) INHIBIT-SPECIAL-WARNINGS TOP-LEVEL-DECLARATIONS (LOCAL-DECLARATIONS LOCAL-DECLARATIONS) (INLINE-DECLARATIONS INLINE-DECLARATIONS) (COMPILING-COMMON-LISP COMPILING-COMMON-LISP) )    (DECLARE (UNSPECIAL NAME-TO-GIVE-FUNCTION FUNCTION-TO-BE-DEFINED))    (WHEN (AND (CONSP FUNCTION-TO-BE-DEFINED)       (EQ (FIRST FUNCTION-TO-BE-DEFINED) ':PROPERTY)       (EQ (THIRD FUNCTION-TO-BE-DEFINED) ':NAMED-STRUCTURE-INVOKE))      (WARN 'OBSOLETE-PROPERTY ':IMPLAUSIBLE    "NAMED-STRUCTURE-INVOKE, the property name, should not have a colon."))    ;; If compiling a macro, compile its expansion function    ;; and direct lap to construct a macro later.    (WHEN (EQ (CAR EXP1) 'MACRO)      (SETF (COMPILAND-MACRO-FLAG COMPILAND) T)      (SETQ EXP1 (CDR EXP1)))    (UNLESS (MEMBER (CAR EXP1) '(GLOBAL:LAMBDA GLOBAL:SUBST       CLI:LAMBDA CLI:SUBST NAMED-SUBST        GLOBAL:NAMED-LAMBDA GLOBAL:NAMED-SUBST NAMED-LAMBDA)    :TEST #'EQ)      (WARN 'FUNCTION-NOT-VALID ':FATAL "The definition is not a function at all.")      (RETURN-FROM QCOMPILE1 NIL))    (WHEN (MEMBER (CAR EXP1)  '(GLOBAL:SUBST GLOBAL:NAMED-SUBST CLI:SUBST NAMED-SUBST)  :TEST #'EQ)      (SETF (COMPILAND-SUBST-FLAG COMPILAND) T    INHIBIT-SPECIAL-WARNINGS T))    (WHEN (NULL (COMPILAND-PARENT COMPILAND))      ;; Process any raw declarations that were placed on the LOCAL-DECLARATIONS      ;; list before the compiler was invoked.      (MULTIPLE-VALUE-SETQ ( LOCAL-DECLARATIONS EXPR-DEBUG-INFO )(PROCESS-PERVASIVE-DECLARATIONS LOCAL-DECLARATIONS NIL NIL T)))    ;; If a NAMED-LAMBDA, discard the name and save debug-info in special place.    (WHEN (MEMBER (CAR EXP1) '(GLOBAL:NAMED-LAMBDA NAMED-LAMBDA       GLOBAL:NAMED-SUBST NAMED-SUBST) :TEST #'EQ)      (SETQ COMPILING-COMMON-LISP    (NOT (EQ (SYMBOL-PACKAGE (CAR EXP1)) ZETALISP-PACKAGE)))      (WHEN (NULL NAME-TO-GIVE-FUNCTION)(SETF NAME-TO-GIVE-FUNCTION (FUNCTION-NAME EXP1))(SETF (COMPILAND-FUNCTION-NAME COMPILAND) NAME-TO-GIVE-FUNCTION))      (UNLESS (ATOM (SECOND EXP1))#+Elroy ; convert p-list to a-list(DO ((PLIST (SECOND (SECOND EXP1)) (CDDR PLIST)))    ((NULL PLIST))  (PUSH (CONS (FIRST PLIST) (SECOND PLIST))EXPR-DEBUG-INFO))#-Elroy ; append the two a-lists(SETQ EXPR-DEBUG-INFO      (IF (NULL EXPR-DEBUG-INFO)  (CDADR EXP1)(APPEND (CDADR EXP1) EXPR-DEBUG-INFO) )))      (SETQ EXP1 (CDR EXP1))      );;;   ;;; Process the argument list and declarations;;;     (SETQ LL (CADR EXP1))   ;lambda list.    (SETQ BODY (CDDR EXP1))    ;; Extract documentation string and declarations from the front of the body.    (MULTIPLE-VALUE-SETQ (BODY TOP-LEVEL-DECLARATIONS DOCUMENTATION) (EXTRACT-DECLARATIONS-RECORD-MACROS BODY NIL T))    (SETF (COMPILAND-DOCUMENTATION COMPILAND) DOCUMENTATION)    ;; unnamed LAMBDA can assume the name of a BLOCK that surrounds the body.    (WHEN (AND (NULL NAME-TO-GIVE-FUNCTION)       (CONSP (FIRST BODY))       (NULL (REST BODY))       (EQ (FIRST (FIRST BODY)) 'BLOCK))      (LET (( NAME (SECOND (FIRST BODY)) ))(WHEN (AND (SYMBOLP NAME)   (NOT (MEMBER NAME '(NIL T))))  (SETF NAME-TO-GIVE-FUNCTION NAME)  (SETF (COMPILAND-FUNCTION-NAME COMPILAND) NAME) )))    ;; Now that we are finally sure what the name of the function is...    (WHEN (AND COMPILER-VERBOSE       (OR FUNCTION-TO-BE-DEFINED NAME-TO-GIVE-FUNCTION)       (NOT (EQ (CAR-SAFE NAME-TO-GIVE-FUNCTION) ':INTERNAL)))      (FORMAT T "~&Compiling ~S" NAME-TO-GIVE-FUNCTION))    ;; Separate debug-info from other declarations.    (MULTIPLE-VALUE-SETQ ( LOCAL-DECLARATIONS EXPR-DEBUG-INFO )       (PROCESS-PERVASIVE-DECLARATIONS TOP-LEVEL-DECLARATIONS LOCAL-DECLARATIONS EXPR-DEBUG-INFO))    (SETF (COMPILAND-OPTIMIZE COMPILAND) OPTIMIZE-SWITCH) ; save for subsequent passes    (WHEN (AND (CONSP FUNCTION-TO-BE-DEFINED)       (EQ (CAR FUNCTION-TO-BE-DEFINED) :METHOD)       SELF-FLAVOR-DECLARATION       (NOT (COMPILING-FOR-V2)))      ;; Actual DEFMETHODs must always have SELF-FLAVOR      (SETF SELF-REFERENCES-PRESENT T))    (WHEN (AND SI:FILE-IN-COLD-LOAD       SELF-FLAVOR-DECLARATION       (NOT (COMPILING-FOR-V2)))      (WARN ':COLD-LOAD ':PROBABLE-ERROR    "Flavors cannot be used in the cold load.") )    ;; Put arglist together with body again.    (LET ((LAMEXP `(LAMBDA ,LL (DECLARE . ,TOP-LEVEL-DECLARATIONS) . ,BODY)))      (WHEN (AND TRE-ENABLE (OR (NOT (LISTP FUNCTION-TO-BE-DEFINED))     LOCAL-FUNCTIONS)) ; might be a recursive LABELS function(SETQ AGAIN-TAG (GENSYM)) )      ;; Now turn any &AUX variables in the LAMBDA into a LET* in the body.      (SETQ LAMEXP (P1AUX LAMEXP AGAIN-TAG))      (SETQ TRE-ARGS (SECOND LAMEXP))      (SETF (COMPILAND-ARGLIST COMPILAND) TRE-ARGS)      ;; If there are keyword arguments, expand them.      (WHEN (MEMBER '&KEY LL :TEST #'EQ) (SETQ LAMEXP (EXPAND-KEYED-LAMBDA LAMEXP));; handle new &AUX variables created by EXPAND-KEYED-LAMBDA(SETQ LAMEXP (P1AUX LAMEXP NIL)) )      ;; Separate lambda list and body again.      (SETQ LL (CADR LAMEXP) BODY (CDDR LAMEXP)))    (IF (AND (CONSP (CAR BODY)) (EQ (CAAR BODY) 'DECLARE))(SETQ TOP-LEVEL-DECLARATIONS (CDAR BODY)      BODY (CDR BODY))      (SETQ TOP-LEVEL-DECLARATIONS NIL))    (SETF (COMPILAND-INHERITED-VARS COMPILAND) VARS) ; after PROCESS-PERVASIVE-DECLARATIONS but before P1SBIND.    (SETF (COMPILAND-DEBUG-INFO COMPILAND) EXPR-DEBUG-INFO);;;;;; Pass 1;;;    (record-individual-time 'p1      (MULTIPLE-VALUE-BIND ( LL2 EXP2 )  (PASS1 LL BODY (LIST (LIST FUNCTION-TO-BE-DEFINED AGAIN-TAG TRE-ARGS)) TOP-LEVEL-DECLARATIONS)(SETF (COMPILAND-EXP2  COMPILAND) EXP2      (COMPILAND-LL2  COMPILAND) LL2      (COMPILAND-ARG-VARS COMPILAND) VARS)      ))    (SETF (COMPILAND-EXPRESSION-SIZE COMPILAND) EXPRESSION-SIZE)    (SETF (COMPILAND-FLAVOR COMPILAND) SELF-FLAVOR-DECLARATION)    (SETF (COMPILAND-MACROS-EXPANDED COMPILAND) MACROS-EXPANDED)    (UNLESS (NULL (COMPILAND-CHILDREN COMPILAND))      (SETF (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)    (LOOP FOR HOME IN ALLVARS  WHEN (AND (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES    (VAR-MISC HOME))    (NOT (EQ (VAR-KIND HOME) 'FEF-ARG-DELETED)))  COLLECT (VAR-LAP-ADDRESS HOME))))    (WHEN (OR SELF-REFERENCES-PRESENT      (AND SELF-FLAVOR-DECLARATION   (MEMBER 'SELF-MAPPING-TABLE FREEVARS)))      (SETF (COMPILAND-SELF-MAP-NEEDED COMPILAND) T))    (SETF (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND) MAX-LEXICAL-CLOSURE-COUNT)    (SETF (COMPILAND-ALLVARS  COMPILAND) ALLVARS)    (SETF (COMPILAND-FREEVARS COMPILAND) FREEVARS) )  COMPILAND);Compile an internal lambda into a separate function, returning the form for addressing it.(DEFUN BREAKOFF (LAMBDA-EXPRESSION EPHEMERAL)  ;; 07/09/85 DNG - Modify choice of FNAME-TO-GIVE.  ;; 07/12/85 DNG - Update LOCAL-FUNCTION-MAP.  ;; 12/11/85 DNG - Use function name instead of offset number in  ;;    :INTERNAL function specs.  ;; 12/23/85 DNG - Increment use count for variables holding local functions.  ;;  2/01/86 DNG - New queue slot VISIBLE-VARS. [for SPR 958 and 1073]  ;;  2/21/86 DNG - Add support for MAKE-EPHEMERAL-LEXICAL-CLOSURE;  ;;no longer disable Tail Recursion Elimination.  ;;  4/28/86 DNG - Cold load warning no longer needed for VM2.  ;;  5/01/86 DNG - Make sure PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG does not  ;;point to a function spec in the temporary area since it is used  ;;as a CATCH tag and hence becomes a constant in the FEF.  ;;  6/09/86 DNG - Cons the name in background-cons-area when compiling in memory.  ;;  6/21/86 DNG - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.  ;;  7/12/86 DNG - Major re-design to use recursive invocation of pass 1  ;;instead of CW-TOP-LEVEL-LAMBDA-EXPRESSION.  ;;  8/12/86 DNG - Reset ephemeral flag for closures used by a non-ephemeral closure.  ;;  9/25/86 DNG - Added call to OBJECT-OPERATION-WITH-WARNINGS .  ;; 10/18/86 DNG - Adjustments for use by EXTEND-LOCAL-VARIABLES .  ;; 11/24/86 DNG - Add warning for a DEFSUBST that is a lexical closure; fix  ;;handling of a macro expander that is a lexical closure.  ;; 12/22/86 DNG - More adjustments for use by EXTEND-LOCAL-VARIABLES .  ;;  2/16/87 DNG - Set COMPILAND-INITIAL-ENVIRONMENT-VARS .  ;;  3/17/87 DNG - Fix so lexical closure is not ephemeral if it has any  ;;children that are non-ephemeral lexical closures.  (WHEN INLINE-EXPANSIONS ; kick back to function PROCEDURE-INTEGRATION    (THROW (SECOND (FIRST INLINE-EXPANSIONS)) 'BREAKOFF) )  (LET* ((LEXICAL NIL) FNAME  FNAME-TO-GIVE  CHILD (PARENT *CURRENT-COMPILAND*) (FUNCTION-TO-BE-DEFINED (COMPILAND-FUNCTION-SPEC PARENT)) (NAME-TO-GIVE-FUNCTION  (COMPILAND-FUNCTION-NAME PARENT)))    (DECLARE (UNSPECIAL FUNCTION-TO-BE-DEFINED NAME-TO-GIVE-FUNCTION))    (WHEN (AND SI:FILE-IN-COLD-LOAD       (CONSP FUNCTION-TO-BE-DEFINED)       (NOT (COMPILING-FOR-V2))       (NOT (ZEROP 1-IF-LIVE-CODE)))      (WARN ':COLD-LOAD ':PROBABLE-ERROR    "The cold loader doesn't allow internal functions in non-symbol function specs.") )    (MULTIPLE-VALUE-BIND ( LAMBDA-NAME NAMEDP )(FUNCTION-NAME LAMBDA-EXPRESSION)      (LET ((LAMBDA-ID     (IF (AND NAMEDP      (SYMBOLP LAMBDA-NAME)      (NOT (MEMBER LAMBDA-NAME   (COMPILAND-LOCAL-FUNCTION-MAP PARENT)   :TEST #'EQ))) ;; When the function has a unique name, use it. LAMBDA-NAME       ;; Else, identify it with a number.       (LENGTH (COMPILAND-CHILDREN PARENT))) )    ( DEFAULT-CONS-AREA (IF (AND QC-FILE-IN-PROGRESS (NOT QC-FILE-LOAD-FLAG))    DEFAULT-CONS-AREA  BACKGROUND-CONS-AREA) ))(SETQ FNAME-TO-GIVE `(:INTERNAL ,NAME-TO-GIVE-FUNCTION ,LAMBDA-ID)      FNAME (IF (EQUAL FUNCTION-TO-BE-DEFINED NAME-TO-GIVE-FUNCTION)FNAME-TO-GIVE      `(:INTERNAL ,FUNCTION-TO-BE-DEFINED ,LAMBDA-ID)))(WHEN (AND (EQ FUNCTION-TO-BE-DEFINED NIL)   (EQ LAMBDA-ID LAMBDA-NAME))  (SETQ FNAME-TO-GIVE LAMBDA-NAME) ))      (SETF CHILD (MAKE-COMPILAND  :FUNCTION-SPECFNAME  :FUNCTION-NAMEFNAME-TO-GIVE  :DEFINITIONLAMBDA-EXPRESSION  :PARENTPARENT  :FLAVOR        SELF-FLAVOR-DECLARATION  :NESTING-LEVEL(1+ (COMPILAND-NESTING-LEVEL PARENT))  :USE-COUNT1-IF-LIVE-CODE  ;; The following fields are only used by procedure integration.  :INHERITED-VARSVARS  :DECLARATIONSLOCAL-DECLARATIONS  :INHERITED-GOTAGSGOTAGS  :INHERITED-PROGDESCSPROGDESCS  :INHERITED-RETPROGDESC RETPROGDESC  :INHERITED-LOCAL-FUNCTIONS LOCAL-FUNCTIONS  :INHERITED-LOCAL-MACROS *LOCAL-ENVIRONMENT*  ))      (UNLESS (ZEROP 1-IF-LIVE-CODE)(PUSH (AND NAMEDP LAMBDA-NAME)      (COMPILAND-LOCAL-FUNCTION-MAP PARENT))(PUSH CHILD      (COMPILAND-CHILDREN PARENT))))    (LET* (( MASK (- VAR-BIT 1))   ( *VAR-LEVEL-COUNTS* (MAKE-LIST (COMPILAND-NESTING-LEVEL CHILD)   :INITIAL-ELEMENT '0) )   ( FORM    (PROG1 (LET ((PROPAGATE-VAR-SET 0) (SUBST-VAR-SET 0) (VARS VARS) (*CURRENT-COMPILAND* CHILD) (*LOOP-LEVEL* 0))     ;; perform pass 1 of compilation.     (IF (AND COMPILER-WARNINGS-CONTEXT      (NULL SI:OBJECT-WARNINGS-OBJECT-NAME)      (SYMBOLP FNAME-TO-GIVE)) (OBJECT-OPERATION-WITH-WARNINGS (FNAME-TO-GIVE)   (P1-WITH-ANNOTATION CHILD #'QCOMPILE1))     (P1-WITH-ANNOTATION CHILD #'QCOMPILE1)))   (UPDATE-PROPAGATE-VAR-SET)) )   ;; lexical entities referenced by the function but defined outside of it:   ( USED    (LOGAND (EXPR-USED    FORM) MASK) )   ( ALTERED (LOGAND (EXPR-ALTERED FORM) MASK) )   ( LEXICAL-VAR-REF-SET (LOGDIF (LOGIOR USED ALTERED) SPECIAL-VAR-BIT) )   )      (UNLESS (OR (ZEROP LEXICAL-VAR-REF-SET)  (ZEROP 1-IF-LIVE-CODE));; At this point we know that the function contained non-local lexical;; references, but they could be to variables, BLOCK names, or GO tags.;; Only variable references require making a lexical closure.(DOLIST ( V VARS )  (WHEN (EQ (VAR-TYPE V) 'FEF-LOCAL)    (LET (( THIS-VAR-BIT (CDDR (VAR-LAP-ADDRESS V))))      (WHEN (IF THIS-VAR-BIT ; could be nil when called from EXTEND-LOCAL-VARIABLES .(LOGTEST LEXICAL-VAR-REF-SET THIS-VAR-BIT)      (VAR-USE-COUNT V));; This is one of the referenced variables(SETF LEXICAL T)   ; making a lexical closure(PUSHNEW 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V))(UNLESS EPHEMERAL  ;; If this closure is not ephemeral, then any that it uses can't be either.  (LET ((INIT (VAR-INIT V)))    (WHEN (AND (CONSP INIT)       (EQ (CAR-SAFE (SECOND INIT)) 'LEXICAL-CLOSURE))      (SETF (THIRD (SECOND INIT)) NIL))))(SETF (VAR-OVERLAP-VAR V) NIL)(WHEN (AND THIS-VAR-BIT   (ZEROP (SETF LEXICAL-VAR-REF-SET(LOGDIF LEXICAL-VAR-REF-SET THIS-VAR-BIT))))  ;; Found all that we were looking for.  (RETURN))))))(WHEN LEXICAL  (INCF LEXICAL-CLOSURE-COUNT)  (WHEN (> LEXICAL-CLOSURE-COUNT MAX-LEXICAL-CLOSURE-COUNT)    (IF (ZEROP MAX-LEXICAL-CLOSURE-COUNT) ; the first time(SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT)      VARS)      (DO ((IVARS (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT) (REST IVARS)))  ((OR (NULL IVARS)       (MEMBER (FIRST IVARS) VARS :TEST #'EQ))   (SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS PARENT) IVARS))))    (SETQ MAX-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT))  (SETF (GETF (COMPILAND-PLIST CHILD) 'VAR-LEVEL-COUNTS)(NREVERSE *VAR-LEVEL-COUNTS*))  (WHEN (COMPILAND-SUBST-FLAG CHILD)    ;; not meaningful for a DEFSUBST to be a closure.    (WARN 'COMPILAND-SUBST-FLAG ':IMPLAUSIBLE  "DEFSUBST ~S references non-local lexical variables so cannot be expanded inline."  FNAME-TO-GIVE)) )(UNLESS (COMPILING-FOR-V2)  (SETQ TRE-OK NIL)) ; prevent Tail Recursion Elimination)      (SETF (COMPILAND-USED-VAR-SET CHILD) USED)      (SETF (COMPILAND-ALTERED-VAR-SET CHILD) ALTERED)     )    (IF LEXICAL(LET ((DEF `(LEXICAL-CLOSURE      ,CHILD      ,(AND (OR EPHEMERAL;; from PROCESS-PERVASIVE-DECLARATIONS:(GETF (COMPILAND-PLIST CHILD)      'SI:DOWNWARD-FUNCTION))    (DOLIST (GRANDCHILD (COMPILAND-CHILDREN CHILD) T)      (LET ((X (COMPILAND-LEXICAL-CLOSURE-FLAG GRANDCHILD)))(WHEN (AND (CONSP X) (NOT (THIRD X)))  ;; current closure can't be ephemeral if it has  ;; any children that are not.  (RETURN NIL)))) ))))   (SETF (COMPILAND-LEXICAL-CLOSURE-FLAG CHILD) DEF)   (INCF EXPRESSION-SIZE 2)   (IF (COMPILAND-MACRO-FLAG CHILD)       ;; need to cons on the macro flag here instead of in QLAPP.       (PROGN (SETF (COMPILAND-MACRO-FLAG CHILD) NIL)      (INCF EXPRESSION-SIZE 2)      `(CONS 'MACRO ,DEF))     DEF))      `(BREAKOFF-FUNCTION ,CHILD))))(DEFUN QCOMPILE2 (COMPILAND)  ;; 7/09/86 DNG - Function QCOMPILE0 split into QCOMPILE1 and QCOMPILE2 and  ;;re-designed around COMPILAND structure.  ;; 7/29/86 DNG - Set *LEXICAL-REGISTER-LEVELS*.  ;;10/11/86 DNG - LEX-A reg must always point to parent if lexical closures are created.  ;;10/18/86 DNG - Add support for phantom variables.  ;; 4/09/87 DNG - Disable re-loading the LEX-A register because it is needed by  ;;LOAD-FROM-HIGHER-CONTEXT.  [SPR 4751]  (DECLARE (OPTIMIZE (SPACE 2) (SPEED 1)))  ;;  ;;Assign addresses of local variables  ;;  (LET ( VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURES( *LEXICAL-REGISTER-LEVELS* NIL ))    (WHEN (AND (COMPILING-FOR-V2)       (OR (> (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND) 0)   (COMPILAND-LEXICAL-CLOSURE-FLAG COMPILAND)))      ;; Function that either makes lexical closures or is a lexical closure.      (SETQ *LEXICAL-REGISTER-LEVELS* '(0))      (LET* ((COUNT-LIST (GETF (COMPILAND-PLIST COMPILAND) 'VAR-LEVEL-COUNTS))     MAX-COUNT B-LEVEL)(DECLARE (LIST COUNT-LIST));; Decide which lexical levels should be addressed by the LEX-A and LEX-B;; addressing modes.(WHEN (REST COUNT-LIST)  (SETQ MAX-COUNT (APPLY #'MAX (REST COUNT-LIST)))  (WHEN (> MAX-COUNT (LOOP-WEIGHTED-INCREMENT 0))    (SETQ B-LEVEL (1+ (POSITION MAX-COUNT (REST COUNT-LIST) :TEST #'EQ)))    (SETQ COUNT-LIST (COPY-LIST COUNT-LIST))    (SETF (NTH B-LEVEL COUNT-LIST) 0)    (SETQ MAX-COUNT (APPLY #'MAX COUNT-LIST))    (SETQ *LEXICAL-REGISTER-LEVELS*  (LIST (IF (AND NIL ; This feature disabled for now.  Before re-instating it, ;; we need to also be sure no more than 32 vars per level so ;; that a LOAD-FROM-HIGHER-CONTEXT or STORE-IN-HIGHER-CONTEXT ;; will never be needed since they use the A register also. (> MAX-COUNT (LOOP-WEIGHTED-INCREMENT 0)) ; enough uses to be worthwhile (= (COUNT-IF-NOT #'ZEROP COUNT-LIST) 1) ; no other levels referenced (ZEROP (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND)))    (POSITION MAX-COUNT COUNT-LIST :TEST #'EQ)  0) ; else LEX-A is the immediate parent levelB-LEVEL))    (UNLESS (EQUAL *LEXICAL-REGISTER-LEVELS* '(0 1))      (PUSH (CONS 'LEXICAL-REGISTER-LEVELS *LEXICAL-REGISTER-LEVELS*)    (COMPILAND-DEBUG-INFO COMPILAND)))    ))))    (LET (( LVCNT (ASSIGN-LAP-ADDRESSES COMPILAND) ))      (SETF VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURES    (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND))      (SETF (COMPILAND-LLOCBLOCK COMPILAND)    (IF (OR (ZEROP (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND))    (COMPILING-FOR-V2))LVCNT      (+ LVCNT (* 4 (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND)) 3 (LENGTH VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURES))))      )    ;; Eliminate overlapped variables after ASSIGN-LAP-ADDRESSES    (SETF (COMPILAND-ALLVARS COMPILAND)  (ELIMINATE-DUPLICATES-AND-REVERSE (COMPILAND-ALLVARS COMPILAND)))    ;; convert list of addresses to list of homes.    (SETF (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)  (LOOP FOR A IN VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURESCOLLECT (SECOND A)))    ;;    ;;construct the DEBUG-INFO structure    ;;    (BUILD-DEBUG-INFO COMPILAND)     ;;    ;;  Begin writing LAP output    ;;    (SETF (FILL-POINTER QCMP-OUTPUT) 0)    (WHEN (COMPILING-FOR-V2)      (OUTF `(DEBUG-INFO . ,(COMPILAND-DEBUG-INFO COMPILAND))) )    ;; output FEF header information    (OUTF (LIST 'MFEF(COMPILAND-FUNCTION-SPEC COMPILAND)(COMPILAND-SPECIAL-FLAG COMPILAND)(COMPILAND-ALLVARS COMPILAND)(COMPILAND-FREEVARS COMPILAND)(COMPILAND-FUNCTION-NAME COMPILAND)(COMPILAND-SUBST-FLAG COMPILAND)(COMPILAND-ARGLIST COMPILAND)))    (WHEN (COMPILAND-MACRO-FLAG COMPILAND)      (OUTF '(CONSTRUCT-MACRO)))    (OUTF `(PARAM LLOCBLOCK ,(COMPILAND-LLOCBLOCK COMPILAND)))    (WHEN (AND (COMPILAND-SELF-MAP-NEEDED COMPILAND)       (COMPILING-FOR-V2))      ;; Flavor name, if any, follows the FEF header      (OUTF `(SELF-FLAVOR . ,(COMPILAND-FLAVOR COMPILAND))))    (OUTF '(QTAG S-V-BASE))    (OUTF '(S-V-BLOCK)) ; special variable pointers output here by LAP.    (UNLESS (COMPILING-FOR-V2)      ;; Flavor name, if any, comes just before the ADL.      (WHEN (COMPILAND-SELF-MAP-NEEDED COMPILAND) (OUTF `(SELF-FLAVOR . ,(COMPILAND-FLAVOR COMPILAND))))      (OUTF '(QTAG DESC-LIST-ORG))      (OUTF '(A-D-L)) )    (OUTF '(QTAG QUOTE-BASE))    (OUTF '(ENDLIST))   ;Lap will insert quote vector here    (WHEN (AND (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)       (NOT (COMPILING-FOR-V2)))      (OUTF `(VARIABLES-USED-IN-LEXICAL-CLOSURES       . ,(NREVERSE    (MAPCAR #'(LAMBDA (HOME)(LET ((TEM (VAR-LAP-ADDRESS HOME)))  (CASE (CAR TEM)    (ARG (CADR TEM))    (LOCBLOCK (%LOGDPB 1 %%Q-BOXED-SIGN-BIT       (CADR TEM)))    (T #+compiler:debug       (BARF TEM 'VARIABLES-USED-IN-LEXICAL-CLOSURES     'BARF)       0))))    (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND))))))    (UNLESS (COMPILING-FOR-V2) ; unless already done above      (LET (( DEBUG-INFO (COMPILAND-DEBUG-INFO COMPILAND) ))(UNLESS (NULL DEBUG-INFO)  (UNLESS (NULL (COMPILAND-CHILDREN COMPILAND))    (OUTF `(BREAKOFFS ,(CDR (ASSOC ':INTERNAL-FEF-OFFSETS DEBUG-INFO :TEST #'EQ)))))  (OUTF `(DEBUG-INFO . ,DEBUG-INFO)) ) ) );;;;;;    Pass 2;;;    (record-individual-time 'p2      (LET ((VARS (COMPILAND-ARG-VARS COMPILAND))    (PROGDESCS NIL )    (GOTAGS NIL))(PASS2 (COMPILAND-LL2 COMPILAND)       (COMPILAND-EXP2 COMPILAND)       (COMPILAND-INHERITED-VARS COMPILAND)       )))  (LET (( COUNT 0 )( LEVEL (COMPILAND-NESTING-LEVEL COMPILAND) ))    ;; Change (LOCAL-REF home) to (LEXICAL-REF level count) for lower-level functions.    (DOLIST (A VAR-ADDRESSES-USED-IN-LEXICAL-CLOSURES)      (LET ((V (SECOND A)))(SETF (CAR A) 'LEXICAL-REF      (CDR A) (LIST LEVEL COUNT))(SETF (VAR-LAP-ADDRESS V) A))      (INCF COUNT) )    (DOLIST (V (GETF (COMPILAND-PLIST COMPILAND) 'PHANTOM-VARS))      (LET ((A (VAR-LAP-ADDRESS V)))(SETF (CAR A) 'LEXICAL-REF      (CDR A) (LIST LEVEL COUNT)))      (INCF COUNT) )    ))  COMPILAND);; After the end of pass 1, assign lap addresses to the variables.;; Returns the total number of local variable slots allocated.(DEFUN ASSIGN-LAP-ADDRESSES (COMPILAND)  ;;  7/11/85 - Don't share slots used in lexical closures.  ;;  9/25/85 - Make ARG-MAP and LOCAL-MAP entries be a symbol instead of a list.  ;; 12/07/85 - Delete use of CLOBBER-NONSPECIAL-VARS-LISTS since it was always NIL.  ;; 12/16/85 - Fix to not share storage with a deleted variable; remove FEF-REMOTE.  ;;  1/10/86 - Reserve local slots for VM2 lexical closure implementation.  ;;  7/08/86 - Revised to use COMPILAND structure.  ;; 10/18/86 - Call EXTEND-LOCAL-VARIABLES if more than 64 local slots are needed.  (LET ((ARGN 0)   ;Next arg number to allocate.(LVCNT 0)  ;Next local block slot number to allocate.   ;Count rest arg, auxes, and internal-auxes if they are not special.(ARG-MAP NIL)  ;We also build the arg map and local map,(LOCAL-MAP NIL)) ;pushing things on in reverse order.    (DECLARE (UNSPECIAL ARG-MAP LOCAL-MAP ARGN LVCNT)     (FIXNUM ARGN LVCNT) (LIST ARG-MAP LOCAL-MAP))    (WHEN (COMPILING-FOR-V2)      ;; Temporary kludgey way of reserving registers needed by microcode when      ;; dealing with lexical closures.      (BLOCK RESERVE-REGISTERS(COND ((> (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT COMPILAND) 0)       ;; current function makes lexical closures       (SETQ LVCNT 6) )      ((SECOND *LEXICAL-REGISTER-LEVELS*)       ;; current function is a lexical closure referencing more than one level.       (SETQ LVCNT 4))      ((NOT (NULL *LEXICAL-REGISTER-LEVELS*))       ;; current function is a lexical closure that only references the parent level.       (SETQ LVCNT 3) )      (T (RETURN-FROM RESERVE-REGISTERS)))(LET (( RESERVED-REGISTER-NAMES       ;; 0   1       234  5       '(NIL NIL LEX-PARENT-ENV-REG LEX-ENV-B-REG LEX-CURRENT-VECTOR-REG LEX-ALL-VECTORS-REG)))  (DOTIMES (I LVCNT)    (PUSH (POP RESERVED-REGISTER-NAMES)  LOCAL-MAP)))) )    (DOLIST (V (REVERSE (COMPILAND-ALLVARS COMPILAND)))      ;; Cons up the expression for Lap to use to refer to this variable.      (LET ((TYPE (VAR-TYPE V))    (KIND (VAR-KIND V))    (NAME (VAR-NAME V))    (OVERLAPS NIL)    PERMANENT-NAME)(SETF (VAR-LAP-ADDRESS V)      (COND ((EQ KIND 'FEF-ARG-DELETED)     `(FEF-ARG-DELETED ,NAME))   ; dummy entry, shouldn't be referenced    ((EQ TYPE 'FEF-SPECIAL)     `(SPECIAL ,NAME))    ((MEMBER KIND '(FEF-ARG-REQ FEF-ARG-OPT) :TEST #'EQ)     `(ARG ,ARGN))    ((EQ KIND 'FEF-ARG-REST)     (WHEN (> LVCNT 0)       (SETQ OVERLAPS V)) ; replace name in LOCAL-MAP instead of pushing     `(LOCBLOCK 0) )    (T (SETQ OVERLAPS (VAR-OVERLAP-VAR V))       (WHEN (AND OVERLAPS  (OR (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES      (VAR-MISC V))      (NEQ KIND (VAR-KIND OVERLAPS)) ; make sure it wasn't deleted      )) ;; can't really share storage after all. (SETF (VAR-OVERLAP-VAR V) NIL) (SETF OVERLAPS NIL) )       (COND (OVERLAPS (VAR-LAP-ADDRESS OVERLAPS))     ((EQ NAME 'SI:.DAEMON-MAPPING-TABLE.)      ;; This magic variable used in combined flavor methods must      ;;  always be LOCAL|1 because the microcode expects to      ;;  find it there when doing a %SET-SELF-MAPPING-TABLE .      (COND ((= LVCNT 0)     (SETQ LVCNT 1)     (PUSH NIL LOCAL-MAP))    ((= LVCNT 1))    (T (UNLESS (COMPILING-FOR-V2) (WARN 'SI:.DAEMON-MAPPING-TABLE. ':ERROR     "~S is not at LOCAL|1" NAME) )       (SETQ OVERLAPS V)) )      `(LOCBLOCK 1))     (T `(LOCBLOCK ,LVCNT))))));; If the name is in the temporary area or is uninterned, don't put it in the;; arg/local map.  This is partly to avoid putting all these stupid gensyms;; into the qfasl file, but the real reason is to avoid the dreaded scourge;; of temporary area lossage in the error handler.(SETQ PERMANENT-NAME (UNLESS (= (%AREA-NUMBER NAME) QCOMPILE-TEMPORARY-AREA)       (WHEN (SYMBOL-PACKAGE NAME) NAME)));; Now increment one or more of the counters of variables;; and maybe make an entry on LOCAL-MAP or ARG-MAP(COND ((MEMBER KIND '(FEF-ARG-REQ FEF-ARG-OPT) :TEST #'EQ)       (PUSH (IF (COMPILING-FOR-V2) PERMANENT-NAME       (AND PERMANENT-NAME (LIST PERMANENT-NAME)))     ARG-MAP)       (AND (= (SETQ ARGN (1+ ARGN)) #o101)    (WARN 'TOO-MANY-SLOTS ':IMPLEMENTATION-LIMIT  "More than 64. arguments accepted by one function.")))      ((EQ KIND 'FEF-ARG-DELETED))      ((OR (EQ TYPE 'FEF-LOCAL)   (NOT (MEMBER KIND '(FEF-ARG-INTERNAL FEF-ARG-INTERNAL-AUX FEF-ARG-KEY):TEST #'EQ)))       (COND ((NOT OVERLAPS)      (PUSH (IF (COMPILING-FOR-V2)PERMANENT-NAME      (AND PERMANENT-NAME (LIST PERMANENT-NAME)))    LOCAL-MAP)      (SETQ LVCNT (1+ LVCNT))      (WHEN (= LVCNT #o101)(IF (AND (COMPILING-FOR-V2) (EXTEND-LOCAL-VARIABLES COMPILAND))    (RETURN-FROM ASSIGN-LAP-ADDRESSES      (ASSIGN-LAP-ADDRESSES COMPILAND))  (WARN 'TOO-MANY-SLOTS ':IMPLEMENTATION-LIMIT"More than 64. local variable slots required by one function."))))     (T (LET ((L1 (NTHCDR (- (LENGTH LOCAL-MAP)     (CADR (VAR-LAP-ADDRESS V))     1)  LOCAL-MAP)))  (UNLESS (NULL PERMANENT-NAME)    (IF (LISTP (CAR L1))(UNLESS (MEMBER NAME (CAR L1) :TEST #'EQ)  (PUSH NAME (CAR L1)) )      (UNLESS (EQ NAME (CAR L1))(SETF (CAR L1) (LIST NAME (CAR L1))) )))))))   )))    (UNLESS (COMPILING-FOR-V2)      (DOLIST (V (COMPILAND-ALLVARS COMPILAND)) ;Fix FIXE's put in by VAR-COMPUTE-INIT(AND (EQ (CAR (VAR-INIT V)) 'FEF-INI-EFF-ADR)     (EQ (CAADR (VAR-INIT V)) 'FIXE)     (SETF (CADADR (VAR-INIT V)) (VAR-LAP-ADDRESS (CADR (CADADR (VAR-INIT V)))))))      )    (SETF (COMPILAND-LOCAL-MAP COMPILAND) (NREVERSE LOCAL-MAP)  (COMPILAND-ARG-MAP   COMPILAND) (NREVERSE ARG-MAP))    LVCNT));There can be duplicates of local vars on allvars because of the variable overlaping hack.;Dont disturb special vars.(DEFUN ELIMINATE-DUPLICATES-AND-REVERSE (VAR-LIST)  (PROG (ANS)    L  (COND ((NULL VAR-LIST) (RETURN ANS))     ((EQ (VAR-KIND (CAR VAR-LIST)) 'FEF-ARG-DELETED))     ((NULL (DOLIST (V ANS)      (IF (AND (EQ (VAR-NAME V) (VAR-NAME (CAR VAR-LIST)))       (NOT (EQ (CAR (VAR-LAP-ADDRESS V)) 'SPECIAL))       (EQUAL (VAR-LAP-ADDRESS V) (VAR-LAP-ADDRESS (CAR VAR-LIST))))  (RETURN T))));this a local duplicate, flush      (SETQ ANS (CONS (CAR VAR-LIST) ANS))))       (SETQ VAR-LIST (CDR VAR-LIST))       (GO L)))(DEFUN EXTEND-LOCAL-VARIABLES (PARENT)  ;; When ASSIGN-LAP-ADDRESSES finds that there are more local variables than  ;; can be handled; it calls this function which splits the compiland into two  ;; FEFs and puts the excess variables in the lexical environment.  These are  ;; called "phantom variables" because they exist only in the lexical environment  ;; and are not part of any stack frame.  ;;  ;; 10/18/86 DNG - Original.  ;; 12/22/86 DNG - Fix for when the function already creates lexical closures.  (LET ((PARENT-ALLVARS NIL)(CHILD-ALLVARS NIL)(OVERLAPPED-ALLVARS NIL)(PHANTOM-VARS NIL)(SPECIAL-VARS))    (DOLIST (V (COMPILAND-ALLVARS PARENT))      (LET ((KIND (VAR-KIND V)))(COND ((EQ KIND 'FEF-ARG-DELETED))      ((EQ (VAR-TYPE V) 'FEF-SPECIAL)       (PUSH V SPECIAL-VARS))      ((EQ KIND 'FEF-ARG-INTERNAL-AUX)       (LET ((USE-COUNT (VAR-USE-COUNT V))     (OVERLAPS (VAR-OVERLAP-VAR V))) (IF (NULL OVERLAPS)     (IF (NULL USE-COUNT) (PUSH V PHANTOM-VARS)       (PUSH V CHILD-ALLVARS))   (LET (( COUNT (VAR-USE-COUNT OVERLAPS) ))     (WHEN (NULL COUNT) (SETQ COUNT 0))     (SETF (VAR-USE-COUNT OVERLAPS)   (+ COUNT USE-COUNT))     (PUSH V OVERLAPPED-ALLVARS)))))      (T (PUSH V PARENT-ALLVARS) (UNLESS (NULL (VAR-USE-COUNT V))   (PUSHNEW 'FEF-ARG-USED-IN-LEXICAL-CLOSURES    (VAR-MISC V)))))))    (UNLESS (OR CHILD-ALLVARS PHANTOM-VARS)      (RETURN-FROM EXTEND-LOCAL-VARIABLES NIL)) ; indicate failure    ;; Allocate the local slots to the variables that are used the most.    (SETF CHILD-ALLVARS (SORT CHILD-ALLVARS #'> :KEY #'VAR-USE-COUNT))    (LET ((CUT (NTHCDR 56. CHILD-ALLVARS))) ; 64 slots minus up to 6 reserved slots = 58      (SETF PHANTOM-VARS (NCONC (CDR CUT) PHANTOM-VARS ))      (SETF (CDR CUT) NIL))    (LET (CHILD BREAKOFF  (OPTIONALS NIL)  (SIBLINGS (COMPILAND-CHILDREN PARENT))  (LOCAL-FUNCTION-NAMES (COMPILAND-LOCAL-FUNCTION-MAP PARENT))  (SAVED-CLOSURE-COUNT (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT PARENT))  )      (LET ((VARS (APPEND PARENT-ALLVARS PHANTOM-VARS))    (GOTAGS NIL)    (PROGDESCS NIL)    (RETPROGDESC NIL)    (LOCAL-FUNCTIONS NIL)    (VAR-BIT 0)    (USED-VAR-SET -1 ) ;(COMPILAND-USED-VAR-SET PARENT))    (ALTERED-VAR-SET -1) ;(COMPILAND-ALTERED-VAR-SET PARENT))    (SUBST-VAR-SET 0)    (PROPAGATE-VAR-SET 0)    (MACRO-CONS-AREA DEFAULT-CONS-AREA)    (LEXICAL-CLOSURE-COUNT 0)    (MAX-LEXICAL-CLOSURE-COUNT 0)    (EXPRESSION-SIZE 0)    (P1VALUE T)    BODY)(SETQ BODY (LET ((ALLVARS NIL))     (MARK-P1-DONE (COMPILAND-EXP2 PARENT))))(SETF (COMPILAND-CHILDREN PARENT) NIL)(SETF (COMPILAND-LOCAL-FUNCTION-MAP PARENT) NIL)        (SETQ BREAKOFF      (BREAKOFF (IF (DOLIST (ARG (COMPILAND-ARGLIST PARENT) NIL)      (COND ((CONSP ARG)     (SETQ OPTIONALS T)     (RETURN T))    ((MEMBER ARG '(&KEY &REST &AUX))     (RETURN NIL))))    ;; some optional args with default values    `(NAMED-LAMBDA :BODY (N-OPT-SUPPLIED)  (%PUSH N-OPT-SUPPLIED) ,BODY)  `(NAMED-LAMBDA :BODY () ,BODY))T))(SETF (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT PARENT) MAX-LEXICAL-CLOSURE-COUNT))      (SETQ CHILD (SECOND BREAKOFF))      (SETF (COMPILAND-CHILDREN CHILD) SIBLINGS)      (SETF (COMPILAND-LOCAL-FUNCTION-MAP CHILD) LOCAL-FUNCTION-NAMES)      (SETF (COMPILAND-MAX-LEXICAL-CLOSURE-COUNT CHILD) SAVED-CLOSURE-COUNT)      ;; the following is to prevent the interpreted definition from being saved      (SETF (COMPILAND-EXPRESSION-SIZE CHILD) (COMPILAND-EXPRESSION-SIZE PARENT))      (LABELS (#+Elroy       (INCREMENT-NESTING-LEVEL (COMPILAND)  (INCF (COMPILAND-NESTING-LEVEL COMPILAND))  ;;(PUSH-END (1+ (LOOP-WEIGHTED-INCREMENT 0))  ;;    (GETF (COMPILAND-PLIST COMPILAND) 'VAR-LEVEL-COUNTS))  (MAPC #'INCREMENT-NESTING-LEVEL (COMPILAND-CHILDREN COMPILAND))  NIL))(DOLIST (C SIBLINGS)  (SETF (SECOND (COMPILAND-FUNCTION-SPEC C)) (COMPILAND-FUNCTION-SPEC CHILD))  (SETF (COMPILAND-PARENT C) CHILD)  (INCREMENT-NESTING-LEVEL C)))      (DOLIST (V CHILD-ALLVARS)(SETF (VAR-COMPILAND V) CHILD)(WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES      (VAR-MISC V))  (PUSHNEW `(LOCAL-REF ,V)   (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES CHILD) :TEST #'EQ)))      (LET ((USED-IN-LEX NIL))(DOLIST (V (PROG1 PARENT-ALLVARS  (SETQ PARENT-ALLVARS NIL)))  (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES(VAR-MISC V))    (PUSHNEW `(LOCAL-REF ,V) USED-IN-LEX :TEST #'EQ))  (PUSH 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 (COMPILAND-ALLVARS CHILD)))      (SETF (COMPILAND-EXP2 PARENT)    (IF OPTIONALS`(FUNCALL ,BREAKOFF (%POP))      `(FUNCALL ,BREAKOFF)))      (SETF (COMPILAND-ALLVARS PARENT) PARENT-ALLVARS)      (SETF (GETF (COMPILAND-PLIST PARENT) 'PHANTOM-VARS)    PHANTOM-VARS)      (SETF (COMPILAND-DEFINITION CHILD) (COMPILAND-DEFINITION PARENT))      ))  T) ; indicate success#-Elroy(defun INCREMENT-NESTING-LEVEL (COMPILAND)  (INCF (COMPILAND-NESTING-LEVEL COMPILAND))  ;;(PUSH-END (1+ (LOOP-WEIGHTED-INCREMENT 0))  ;;    (GETF (COMPILAND-PLIST COMPILAND) 'VAR-LEVEL-COUNTS))  (MAPC #'INCREMENT-NESTING-LEVEL (COMPILAND-CHILDREN COMPILAND))  NIL)#-Elroy  ; defined in "KERNEL;FUNCTIONS"(DEFPARAMETER SI:*DEBUG-STRUCT-LOCAL-DECLARATION-TYPES*  '((ARGLIST  . :DESCRIPTIVE-ARGLIST)    (RETURN-LIST  . :VALUES)    (VALUES  . :VALUES)    (:ARGLIST  . :DESCRIPTIVE-ARGLIST)    (:RETURN-LIST . :VALUES)    (:VALUES  . :VALUES)    (FUNCTION-PARENT . :FUNCTION-PARENT)    (COMPILER:COMPILER-ARGLIST . :ARGLIST)    (SI:WRAPPER-SXHASHES . SI:WRAPPER-SXHASHES) ; from SI:MAKE-COMBINED-METHOD     (SI:COMBINED-METHOD-DERIVATION . SI:COMBINED-METHOD-DERIVATION))  "Local declaration types which are incorporated into the function debugging info.Each element is (DECLARATION . DEBUG-INFO-KEYWORD).Note that there are many synonyms among the declarations.")(DEFUN COPY-TO-PROPER-AREA (OBJECT)  ;; If the object is in a temporary area which is not the current  ;; DEFAULT-CONS-AREA, then copy it.  ;;  5/08/86 DNG - Original.  (IF (OR (SYMBOLP OBJECT)  (EQ DEFAULT-CONS-AREA QCOMPILE-TEMPORARY-AREA))      OBJECT    (SI:COPY-OBJECT-TREE OBJECT T)))(DEFUN BUILD-DEBUG-INFO (COMPILAND)  ;; Set up the debug info from the local declarations and other things.  ;; Note that the most frequently used information should be pushed last  ;; so it will be at the front of the list.  ;;  ;; 12/27/84 DNG - Save DEFUN-METHOD definitions on FILE-LOCAL-DECLARATIONS.  ;;  2/15/85 DNG - Remember function which redefines a macro or subst.  ;;  3/07/85 DNG - Don't push COMPILER-ARGLIST when redundant.  ;;  3/29/85 DNG - Fix to not mark all DEFSUBSTs with '(:NO-SIMPLE-SUBSTITUTION T).  ;;  4/09/85 DNG - Fix for EXPANSION which is an atom.  ;;  4/23/85 DNG - Save interpreted definition of small functions in the  ;;    GLOBAL package to allow later inline expansion.  ;;  7/12/85 DNG - Include LOCAL-FUNCTION-MAP in the debug info.  ;; 10/03/85 DNG - Fix to remember method definitions in COMPILE-FILE for  ;;    integration later in the file.  ;; 10/21/85 DNG - Don't record debug info when *SUPPRESS-DEBUG-INFO* is true.  ;; 11/16/85 DNG - Generate new debug-info structure for release 3.  ;;  1/09/86 DNG - New field :VARIABLES-USED-IN-LEXICAL-CLOSURES.  ;;  2/01/86 DNG - Record debug info lexical parent function;  ;;    don't suppress documentation of external functions.  ;;  3/18/86 DNG - Use new function CHECK-USED-BEFORE-DEFINED to warn about  ;;macros etc. used before defined.  ;;  3/21/86 DNG - Always use new debug info structure when compiling for VM2.  ;;  4/24/86 DNG - On VM2, use ARGS-DESC instead of ARGS-INFO.  ;;  5/08/86 DNG - Use new function COPY-TO-PROPER-AREA on debug info lists;  ;;bind FUNCTION-PROPERTY-AREA around call to MAKE-DEBUG-INFO-STRUCT.  ;;  5/22/86 DNG - Don't save interpreted defn. for symbols with QLVAL property.  ;;  6/09/86 DNG - Make sure the function name is in the proper area; remove  ;;binding of FUNCTION-PROPERTY-AREA which is no longer needed.  ;;  6/16/86 DNG - Temporary special handling of COMBINED-METHOD-DERIVATION and  ;;WRAPPER-SXHASHES debug info when cross-compiling.  ;;  6/18/86 DNG - Modify handling of EXPR-DEBUG-INFO.  ;;  7/08/86 DNG - New function BUILD-DEBUG-INFO replaces SET-UP-DEBUG-INFO.  ;;  7/22/86 DNG - Don't suppress :ARGLIST when it contains &QUOTE.  ;;  7/31/86 DNG - Macro definitions are now saved on FILE-LOCAL-DECLARATIONS  ;;here instead of in the special forms DEFMACRO and DEFSUBST.  ;;  8/04/86 DNG - Avoid using QC-TF-OUTPUT-MODE here.  ;;  8/12/86 DNG - Don't push macro definition on FILE-LOCAL-DECLATIONS when already done.  ;; 10/08/86 DNG - Don't save interpreted definition of fasload-combined methods.  ;; 10/11/86 DNG - Record hash code for DEFSUBSTs and inline functions as well as macros.  ;; 10/17/86 DNG - Use new function EQUIVALENT-FORMS-P .  ;; 10/19/86 DNG - Add support for phantom variables.  ;; 11/15/86 DNG - Fix reference to EXPRESSION-SIZE.  ;; 11/21/86 DNG - Test OPCODE property instead of QLVAL or TWO-ARGUMENT-FUNCTION.  ;;  1/06/87 DNG - Fix to not put temporary area gensyms in the :VARIABLES-USED-IN-LEXICAL-CLOSURES list.  ;;  2/18/87 DNG - Fix several problems with the *SUPPRESS-DEBUG-INFO* option.  (LET* (( SUPPRESS-DEBUG*SUPPRESS-DEBUG-INFO* ) ( SUPPRESS-ARGSSUPPRESS-DEBUG ) ( FUNCTION-TO-BE-DEFINED (COMPILAND-FUNCTION-SPEC COMPILAND)) ( EXPR-DEBUG-INFO(COMPILAND-DEBUG-INFOCOMPILAND) ) ( TRE-ARGS(COMPILAND-ARGLISTCOMPILAND) ) ( MACROFLAG(COMPILAND-MACRO-FLAGCOMPILAND) ) ( EXP(COMPILAND-DEFINITIONCOMPILAND) ) ( SUBST-FLAG(COMPILAND-SUBST-FLAGCOMPILAND) ) ( DOCUMENTATION(COMPILAND-DOCUMENTATION COMPILAND) ) ( MACROS-EXPANDED(COMPILAND-MACROS-EXPANDED COMPILAND) ) ( QUOTED-ARG  (MEMBER '&QUOTE TRE-ARGS :TEST #'EQ)  ))    (DECLARE (UNSPECIAL FUNCTION-TO-BE-DEFINED MACROS-EXPANDED))    (WHEN SUPPRESS-ARGS      (IF (AND FUNCTION-TO-BE-DEFINED (EXTERNAL-SYMBOL-P FUNCTION-TO-BE-DEFINED))  ;; always provide arglist and doc string for externally defined functions  (SETQ SUPPRESS-ARGS NIL)(SETQ DOCUMENTATION NIL))      (IF (MEMBER SUPPRESS-DEBUG '( :DOCUMENTATION DOCUMENTATION ))  ;; suppress doc string only  (SETQ SUPPRESS-ARGS NIL  SUPPRESS-DEBUG NIL)(WHEN (AND SUPPRESS-ARGS   (NOT (COMPILING-FOR-V2)) ; temporary until the implications can be considered   (NOT SUBST-FLAG) (NOT MACROFLAG)   (NOT (AND QUOTED-ARG (COMPILING-FOR-V2)))   (NULL (COMPILAND-CHILDREN COMPILAND))   (NOT (EQ (CAR-SAFE FUNCTION-TO-BE-DEFINED) :METHOD))   (NULL (INLINE-DECL FUNCTION-TO-BE-DEFINED)))  (RETURN-FROM BUILD-DEBUG-INFO    (SETF (COMPILAND-DEBUG-INFO COMPILAND) '#,(SI:MAKE-DEBUG-INFO-STRUCT :NAME NIL))))))    (WHEN (AND (NULL FUNCTION-TO-BE-DEFINED)       (NULL (ASSOC 'SYS:FUNCTION-PARENT EXPR-DEBUG-INFO)))      (LET ((PARENT (COMPILAND-PARENT COMPILAND)))(UNLESS (NULL PARENT)  (LET ((DCL (ASSOC 'SYS:FUNCTION-PARENT (COMPILAND-DEBUG-INFO PARENT))))    (UNLESS (NULL DCL)      (PUSH DCL EXPR-DEBUG-INFO))))))      ;;      ;;   --  Debug info structure for release 3  --      ;;    (IF (COMPILING-FOR-V2)(LET ( DBI      ( DEFAULT-CONS-AREA (IF (AND QC-FILE-IN-PROGRESS   (NOT QC-FILE-LOAD-FLAG))      DEFAULT-CONS-AREA    BACKGROUND-CONS-AREA) ))  (IF (LISTP EXPR-DEBUG-INFO)      (PROGN(SETQ DBI (SI:MAKE-DEBUG-INFO-STRUCT    :NAME (COPY-TO-PROPER-AREA    (COMPILAND-FUNCTION-NAME COMPILAND))))(DOLIST (DCL EXPR-DEBUG-INFO)  (LET (( DT (OR (CDR (ASSOC (CAR DCL)     SI:*DEBUG-STRUCT-LOCAL-DECLARATION-TYPES*     :TEST #'EQ)) (CAR DCL)) ))    (UNLESS (OR (SI:GET-DEBUG-INFO-FIELD DBI DT);; Don't record SXHASH because it will be different under VM2.#-Elroy (EQ (CAR DCL) 'SI:WRAPPER-SXHASHES);; Suppress redundant FUNCTION-PARENT declaration.(AND (EQ DT ':FUNCTION-PARENT)     (EQUAL (SECOND DCL) (COMPILAND-FUNCTION-NAME COMPILAND)) ))      (SI:PUT-DEBUG-INFO-FIELDDBIDT(COPY-TO-PROPER-AREA  (IF (OR #-Elroy  (AND (EQ (CAR DCL) 'SI:COMBINED-METHOD-DERIVATION)       (CONSP (CDR DCL))       (NULL (CDDR DCL))))      (SECOND DCL)    (CDR DCL))) )))))    (SETQ DBI EXPR-DEBUG-INFO) )  (UNLESS (NULL DOCUMENTATION)    (SI:PUT-DEBUG-INFO-FIELD DBI :DOCUMENTATION (COPY-TO-PROPER-AREA DOCUMENTATION)) )  (UNLESS SUPPRESS-DEBUG    ;; If we aren't going to mark this function as requiring a mapping    ;; table, provide anyway some info that the user declared it wanted one.    (WHEN (AND (COMPILAND-FLAVOR COMPILAND) (NOT (COMPILAND-SELF-MAP-NEEDED COMPILAND)))      (SI:PUT-DEBUG-INFO-FIELD DBI :SELF-FLAVOR (CAR (COMPILAND-FLAVOR COMPILAND))) )    (WHEN (AND (COMPILAND-PARENT COMPILAND)       (COMPILAND-LEXICAL-CLOSURE-FLAG COMPILAND))      (SI:PUT-DEBUG-INFO-FIELD DBI       :LEXICAL-PARENT-DEBUG-INFO       (COMPILAND-DEBUG-INFO (COMPILAND-PARENT COMPILAND))))    (LET ((LEXVARS (GETF (COMPILAND-PLIST COMPILAND) 'PHANTOM-VARS)))      ;; phantom variables are created by EXTEND-LOCAL-VARIABLES       (IF (NULL LEXVARS)  (SETQ LEXVARS (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND))(SETQ LEXVARS (APPEND (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)      LEXVARS)))      (UNLESS (NULL LEXVARS)(SI:PUT-DEBUG-INFO-FIELD  DBI  :VARIABLES-USED-IN-LEXICAL-CLOSURES  (LOOP FOR HOME IN LEXVARS COLLECT(LET ((NAME (VAR-NAME HOME)))  (IF (AND (SYMBOLP NAME) (NULL (SYMBOL-PACKAGE NAME)))      ;; Intern gensyms so the symbol won't be in the temporary area.      ;; Needed for the variables created by P1BLOCK to hold the BLOCK exit throw tag.      (INTERN (SYMBOL-NAME NAME))    NAME))) ))) )  (WHEN (COMPILAND-CHILDREN COMPILAND)    (UNLESS (EVERY #'NULL (COMPILAND-LOCAL-FUNCTION-MAP COMPILAND))      (SI:PUT-DEBUG-INFO-FIELD DBI       :INTERNAL-FEF-NAMES       (REVERSE (COMPILAND-LOCAL-FUNCTION-MAP COMPILAND)) ) )    (SI:PUT-DEBUG-INFO-FIELD DBI :INTERNAL-FEF-OFFSETS     (MAKE-LIST (LENGTH (COMPILAND-CHILDREN COMPILAND)))) )  (UNLESS SUPPRESS-DEBUG    ;; Include the local variable map.  It was built by ASSIGN-LAP-ADDRESSES.    (LET (( LOCAL-MAP (COMPILAND-LOCAL-MAP COMPILAND) ))      (DECLARE (UNSPECIAL LOCAL-MAP)(LIST LOCAL-MAP))      (UNLESS (OR (NULL LOCAL-MAP)  (EVERY #'NULL LOCAL-MAP))(SI:PUT-DEBUG-INFO-FIELD  DBI :LOCAL-MAP (COPY-TO-PROPER-AREA LOCAL-MAP)))))  (WHEN (OR (NOT SUPPRESS-ARGS) QUOTED-ARG SUBST-FLAG)    (SI:PUT-DEBUG-INFO-FIELD DBI :ARGLIST (COPY-TO-PROPER-AREA TRE-ARGS)))  ;; Include list of macros used, if any.  (WHEN (AND MACROS-EXPANDED (NOT SUPPRESS-DEBUG))    (SI:PUT-DEBUG-INFO-FIELD DBI :MACROS-EXPANDED     (MACROS-EXPANDED-DEBUG-INFO MACROS-EXPANDED)))  (LET* (( IND (INLINE-DECL FUNCTION-TO-BE-DEFINED) ) ( TRY-INLINE   ; is this a candidate for inline expansion?  (OR (EQ IND 'compiler:INLINE)      (EQ IND 'compiler:TRY-INLINE)      (AND (NEQ IND 'compiler:NOTINLINE)   (< (COMPILAND-EXPRESSION-SIZE COMPILAND) 20.)   (OR (> (OPT-SPEED OPTIMIZE-SWITCH)  (OPT-SAFETY OPTIMIZE-SWITCH))       (AND (SYMBOLP FUNCTION-TO-BE-DEFINED)    (EQ (SYMBOL-PACKAGE FUNCTION-TO-BE-DEFINED)SI:PKG-LISP-PACKAGE)    (EXTERNAL-SYMBOL-P FUNCTION-TO-BE-DEFINED)))   (NOT MACROFLAG)   (NOT (AND (SYMBOLP FUNCTION-TO-BE-DEFINED)     (GETL FUNCTION-TO-BE-DEFINED '(P1 P2 OPCODE)) ) )   (OR (NOT (LISTP FUNCTION-TO-BE-DEFINED))       (NEQ (THIRD FUNCTION-TO-BE-DEFINED) 'SI:FASLOAD-COMBINED))   ) ) ) OLD-DEF )    (WHEN (AND QC-FILE-IN-PROGRESS       (NOT QC-FILE-LOAD-FLAG)       FUNCTION-TO-BE-DEFINED        (OR TRY-INLINE   QUOTED-ARG   MACROFLAG   SUBST-FLAG   (IF (CONSP FUNCTION-TO-BE-DEFINED)       (AND (EQ (FIRST FUNCTION-TO-BE-DEFINED) :METHOD)    (NTHCDR 3 FUNCTION-TO-BE-DEFINED) )     (AND (COMPILAND-FLAVOR COMPILAND)  (COMPILAND-SELF-MAP-NEEDED COMPILAND)) )   (AND (SYMBOLP FUNCTION-TO-BE-DEFINED)(FBOUNDP FUNCTION-TO-BE-DEFINED)(SETQ OLD-DEF (SYMBOL-FUNCTION 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)    (NOT (EQUAL (ARGLIST OLD-DEF 'LISP:COMPILE)TRE-ARGS)) ) )   )       ;; 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 MACROEXPAND, MAYBE-INTEGRATE, P1ARGC,       ;; CHECK-NUMBER-OF-ARGS, or EVAL-FOR-TARGET to use later in the file.      (PUSH `(DEF ,FUNCTION-TO-BE-DEFINED . ,EXP)    FILE-LOCAL-DECLARATIONS) )    (WHEN (OR SUBST-FLAG      TRY-INLINE      SAVE-INTERP-DEF      (NOT (AND QC-FILE-IN-PROGRESS(NOT QC-FILE-LOAD-FLAG))))      (SI:PUT-DEBUG-INFO-FIELD DBI :INTERPRETED-DEFINITION       (COPY-TO-PROPER-AREA EXP)) )    (WHEN UNDO-DECLARATIONS-FLAG      (LET (( KIND (COND (MACROFLAG "macro") (QUOTED-ARG "special form") (SUBST-FLAG 'DEFSUBST) ((EQ IND 'compiler:INLINE) "inline function") (T NIL)) ))(UNLESS (NULL KIND)  (CHECK-USED-BEFORE-DEFINED FUNCTION-TO-BE-DEFINED KIND))))  (WHEN SUBST-FLAG    (LET* (( DUMMY-FORM    (MULTIPLE-VALUE-BIND ( MIN MAX REST )(SI:ARGS-DESC EXP)      (DECLARE (IGNORE MIN))      (CONS 'FOO (MAKE-LIST (+ MAX (IF REST 1 0))    :INITIAL-ELEMENT '(GENSYM)))))   ( EXPANSION (SI:SUBST-EXPAND EXP DUMMY-FORM NIL)) )   ; hard way      (UNLESS (EQUIVALENT-FORMS-P EXPANSION  (SI:SUBST-EXPAND EXP DUMMY-FORM T))   ; easy way;; If simple and thoughtful substitution give the same result;; even with the most intractable arguments,;; we need not use thoughtful substitution for this defsubst.;; Otherwise, mark it as requiring thoughtful substitution.(SI:PUT-DEBUG-INFO-FIELD DBI :NO-SIMPLE-SUBSTITUTION T) )))  ;; Compute the sxhash now, after all displacing macros have been displaced  (WHEN (AND (OR MACROFLAG SUBST-FLAG (EQ IND 'compiler:INLINE))     ;; allow hash code to be over-ridden by a DECLARE     (NULL (SI:GET-DEBUG-INFO-FIELD DBI :EXPR-SXHASH)))    (SI:PUT-DEBUG-INFO-FIELD DBI     :EXPR-SXHASH     (FUNCTION-EXPR-SXHASH (IF MACROFLAG (CDR EXP) EXP))) ))  (SETF (COMPILAND-DEBUG-INFO COMPILAND) DBI) ) ;; ;;   --  Debug info list for release 1 and 2 -- ;; #-Elroy (LET ((DEBUG-INFO NIL))   (WHEN DOCUMENTATION (PUSH `(:DOCUMENTATION ,DOCUMENTATION) DEBUG-INFO))   (DOLIST (DCL EXPR-DEBUG-INFO)     (LET (( DT (OR (CDR (ASSOC (CAR DCL)*DEBUG-INFO-LOCAL-DECLARATION-TYPES*:TEST #'EQ))    (CAR DCL)) ))       (UNLESS (OR (ASSOC DT DEBUG-INFO :TEST #'EQ)   ;; Suppress redundant FUNCTION-PARENT declaration.   (AND (EQ DT 'SYS:FUNCTION-PARENT)(EQUAL (SECOND DCL) (COMPILAND-FUNCTION-NAME COMPILAND)) )) (PUSH (IF (EQ DT (CAR DCL))   DCL (CONS DT (CDR DCL)) )       DEBUG-INFO))))   (WHEN (AND (MEMBER '&KEY TRE-ARGS)      (NOT (ASSOC 'ARGLIST DEBUG-INFO :TEST #'EQ))      (NOT SUPPRESS-ARGS))     (PUSH `(ARGLIST . ,TRE-ARGS) DEBUG-INFO))   (WHEN (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)     (PUSH `(:VARIABLES-USED-IN-LEXICAL-CLOSURES      ,(LOOP FOR HOME IN (COMPILAND-VARIABLES-USED-IN-LEXICAL-CLOSURES COMPILAND)     COLLECT (VAR-NAME HOME)) )   DEBUG-INFO) )   (WHEN (COMPILAND-CHILDREN COMPILAND)     (UNLESS (EVERY #'NULL (COMPILAND-LOCAL-FUNCTION-MAP COMPILAND))        (PUSH `(:INTERNAL-FEF-NAMES . ,(REVERSE (COMPILAND-LOCAL-FUNCTION-MAP COMPILAND)))     DEBUG-INFO))     (LET ((INTERNAL-OFFSETS (MAKE-LIST (LENGTH (COMPILAND-CHILDREN COMPILAND)))))       (PUSH `(:INTERNAL-FEF-OFFSETS . ,INTERNAL-OFFSETS) DEBUG-INFO)) )   (UNLESS SUPPRESS-DEBUG     ;; Include the local and arg maps if we have them.     ;; They were built by ASSIGN-LAP-ADDRESSES.     (WHEN (COMPILAND-LOCAL-MAP COMPILAND)       (PUSH `(compiler:LOCAL-MAP ,(COMPILAND-LOCAL-MAP COMPILAND)) DEBUG-INFO))     (WHEN (COMPILAND-ARG-MAP COMPILAND)       (PUSH `(compiler:ARG-MAP ,(COMPILAND-ARG-MAP COMPILAND)) DEBUG-INFO)) )   ;; Include list of macros used, if any.   (WHEN MACROS-EXPANDED     (PUSH `(:MACROS-EXPANDED ,(MACROS-EXPANDED-DEBUG-INFO MACROS-EXPANDED))   DEBUG-INFO))   (LET* (( IND (INLINE-DECL FUNCTION-TO-BE-DEFINED) )  ( TRY-INLINE   ; is this a candidate for inline expansion?   (OR (EQ IND 'compiler:INLINE)       (EQ IND 'compiler:TRY-INLINE)       (AND (NEQ IND 'compiler:NOTINLINE)    (< (COMPILAND-EXPRESSION-SIZE COMPILAND) 20.)    (OR (> (OPT-SPEED OPTIMIZE-SWITCH)   (OPT-SAFETY OPTIMIZE-SWITCH))(AND (SYMBOLP FUNCTION-TO-BE-DEFINED)     (EQ (SYMBOL-PACKAGE FUNCTION-TO-BE-DEFINED) SI:PKG-LISP-PACKAGE)))    (NOT MACROFLAG)    (NOT (AND (SYMBOLP FUNCTION-TO-BE-DEFINED)      (GETL FUNCTION-TO-BE-DEFINED    '(P1 P2 OPCODE)) ) )    ) ) )  OLD-DEF )     (WHEN (AND QC-FILE-IN-PROGRESS(NOT QC-FILE-LOAD-FLAG)FUNCTION-TO-BE-DEFINED (OR TRY-INLINE    QUOTED-ARG    MACROFLAG    SUBST-FLAG    (IF (CONSP FUNCTION-TO-BE-DEFINED)(AND  (EQ (FIRST FUNCTION-TO-BE-DEFINED) :METHOD)      (NTHCDR 3 FUNCTION-TO-BE-DEFINED) )      (AND (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.       (PUSH `(DEF ,FUNCTION-TO-BE-DEFINED . ,EXP)     FILE-LOCAL-DECLARATIONS) )     (IF (OR SUBST-FLAG     TRY-INLINE     SAVE-INTERP-DEF     (NOT (AND QC-FILE-IN-PROGRESS       (NOT QC-FILE-LOAD-FLAG)))) (PUSH `(INTERPRETED-DEFINITION ,EXP) DEBUG-INFO)       (UNLESS (OR (EQUAL TRE-ARGS (CDR (ASSOC 'ARGLIST DEBUG-INFO :TEST #'EQ)))   (EVERY #'ATOM TRE-ARGS)) (PUSH (CONS 'compiler:COMPILER-ARGLIST TRE-ARGS) DEBUG-INFO)))   ; for ARGLIST function     (WHEN UNDO-DECLARATIONS-FLAG      (LET (( KIND (COND (MACROFLAG "macro") (QUOTED-ARG "special form") (SUBST-FLAG 'DEFSUBST) ((EQ IND 'compiler:INLINE) "inline function") (T NIL)) ))(UNLESS (NULL KIND)  (CHECK-USED-BEFORE-DEFINED FUNCTION-TO-BE-DEFINED KIND))))     )   (when SUBST-FLAG     (LET* ((ARGS-INFO (ARGS-INFO EXP))    (DUMMY-FORM (CONS 'FOO      (MAKE-LIST (+ (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO)    (IF (LDB-TEST %ARG-DESC-EVALED-REST ARGS-INFO)1 0)) :INITIAL-ELEMENT '(GENSYM))))    (EXPANSION (SI:SUBST-EXPAND EXP DUMMY-FORM NIL)) )   ; hard way       (UNLESS (EQUIVALENT-FORMS-P EXPANSION   (SI:SUBST-EXPAND EXP DUMMY-FORM T))  ; easy way ;; If simple and thoughtful substitution give the same result ;; even with the most intractable arguments, ;; we need not use thoughtful substitution for this defsubst. ;; Otherwise, mark it as requiring thoughtful substitution. (PUSH '(:NO-SIMPLE-SUBSTITUTION T) DEBUG-INFO) )))   ;; Compute the sxhash now, after all displacing macros have been displaced   (AND (OR MACROFLAG SUBST-FLAG)(PUSH `(:EXPR-SXHASH ,(FUNCTION-EXPR-SXHASH (CDR EXP)))      DEBUG-INFO))   ;; If we aren't going to mark this function as requiring a mapping   ;; table, provide anyway some info that the user declared it wanted one.   (AND (COMPILAND-FLAVOR COMPILAND) (NOT (COMPILAND-SELF-MAP-NEEDED COMPILAND))(PUSH `(:SELF-FLAVOR ,(CAR (COMPILAND-FLAVOR COMPILAND))) DEBUG-INFO))   (SETF (COMPILAND-DEBUG-INFO COMPILAND) DEBUG-INFO) )      )))(DEFUN EXTERNAL-SYMBOL-P (OBJECT)  (AND (SYMBOLP OBJECT)       (NOT (NULL (SYMBOL-PACKAGE OBJECT)))       (MULTIPLE-VALUE-BIND ( SYMBOL CLASS )   (FIND-SYMBOL (SYMBOL-NAME OBJECT)(SYMBOL-PACKAGE OBJECT)) (DECLARE (IGNORE SYMBOL)) (EQ CLASS :EXTERNAL) )))(DEFUN EQUIVALENT-FORMS-P (A B &OPTIONAL CDR-FLAG)  ;; Compare two source forms like EQUAL except disregarding redundant PROGNs.  (DECLARE (ARGLIST A B)(OPTIMIZE (SPEED 2)(SAFETY 0)))  (COND ((EQL A B) T)((AND (ATOM A) (ATOM B)) NIL)((AND (EQ (CAR-SAFE A) 'PROGN)      (NULL (CDDR A))      (NOT CDR-FLAG)) (EQUIVALENT-FORMS-P (SECOND A) B))((AND (EQ (CAR-SAFE B) 'PROGN)      (NULL (CDDR B))      (NOT CDR-FLAG)) (EQUIVALENT-FORMS-P A (SECOND B)))((OR (ATOM A) (ATOM B)) NIL)((EQUIVALENT-FORMS-P (CAR A) (CAR B)) (IF (AND (EQ (CAR A) 'QUOTE)  (NOT CDR-FLAG))     (EQUAL (CDR A) (CDR B))   (EQUIVALENT-FORMS-P (CDR A) (CDR B) T)))(T NIL)))(DEFUN MACROS-EXPANDED-DEBUG-INFO (MACROS-EXPANDED)  ;; Given the list of macros expanded in the current function, return the value  ;; for the :MACROS-EXPANDED entry in the debug info.  ;;  8/08/86 DNG - Original.  ;;  8/28/86 DNG - Don't record hash codes when cross-compiling since the  ;;hashing algorithm is different between releases 2 and 3.  ;; 10/09/86 DNG - In QC-FILE, macro names which are lists must be enclosed in  ;;a list in the debug info.  (DECLARE (UNSPECIAL MACROS-EXPANDED))  (WHEN MACROS-EXPANDED    (LET ((MACROS-AND-SXHASHES    (MAPCAR #'(LAMBDA (MACRONAME)(LET ((HASH (AND #-Elroy (NOT (COMPILING-FOR-V2)) #+Elroy (COMPILING-FOR-V2) (EXPR-SXHASH MACRONAME))))  (IF (OR HASH (CONSP MACRONAME))      (LIST MACRONAME HASH)    MACRONAME)))    MACROS-EXPANDED)))      (IF QC-FILE-RECORD-MACROS-EXPANDED  (PROGN    ;; If in QC-FILE, put just macro names in the function    ;; but put the names and sxhashes into the file's list.    (DOLIST (M MACROS-AND-SXHASHES)      (UNLESS (MEMBER M QC-FILE-MACROS-EXPANDED :TEST #'EQUAL) (PUSH M QC-FILE-MACROS-EXPANDED)))    (MAPCAR #'(LAMBDA (MACRONAME)(IF (CONSP MACRONAME)    (LIST MACRONAME)  MACRONAME))    MACROS-EXPANDED) )MACROS-AND-SXHASHES) )))(DEFUN CHECK-USED-BEFORE-DEFINED ( NAME KIND )  ;;  3/18/86 DNG - Original. (Previously part of SETUP-DEBUG-INFO, MACRO, etc.  (UNLESS (NULL KIND)    (LET (( REF (ASSOC NAME FUNCTIONS-REFERENCED :TEST #'EQUAL) ))      (UNLESS (NULL REF)(IF (NULL (CDDR REF))    (WARN 'MACRO-USED-BEFORE-DEFINED ':IMPLAUSIBLE  "The ~A ~S was used by ~S before it was defined."  KIND NAME (CADR REF) )  (PROGN (WARN 'MACRO-USED-BEFORE-DEFINED ':IMPLAUSIBLE       "The ~A ~S was used before it was defined."       KIND NAME ) (FORMAT T "~&Referenced by:") (DOLIST ( F (CDR REF) )   (WRITE-CHAR #\SPACE)   (PRIN1 F) ) ))))))(DEFUN PRINT-FUNCTIONS-REFERENCED-BUT-NOT-DEFINED ()  "Record and print warnings about any functions referenced in compilation but not defined."  ;; 10/25/85 DNG - Improve wording of warning message.  ;;  6/04/86 DNG - Use FORMAT with ~{ instead of FORMAT:PRINT-LIST;  ;;clean up the programming style.  ;;  9/25/86 DNG - Add local function POSSIBLY.  ;; 11/19/86 DNG - Show possible names in TICL package.  ;; Discard any functions that have since become defined.  (SETQ FUNCTIONS-REFERENCED(DELETE-IF #'(LAMBDA (X) (COMPILATION-DEFINEDP (CAR X)))   (THE LIST FUNCTIONS-REFERENCED)) )  ;; Record warnings about the callers, saying that they called an undefined function.  (DOLIST (FREF FUNCTIONS-REFERENCED)    (DOLIST (CALLER (CDR FREF))      (OBJECT-OPERATION-WITH-WARNINGS (CALLER NIL T)(RECORD-WARNING 'UNDEFINED-FUNCTION-USED ':PROBABLE-ERROR NIL"The undefined function ~S was called"(CAR FREF)))))  (UNLESS (NULL FUNCTIONS-REFERENCED)    ;; Now print messages describing the undefined functions used.    (FORMAT T      "~&The following functions were referenced but do not seem to be defined:")    (WHEN (< *RETURN-STATUS* WARNINGS)      (SETQ *RETURN-STATUS* WARNINGS) )    (FLET ((POSSIBLY (F)     ;; Help the user out if they reference a function that used to     ;; be in the GLOBAL package but is now in ZLC or SYS instead.     (WHEN (SYMBOLP F)       (LET* ((NAME (SYMBOL-NAME F))      ;; Look it up in the Compiler package because it inherits      ;; from all the right places: LISP, TICL, ZLC, and SYS.      (SYM (FIND-SYMBOL NAME SI:PKG-COMPILER-PACKAGE))) (WHEN (AND SYM    (EXTERNAL-SYMBOL-P SYM)    (OR (FBOUNDP SYM) (GETL SYM '(P2 OPCODE))))   (LET ((NEW (OR (GET SYM 'SUPERSEDED)  (GET SYM 'SUPERSEDED-BY))))     (FORMAT T "~&~8TPerhaps you want ~S ?"     (IF (AND NEW (SYMBOLP NEW)) NEW SYM)))))) ))    (IF (SEND *STANDARD-OUTPUT* :OPERATION-HANDLED-P :ITEM)(DOLIST (X FUNCTIONS-REFERENCED)  (FORMAT T "~& ~S referenced by " (CAR X))  (DO ((L (CDR X) (CDR L))       (LINEL (OR (SEND *STANDARD-OUTPUT* :SEND-IF-HANDLES :SIZE-IN-CHARACTERS)  95.)))      ((NULL L))    (WHEN (> (+ (SEND *STANDARD-OUTPUT* :READ-CURSORPOS :CHARACTER)(FLATSIZE (CAR L))3)     LINEL)      (FORMAT T "~%  "))    (SEND *STANDARD-OUTPUT* :ITEM 'FUNCTION-NAME (CAR L)  "~S" (CAR L))    (WHEN (CDR L) (PRINC ", ")))  (POSSIBLY (CAR X))  (FORMAT T "~&"))      (DOLIST (X FUNCTIONS-REFERENCED)(FORMAT T "~& ~S referenced by ~{~S~^, ~}~&" (CAR X) (CDR X))(POSSIBLY (CAR X)))))));BARF is how the compiler prints an error message.;SEVERITY should be WARN for a warning (no break),;DATA for something certainly very wrong in the user's input;(something which can't be recovered from),;BARF for an inconsistency in the compiler's data structures (not the user's fault).(DEFUN BARF (EXP REASON SEVERITY)  "This is the old way to record a compiler warning.  Use COMPILER:WARN now.EXP is a piece of data to include in the message,REASON is a string, and SEVERITY is either WARN, DATA or BARF.BARF means a bug in the compiler, and DATA means a severe error in input.Both BARF and DATA enter the error handler."  ;;  1/15/86 - Set *RETURN-STATUS*.  ;;  5/28/86 - Delete obsolete use of FUNCTION-BEING-PROCESSED.  (COND ((EQ SEVERITY 'WARN) (WARN NIL NIL "~S ~A." EXP REASON))(T (WHEN (< *RETURN-STATUS* FATAL)     (SETQ *RETURN-STATUS* FATAL) )  ; in case debugger used to contine   (FERROR NIL "~S ~A" EXP REASON))));This is the modern way for the compiler to issue a warning.(DEFUN WARN (TYPE SEVERITY FORMAT-STRING &REST ARGS)  "Record and print a compiler warning.TYPE describes the particular kind of problem, such as FUNCTION-NOT-VALID.SEVERITY is a symbol in the keyword package giving a broader classification;see the source for a list of possible severities.  FORMAT-STRING and ARGSare used to print the warning."  ;;  3/13/86 DNG - Bind TARGET-PROCESSOR to HOST-PROCESSOR to prevent recursive  ;;invocation from difficulties in EVAL-FOR-TARGET.  (IF WARN-CATCHER (THROW WARN-CATCHER 'WARN))  (LET (( STATUS (COND ((MEMBER SEVERITY'(:IMPLAUSIBLE :MISSING-DECLARATION :PROBABLE-ERROR  :OBSOLETE :MACLISP :IGNORABLE-MISTAKE):TEST #'EQ)WARNINGS)       ((EQ SEVERITY ':FATAL)  FATAL)       (T  ERRORS) ) ))    (WHEN (< *RETURN-STATUS* STATUS) (SETQ *RETURN-STATUS* STATUS)) )    (LET-UNLESS-CONSTANT (( *PRINT-CASE* ':UPCASE )( TARGET-PROCESSOR HOST-PROCESSOR ))    (APPLY 'SI:RECORD-AND-PRINT-WARNING TYPE SEVERITY NIL FORMAT-STRING   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))     ;; Copy temp area data only; note that ARGS lives in PDL-AREA.     ;; on error for nonexistent package refname.     (MAPCAR #'(LAMBDA (ARG) (SI:COPY-OBJECT-TREE ARG T 12.))     ARGS))))); Severities for WARN include:; :IMPLAUSIBLE - something that is not intrinsically wrong but is probably due;  to a mistake of some sort.; :IMPOSSIBLE - something that cannot have a meaning; :IGNORABLE-MISTAKE - something that is definately illegal, but that has;       the severity of a warning instead of an error.; :MISSING-DECLARATION - free variable not declared special, usually.; :PROBABLE-ERROR - something that is an error unless you have changed something else.; :OBSOLETE - something that you shouldn't use any more; :VERY-OBSOLETE - similar only more so.; :MACLISP - something that doesn't work in Maclisp; :FATAL - something that means the function just can't be made sense of.; :ERROR - there was an error in reading or macro expansion.; :IMPLEMENTATION-LIMIT - exceeded the allowed number of something.; :BUG - the compiler has detected something wrong with itself - not the user's fault.   $   $   $   $   $   $   $   $   $   $   $   $      $      $      $      $      $      $      $                                                              $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $      $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $   $                                                   $   $   $   $   $   