LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030365. :SYSTEM-TYPE :LOGICAL :VERSION 11. :TYPE "LISP" :NAME "P1FUNS" :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 2758302722. :AUTHOR "REL3" :LENGTH-IN-BYTES 145272. :LENGTH-IN-BLOCKS 142. :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 pass 1, except for the special form   |;;;;   |  handlers and optimizers.   |;;;;   *-----------------------------------------------------------*;;; Feb. 1984 - Version 98 from MIT via LMI.;;; July 1984 - TI modifications to add new optimizations: Tail Recursion;;;  Elimination, Procedure Integration, and Value Propagation.;;;       Also removed "compiler recursively entered" messages since;;; simultaneous invokations now work ok. ;;; 07/25/84 - From MIT patch 98.33, fix a few functions which didn't;;;       know about CLI:LAMBDA, etc.;;; 07/31/84 - Fix P1VALUE handling in function (MULTIPLE-VALUE-BIND P1);;;       to prevent improper optimizations.;;; 08/06/84 - Update SPECIALP and QC-TRANSLATE-FUNCTION from MIT patch 98.44;;;; add handler for IF adapted from MIT patch 47 [IF is being;;; changed from a macro to a special form].;;; 08/06/84 - Updated CHECK-NUMBER-OF-ARGS from MIT patches 98.47 and 98.50.;;; 08/13/84 - Fix PROCESS-SPECIAL-DECLARATIONS so that variables declared;;; SPECIAL but not actually referenced do not have pointers;;; included in the FEF.  Fix P1LET to call P1V instead of P1.;;; Change QCOMPILE0 to not insert AGAIN-TAG unless TRE-ENABLE.;;; For bug 401, change FIND-TYPE to not do SPECIAL inheritance;;; when in Common Lisp mode.  Modify PRE-OPTIMIZE to not ;;; CHECK-NUMBER-OF-ARGS if COMPILATION-SPEED preferred over;;; SAFETY.  Add error message in P1SBIND for keyword used;;; as name of variable.-- D.N.G.;;; 08/14/84 - Fixed compile to file to use new version of INLINE and &QUOTE;;; functions defined in the same file.;;; 08/15/84 DNG - Included support for inline expansion of method calls ;;; in a combined method.;;; 08/22/84 DNG - Use unmapped access to SELF in combined method.;;; 08/23/84 DNG - Simplify and optimize handling of RETURNs.;;; 08/29/84 DNG - Improve dead code handling.;;; 09/06/84 DNG - Return error status from COMPILE and COMPILE-LAMBDA.;;; 09/11/84 DNG - Optimize call to DEFUN-METHOD to use FUNCALL-WITH-MAPPING-TABLE.;;; 09/13/84 DNG - Split new function SET-UP-DEBUG-INFO out of QCOMPILE0.;;; 11/01/84 DNG - Fix to not do POST-OPTIMIZE on a DONT-OPTIMIZE form.;;; 11/27/84 DNG - Pass DOCUMENTATION as an argument of SET-UP-DEBUG-INFO.;;; 12/07/84 DNG - Support cross-compilation target environment.;;; 12/26/84 DNG - Use SI:EVAL1 instead of EVAL; support value replacement of;;;   DEFCONSTANT symbols defined in the same file where used.;;; 12/27/84 DNG - Fix DEFUN-METHOD call optimization in QC-FILE.;;; 12/28/84 DNG - Modify P1, P1COND, and P1PROGN-1 to improve EXPRESSION-SIZE calculation.;;;  1/17/85 DNG - Collect timing information.;;;  1/19/85 DNG - NOTINLINE declaration prevents expansion of DEFSUBSTs.;;;  1/23/85 DNG - Make sure COLD-LOAD files only use functions defined in the cold load.;;;  1/24/85 DNG - Implement value propagation across loops.;;;  2/15/85 DNG - Re-enable use of special variable bitmap;;;;   fix for compiling function which redefines a macro or subst.;;;  2/20/85 DNG - Suppress constant folding in dead code; fix handling of ;;;   multiple :SELF-FLAVOR declarations on LOCAL-DECLARATIONS.;;;  3/28/85 DNG - Update QCOMPILE0 to record mapping table in object file.;;;  3/29/85 DNG - Dont' always flag DEFSUBSTs with NO-SIMPLE-SUBSTITUTIONS.;;;  4/12/85 DNG - Fixes to SET-UP-DEBUG-INFO and CHECK-NUMBER-OF-ARGS.;;;  4/23/85 DNG - Add handler for %BIND.;;;  5/01/85 DNG - Fix special binding bug in OPTIMIZE-TOP-LEVEL of LET.;;;    ---[ release 1.0 includes everything above this point ]---;;;  6/26/85 DNG - Minor modifications to improve speed of compilation.;;;  8/27/85 DNG - Fix handling of documentation strings in lambda expressions;;;   [SPR 596]; fix P1GO to not trap on undefined tag [SPR 501];;;;   fix P1 to not do T.R.E. on a Misc-op call.;;;  9/19/85 DNG - File QCP1 split into files P1DEFS, P1FUNS, P1HAND, and COMPILE.;;; 10/24/85 DNG - Eliminate references to QINTCMP property.;;; 12/10/85 DNG - New functions PASS1 and P1-ARG-FIXUP.;;;  1/31/86 DNG - Add checking for obsolete special variable names.;;;  2/01/86 DNG - Binding of MACRO-CONS-AREA moved from PRE-OPTIMIZE to PASS1.;;;  4/06/86 DNG - Converted from Zetalisp to Common Lisp.;;;  4/24/86 DNG - Eliminate use of ARGS-INFO for VM2.;;;  4/28/86 DNG - Changed file to use base 10.;;;  5/30/86 DNG - Eliminate use of ASSQ and MEMQ.;;;  8/08/86 DNG - Major changes to the way nested functions are compiled.;;; 10/01/86 DNG - COMPILAND-BREAKOFF-COUNT replaced by COMPILAND-CHILDREN.;;; 10/18/86 DNG - Moved ASSIGN-LAP-ADDRESSES and BREAKOFF to file COMPILE.;;; 11/24/86 DNG - Release 3 functionality freeze.;;; 12/15/86 DNG - New handling for %BIND in LET with unknown number of result values.;;; 12/16/86 DNG - Fix TAIL-RECURSION-ELIMINATION for unsharing arguments that are closed over.;;;  2/04/87 DNG - Warnings for instance variable in wrong package, missing;;;required flavors, and initial value inconsistent with type declaration.;;;  2/12/87 DNG - Fix error in FUNCTION-P .;;;  4/06/87 DNG - Update PROCEDURE-INTEGRATION and CHECK-NUMBER-OF-ARGS to fix SPR 4528.(DEFUN PASS1 ( LL BODY INITIAL-P1VALUE TOP-LEVEL-DECLARATIONS )  ;; This is the top-level routine of pass 1.  It is called by QCOMPILE1.  ;; 12/09/85 DNG - Original version of this function separated from QCOMPILE0.  ;;  2/01/86 DNG - Binding of MACRO-CONS-AREA moved from PRE-OPTIMIZE to PASS1;  ;;    binding of COMPILER-LEXICAL-PROGDESCS and COMPILER-LEXICAL-GOTAGS  ;;    moved to here from QC-TRANSLATE-FUNCTION.  ;;  6/10/86 DNG - Pass new argument TOP-LEVEL-DECLARATIONS to P1SBIND instead  ;;of LOCAL-DECLARATIONS for consistency with P1LET.  ;;  6/26/86 DNG - Move binding of var sets from here to QC-TRANSLATE-FUNCTION.  ;;  7/10/86 DNG - Eliminated COMPILER-LEXICAL-PROGDESCS and COMPILER-LEXICAL-GOTAGS;  ;;move binding of PROPAGATE-VAR-SET and SUBST-VAR-SET to QC-TRANSLATE-FUNCTION.  ;;  8/04/86 DNG - Moved binding of MACRO-CONS-AREA from here to QC-TRANSLATE-FUNCTION.  ;;  9/10/86 DNG - Add call to VARIABLE-WRAPUP.  (LET (( TLFUNINIT NIL )( FAST-ARGS-POSSIBLE T )( TLEVEL T )( BINDP NIL )( HIDDEN-ACTIVE-VARS NIL )( LEXICAL-CLOSURE-COUNT 0 )( EXPRESSION-SIZE-LIMIT (TRUNCATE MOST-POSITIVE-FIXNUM 2) )( INLINE-EXPANSIONS NIL )( OLD-VARS VARS )PASS2-LL)    ;;       ;;       Process the argument list with P1SBIND    ;;    (UNLESS (NULL LL)      (LET (( P1VALUE T )    ( TRE-OK NIL ))(SETQ PASS2-LL (P1SBIND LL 'FEF-ARG-REQ NIL NIL TOP-LEVEL-DECLARATIONS));;     ;; Take care of special arguments and optional arguments with default values.;;(WHEN (COMPILING-FOR-V2)  (SETQ BODY (P1-ARG-FIXUP BODY OLD-VARS) ))))    ;;       ;;       P1    ;;    (LET* (( P1VALUE INITIAL-P1VALUE )   ( TRE-OK INITIAL-P1VALUE )   EXP1   )      ;; Do pass 1 to single-expression body      (SETQ EXP1 (OPTIMIZE-TOP-LEVEL   (P1 (IF (NOT (NULL (CDR BODY)))   (CONS 'PROGN BODY) (CAR BODY)))))      (VARIABLE-WRAPUP VARS OLD-VARS)      (VALUES PASS2-LL EXP1) )    ) )(DEFUN P1-ARG-FIXUP (BODY OLD-VARS)  ;; This function is called by PASS1 to generate any code needed to  ;; assign default values to optional arguments or bind special arguments.  ;; [This function is new for Explorer release 3 -- previously, these things  ;; were handled by the A.D.L. and the Special Variable Bit-Map.]  ;; If a function has any optional arguments, the microcode will push the  ;; number of optionals supplied on the stack before executing the first  ;; instruction.  The code generated below tests that value to determine  ;; which arguments need to be defaulted.  Note that since the new code is  ;; being pushed onto the front of the function body, the code is being  ;; generated in reverse order from its execution order.  ;;  ;; 12/10/85 DNG - Original version.  ;;  6/10/86 DNG - Use new argument OLD-VARS.  ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE.    (LET (( OPTIONAL-ARG-COUNT 0 )( DEPENDENCY NIL )( DEFAULT-VALUES NIL )( STOP (CAR OLD-VARS) ))        ;; First, scan the argument variables to collect some information.        (DOLIST ( V VARS ) ; scan args from last to first      (WHEN (EQ V STOP) (RETURN))      (WHEN (AND (EQ (VAR-TYPE V) 'FEF-SPECIAL) ; a special variable DEFAULT-VALUES (NOT DEPENDENCY) (VARS-USED (CONS 'PROGN DEFAULT-VALUES)    (LIST (VAR-NAME V))) );; The special variable may be accessed by one of the default values.(SETQ DEPENDENCY T) )      (WHEN (EQ (VAR-KIND V) 'FEF-ARG-OPT) ; an optional argument(INCF OPTIONAL-ARG-COUNT)(LET (( INIT (VAR-INIT V) ))  (UNLESS (AND (MEMBER (CAR INIT) '(FEF-INI-NONE FEF-INI-NIL) :TEST #'EQ) ; defaults to NIL       (NULL (CDDR INIT)) ; no supplied flag     )    (PUSH (SECOND (VAR-INIT V)) DEFAULT-VALUES) ) ) )      ) ; end of DOLIST    (IF (OR (NULL (CDR DEFAULT-VALUES)); no more than one test needed    DEPENDENCY); special binding must be done in particular order;;     generate a series of IFs(LET (( COUNT OPTIONAL-ARG-COUNT )      ( NUMBER-SUPPLIED '(%POP) )) ; last use pops the count  (DOLIST ( V VARS )    (WHEN (EQ V STOP) (RETURN))    (WHEN (AND (EQ (VAR-TYPE V) 'FEF-SPECIAL)       (NEQ (VAR-KIND V) 'FEF-ARG-AUX)) ; not a supplied flag      ;; This vars table entry is used for the original argument;      ;; another entry is made by the LET* for the special variable.      (SETF (VAR-TYPE V) 'FEF-LOCAL)      (LET (( NAME (VAR-NAME V) ))(SETQ BODY      `((LET* ( &SPECIAL ( ,NAME ,NAME ))  . ,BODY)) ) ) )    (WHEN (EQ (VAR-KIND V) 'FEF-ARG-OPT)      (DECF COUNT)      (LET* (( INIT (VAR-INIT V) )     ( DEFAULT (IF (MEMBER (CAR INIT) '(FEF-INI-NONE FEF-INI-NIL) :TEST #'EQ)    NIL `(SETQ ,(VAR-LAP-ADDRESS V) ,(SECOND INIT)) ) )     ( FLAG (AND (CDDR INIT) `(SETQ ,(VAR-LAP-ADDRESS (CDDR INIT)) 'T)) ) )(WHEN (OR DEFAULT FLAG)  (PUSH `(IF (> ,NUMBER-SUPPLIED ,COUNT)     ;; Argument supplied - set flag variable     ,(MARK-P1-DONE FLAG)   ;; Else, assign default value   ,(MARK-P1-DONE DEFAULT) )BODY)  (WHEN (AND FLAG (SYMBOLP (SECOND FLAG)) )    ;; Bind special variable supplied flag    (SETQ BODY `((LET ((,(SECOND FLAG) NIL)) . ,BODY))) )  (SETQ NUMBER-SUPPLIED '(%DUP (%POP))) ; duplicate top of stack  ) ) ) ) )            ;;     else, use a DISPATCH instruction            (LET (( TEM NIL ) ; the body of the %DISPATCH form    ( ANY-INITS NIL )    ( COUNT OPTIONAL-ARG-COUNT )    ( SPECIAL-ARGS NIL ) ; list of names of special variable arguments    ( SUPPLIED-FLAGS NIL ))(DOLIST ( V VARS )  (WHEN (EQ V STOP) (RETURN))  (WHEN (EQ (VAR-TYPE V) 'FEF-SPECIAL)    (PUSH (VAR-NAME V) SPECIAL-ARGS)    ;; This vars table entry is used for the original argument;    ;; another entry is made below for the special variable.    (SETF (VAR-TYPE V) 'FEF-LOCAL) )  (WHEN (EQ (VAR-KIND V) 'FEF-ARG-OPT)    (PUSH COUNT TEM)    (DECF COUNT)    (LET (( INIT (VAR-INIT V) ))      (UNLESS (NULL (CDDR INIT))(LET (( ADDRESS (VAR-LAP-ADDRESS (CDDR INIT)) ))  (PUSH `(SETQ ,ADDRESS 'T)SUPPLIED-FLAGS)  (PUSH `(SETQ ,ADDRESS 'NIL)TEM) )(SETQ ANY-INITS T) )      (UNLESS (MEMBER (CAR INIT) '(FEF-INI-NONE FEF-INI-NIL) :TEST #'EQ) (PUSH `(SETQ ,(VAR-LAP-ADDRESS V) ,(SECOND INIT))      TEM)(SETQ ANY-INITS T) ) )    ) )(UNLESS (NULL SPECIAL-ARGS)  ;; Bind special variables to their corresponding arguments.  (LET (( BINDING-LIST NIL ))    (DOLIST ( X SPECIAL-ARGS )      (PUSH (LIST X X)    BINDING-LIST) )    (SETQ BODY  `((LET* ( &SPECIAL . ,BINDING-LIST )      . ,BODY)) ) ) )(WHEN ANY-INITS  (PUSH (MARK-P1-DONE  `(%DISPATCH (%POP) ; dispatch selector = number of optionals supplied      ,OPTIONAL-ARG-COUNT  ; maximum selector value      NIL   ; default action is to do nothing      0 . ,TEM) )  ; list of values and actionsBODY)  (DOLIST ( X SUPPLIED-FLAGS ) ; initialize all supplied flags to T    (PUSH (MARK-P1-DONE X) BODY) ) ) )            ) )    ;;   Finally, return the augmented function body for processing by P1.    BODY );Pass 1.;We expand all macros and perform source-optimizations;according to the OPTIMIZERS properties.  Internal lambdas turn into progs.;Free variables are made special and put on FREEVARS unless on INSTANCEVARS.;PROGs are converted into an internal form which contains pointers;to the VARS and GOTAGS lists of bound variables and prog tags.;All self-evaluating constants (including T and NIL) are replaced by;quote of themselves.;P1VALUE is NIL when compiling a form whose value is to be discarded.;Some macros and optimizers look at it.(PROCLAIM '(INLINE P1V))(DEFUN P1V (FORM)    (LET ((P1VALUE T))       (P1 FORM)))(DEFUN P1VAR ( SYMBOL )  ;; Gets the address of a variable by calling P1 with value propagation  ;; and DEFCONSTANT expansion inhibited.  (LET (( PROPAGATE-VAR-SET 0 ))    (P1 SYMBOL T) ) )(DEFUN P1 (ORIGINAL-FORM &OPTIONAL DONT-OPTIMIZE)  "Pass 1 compilation of a single Lisp form."  ;; 12/27/84 - Improve EXPRESSION-SIZE update.  ;; 12/28/84 - Don't increment use count of ignored variable.  ;; 12/29/84 - Do increment use count of propagated variable.  ;;  1/19/85 - NOTINLINE declaration forces call instead of   ;;machine instruction and prevents DEFSUBST expansion.  ;;  1/23/85 - Add check for cold load files.  ;;  1/24/85 - Add use of P1-WITH-ANNOTATION.  ;;  2/20/85 - Suppress constant folding on dead code.  ;;  8/27/85 - Suprress T.R.E. on function defined by Misc-op.  ;;  2/21/86 - Enable first arg of FUNCALL to be ephemeral closure.  ;;  5/07/86 - Do NIL ==> (QUOTE NIL) without consing.  ;;  6/16/86 - Check for higher level lexical variable before DEFCONSTANT to  ;;allow local shadowing with UNSPECIAL declaration. [SPR 2413]  ;;  6/20/86 - Call EXPAND-LAMBDA directly instead of using P1LAMBDA.  ;;  6/25/86 - Fix to handle (FUNCALL '#<DTP-FUNCTION ...> ...).  ;;  7/02/86 - Change handling of non-local lexical variables.  ;;  7/10/86 - Set SPECIAL-VAR-BIT in USED-VAR-SET on reference to free  ;;special variable; provide for inline expansion of local functions.  ;;  7/17/86 - Allow inline expansion of local functions.  ;;  7/25/86 - More changes for non-local variables.  ;;  8/28/86 - Call to p1argc no longer passes result of getargdesc - just pass form  ;;  9/09/86 - Increment use count of propagated BREAKOFF-FUNCTION.  ;;  9/15/86 - Call MAYBE-INTEGRATE after POST-OPTIMIZE instead of before.  ;;  9/16/86 - Record side-effects for arbitrary function calls.  ;;  9/18/86 - Use FIX-FUNCALL-EVALUATION-ORDER on FUNCALL forms.  ;;  9/20/86 - Add special handling for COMPILER-LET.  ;;  9/24/86 - Pass saved ALLVARS as second arg to FIX-FUNCALL-EVALUATION-ORDER .  ;; 10/18/86 - Permit tail recursion elimination of local functions.  ;; 11/14/86 - Don't count BLOCK-FOR-PROG in EXPRESSION-SIZE.  (LET (FORM TM NEW-SIZE NEW-FORM INDECL HANDLER)    (IF (ATOM ORIGINAL-FORM)(SETQ FORM ORIGINAL-FORM)      (PROGN(WHEN (ATOM (CAR ORIGINAL-FORM))  (SETQ INDECL (INLINE-DECL (CAR ORIGINAL-FORM))) )(SETQ FORM (PRE-OPTIMIZE ORIGINAL-FORM T (OR DONT-OPTIMIZE     (AND (EQ INDECL 'NOTINLINE)  (NULL (GETL (CAR ORIGINAL-FORM)      '(P1 P2))) ) ) ))      ) )    (SETQ NEW-SIZE (+ EXPRESSION-SIZE 1-IF-LIVE-CODE))    (COND      ((ATOM FORM)       (SETQ EXPRESSION-SIZE NEW-SIZE)       (RETURN-FROM P1 (COND ((EQ FORM 'NIL) '(QUOTE NIL)) ; avoid consing for this common special case       ((EQ FORM 'T)   '(QUOTE T))       ((OR (NOT (SYMBOLP FORM))    (KEYWORDP FORM) )(LIST 'QUOTE FORM))  ; constant other than a DEFCONSTANT       ((SETQ TM (LOOKUP-VAR FORM VARS)) ; found in table of local variables(IF (AND (NOT P1VALUE) (NOT DONT-OPTIMIZE))    ;; The value is not being used, so the reference is    ;; expected to be deleted by later optimizations.    ;; Don't increment the variable's use count and just    ;; return a dummy placeholder.    (PROGN (WHEN (NULL (VAR-USE-COUNT TM))     (SETF (VAR-USE-COUNT TM) 0))   '(QUOTE |<unused_var>|))  (PROGN ; a genuine variable reference    (SETQ NEW-FORM (VAR-LAP-ADDRESS TM))    (IF (AND (CONSP NEW-FORM)     (EQ (CAR NEW-FORM) 'LOCAL-REF))(IF (AND (LOGTEST (CDDR NEW-FORM) PROPAGATE-VAR-SET) PROPAGATE-ENABLE )    (PROGN (SETQ NEW-FORM (SECOND (VAR-INIT TM)))   (COND ((NULL NEW-FORM)  (SETQ NEW-FORM '(QUOTE NIL))) ((ATOM NEW-FORM)) ((EQ (CAR NEW-FORM) 'LOCAL-REF)  (VAR-INCREMENT-USE-COUNT (SECOND NEW-FORM))  (SETQ USED-VAR-SET(LOGIOR USED-VAR-SET (CDDR NEW-FORM)))) ((EQ (CAR NEW-FORM) 'BREAKOFF-FUNCTION)  (INCF (COMPILAND-USE-COUNT (SECOND NEW-FORM)))) (T (DEBUG-ASSERT (NO-SIDE-EFFECTS-P NEW-FORM))))   (WHEN (NULL (VAR-USE-COUNT TM))     (SETF (VAR-USE-COUNT TM) 0))   (RETURN-FROM P1 NEW-FORM))  (PROGN    (UNLESS (OR (NULL *VAR-LEVEL-COUNTS*)(ZEROP 1-IF-LIVE-CODE))      (LET (( VC (VAR-COMPILAND TM) ))(UNLESS (EQ VC *CURRENT-COMPILAND*)  (INCF (NTH (COMPILAND-NESTING-LEVEL VC)     *VAR-LEVEL-COUNTS*)(LOOP-WEIGHTED-INCREMENT *LOOP-LEVEL*)    ))))    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (CDDR NEW-FORM)))    ))      (WHEN (SYMBOLP NEW-FORM)(WHEN (OR (EQ (VAR-KIND TM) 'FEF-ARG-FREE)  (NEQ (VAR-COMPILAND TM) *CURRENT-COMPILAND*))  (UNLESS (ZEROP 1-IF-LIVE-CODE)    (PUSHNEW NEW-FORM FREEVARS :TEST 'EQ) ) )(UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))))    (VAR-INCREMENT-USE-COUNT TM)    NEW-FORM) ))       ((AND SELF-FLAVOR-DECLARATION     (TRY-REF-SELF FORM)))       ((BLOCK CONSTANT?  (AND (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)       (NOT DONT-OPTIMIZE)       (LET ( CONST ) (COND ((SETQ CONST (ASSOC FORM FILE-CONSTANTS-LIST :TEST #'EQ))(SETQ TM (CDR CONST)) )       ((AND (SETQ CONST (GET-FOR-TARGET FORM 'SYSTEM-CONSTANT))     (NOT (EQ CONST 'COMPILER:QC-PROCESS-INITIALIZE))     ;; DEFCONSTANT, not a machine-dependent constant     (BOUNDP-FOR-TARGET FORM))(SETQ TM (SYMEVAL-FOR-TARGET FORM)) )       (T (RETURN-FROM CONSTANT? NIL)) ) (OR (NUMBERP TM)     (SYMBOLP TM)     (CHARACTERP TM) ) ) ) )(LIST 'QUOTE TM))       (T (MAKESPECIAL FORM)  (UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)    (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))  FORM))))      ((EQ (CAR FORM) 'QUOTE)       (SETQ EXPRESSION-SIZE NEW-SIZE)       (RETURN-FROM P1  FORM))      ;; Certain constructs must be checked for here      ;; so we can call P1 recursively without setting TLEVEL to NIL.      ((NOT (ATOM (CAR FORM)))       (LET ((FCTN (CAR FORM))) (UNLESS (SYMBOLP (CAR FCTN))   (WARN 'BAD-FUNCTION-CALLED ':IMPOSSIBLE "There appears to be a call to a function whose CAR is ~S." (CAR FCTN))) (COND ((MEMBER (CAR FCTN)'(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA CLI:LAMBDA NAMED-LAMBDA):TEST #'EQ);;added extra arg to expand lambda to indicate that args not processed(RETURN-FROM P1  (P1 (EXPAND-LAMBDA FCTN (CDR FORM) NIL nil)) ))       (T ;; Old Maclisp evaluated functions.(WARN 'EXPRESSION-AS-FUNCTION ':VERY-OBSOLETE      "The expression ~S is used as a function; use FUNCALL."      (CAR FORM))(RETURN-FROM P1 (P1 `(FUNCALL . ,FORM)))))))      ((NOT (SYMBOLP (CAR FORM)))       (WARN 'BAD-FUNCTION-CALLED ':IMPOSSIBLE     "~S is used as a function to be called." (CAR FORM))       (RETURN-FROM P1 (P1 (CONS 'PROGN (CDR FORM)))))      )    (SETQ NEW-FORM  (COND    ((SETQ TM (ASSOC (CAR FORM) LOCAL-FUNCTIONS :TEST #'EQ))     ;; local function defined by FLET or LABELS     (SETQ NEW-FORM (P1EVARGS FORM))     (SETQ EXPRESSION-SIZE NEW-SIZE)     (OR (AND (EQ (COMPILAND-DEFINITION *CURRENT-COMPILAND*)  (THIRD TM)) ; function is calling itself      (CONSP P1VALUE)      (LET ((X (ASSOC (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)      P1VALUE :TEST #'EQ)))(AND X ; this is a tail recursive call     (MEMBER X TRE-OK :TEST #'EQ) ; no special bindings in effect     (<= (OPT-SAFETY OPTIMIZE-SWITCH) (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))     (SECOND X) ; loop-back tag provided     (NOT DONT-OPTIMIZE)     (TAIL-RECURSION-ELIMINATION       NEW-FORM (SECOND X) (THIRD X)) ))) `(FUNCALL ,(REF-LOCAL-FUNCTION-VAR (SECOND TM))   . ,(CDR NEW-FORM)) ))    #-Elroy ; PROG is a macro in release 3    ((MEMBER (CAR FORM) '(PROG PROG*) :TEST #'EQ)     (P1PROG FORM))    ((MEMBER (CAR FORM) '(LET LET*) :TEST #'EQ)     (P1-WITH-ANNOTATION FORM #'P1LET 'UNKNOWN DONT-OPTIMIZE))    ((EQ (CAR FORM) 'BLOCK)     (P1-WITH-ANNOTATION FORM #'P1BLOCK 'UNKNOWN DONT-OPTIMIZE))    ((EQ (CAR FORM) 'TAGBODY)     (P1-WITH-ANNOTATION FORM #'P1TAGBODY 'NULL DONT-OPTIMIZE))    ((EQ (CAR FORM) '%POP) FORM );P2 specially checks for this    ((EQ (CAR FORM) 'COMPILER-LET)     ;; handled specially here so that the result will not be re-optimized     ;; after the bindings are un-done.     (RETURN-FROM P1       (SI:EVAL1 `(COMPILER-LET ,(SECOND FORM)    (P1 '(PROGN . ,(CDDR FORM))) ))))    ((SETQ TLEVEL NIL))    ((EQ (CAR FORM) 'COND)     (P1-WITH-ANNOTATION FORM #'P1COND 'UNKNOWN DONT-OPTIMIZE))    ;; Check for functions with special P1 handlers.    ((AND (SETQ HANDLER (GET (CAR FORM) 'P1))  (OR (NEQ INDECL 'NOTINLINE)      (NOT (MEMBER HANDLER '(P1SIMPLE P1-DOWNWARD-FUNARG     P1-DOWNWARD-FUNARG-DESTRUCTIVE) :TEST #'EQ))) )     (UNLESS (MEMBER (CAR FORM)     '( PROGN IGNORE P1-HAS-BEEN-DONE RETURN-FROM %BLOCK-BODY        #+compiler:debug P1-ALREADY-DONE ; this one is obsolete 9/19/86COMPILER-LET BLOCK-FOR-PROG)     :TEST #'EQ)       (SETQ EXPRESSION-SIZE NEW-SIZE) )     (FUNCALL HANDLER FORM))    ((AND ALLOW-VARIABLES-IN-FUNCTION-POSITION-SWITCH  (LOOKUP-VAR (CAR FORM) VARS)  (NULL (FUNCTION-P (CAR FORM))))     (WARN 'EXPRESSION-AS-FUNCTION ':VERY-OBSOLETE   "The variable ~S is used in function position; use FUNCALL."   (CAR FORM))     (RETURN-FROM P1 (P1 (CONS 'FUNCALL FORM))))    ((EQ (CAR FORM) 'FUNCALL)     (LET (( F (LET (( P1VALUE 'DOWNWARD-ONLY )) (P1 (SECOND FORM)) )))       (COND ((AND (CONSP F)   (MEMBER (FIRST F) '(QUOTE FUNCTION) :TEST #'EQ)   (NOT DONT-OPTIMIZE)   (OR (SYMBOLP (SECOND F))       (CONSP (SECOND F)))   (FUNCTIONP (SECOND F)) )      ;; (FUNCALL #'f a b) ==> (f a b)      ;; (FUNCALL #'(LAMBDA ...) a b) ==> ((LAMBDA ...) a b)      (RETURN-FROM P1 (P1 (CONS (SECOND F) (CDDR FORM)))))     (T (SETQ EXPRESSION-SIZE NEW-SIZE)(PROG1 (LET ((SAVE-ALLVARS ALLVARS)) (FIX-FUNCALL-EVALUATION-ORDER   (CONS 'FUNCALL (P1EVARGS (CONS F (CDDR FORM))))   SAVE-ALLVARS))       (ARBITRARY-SIDE-EFFECTS))) )))    ( T  ; general function     (SETQ EXPRESSION-SIZE NEW-SIZE)     (UNLESS (NULL (CDR FORM))       (SETQ FORM (P1ARGC FORM ) ))     (COND       ((AND (CONSP P1VALUE)  ; still has initial value from QCOMPILE1     (SETQ TM (ASSOC (CAR FORM) P1VALUE :TEST #'EQ)); this is a tail recursive call     (EQL (OPT-SAFETY OPTIMIZE-SWITCH) 0) ; user permits optimizing     (MEMBER TM TRE-OK :TEST #'EQ) ; no special bindings in effect     TRE-ENABLE      (NOT DONT-OPTIMIZE)     (NOT (GETL (CAR FORM)'(P2  #-Elroy compiler:QINTCMP ; temporary  #+Elroy OPCODE))) ; not expanded by pass 2     (TAIL-RECURSION-ELIMINATION       FORM (SECOND TM) (THIRD TM) ) ))       ((AND (SETQ TM (ASSOC (CAR FORM) INLINE-EXPANSIONS :TEST #'EQ))     (NEQ (FIRST TM) (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) );; This is a recursive call to a function which we are;;   currently in the process of expanding inline.;; Abort the inline expansion.(THROW (SECOND TM) 'RECURSIVE) ); the CATCH is in function PROCEDURE-INTEGRATION       ((AND (EQ INDECL 'NOTINLINE)     (EQ (CAR ORIGINAL-FORM) (CAR FORM)) )(SETQ DONT-OPTIMIZE INDECL)(ARBITRARY-SIDE-EFFECTS)(IF (AND (GET (CAR FORM) 'P2) (FUNCTIONP (CAR FORM)) )    `(FUNCALL (FUNCTION ,(CAR FORM)) . ,(CDR FORM))  FORM) )       (T (SETQ HANDLER 'P1ARGC)  FORM) )    )))    ;; Apply post-optimizations    (UNLESS (OR DONT-OPTIMIZE;; Don't optimize dead code -- not only to avoid;; wasting time, but because constant folding could;; get an argument type error which would be irrelevant.(ZEROP 1-IF-LIVE-CODE))      (SETQ TM (POST-OPTIMIZE NEW-FORM))      (WHEN (AND (MEMBER HANDLER '(P1ARGC P1-DOWNWARD-FUNARG P1-DOWNWARD-FUNARG-DESTRUCTIVE) :TEST #'EQ) (OR (EQ TM NEW-FORM)     (NOT (TRIVIAL-FORM-P TM))));; possibility of inline expansion of the called function(SETQ FORM (IF (OR (EQ (CAR ORIGINAL-FORM) (CAR TM))   (EQ INDECL 'INLINE))       (MAYBE-INTEGRATE (CAR TM) (CDR TM) NIL INDECL)     (MAYBE-INTEGRATE (CAR TM) (CDR TM)) ))(UNLESS (NULL FORM)  (SETQ TM (POST-OPTIMIZE FORM))  (SETQ HANDLER NIL)))      (WHEN (NEQ NEW-FORM TM)(SETQ HANDLER NIL) ; don't update var sets below(SETQ NEW-FORM TM)(WHEN (TRIVIAL-FORM-P NEW-FORM)  ;; optimized down to just a constant or variable --  ;; count its size as only 1  (SETQ EXPRESSION-SIZE NEW-SIZE)      ) ) )    (WHEN (AND INLINE-EXPANSIONS       (> EXPRESSION-SIZE EXPRESSION-SIZE-LIMIT) )      ;; inline expansion of function call has become too big       ;;  to be desirable -- abort back to CATCH in      ;;  function PROCEDURE-INTEGRATION      (THROW (SECOND (FIRST INLINE-EXPANSIONS)) 'SIZE) )    (WHEN (EQ HANDLER 'P1ARGC)      (BLOCK USE-SPECIAL(UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)  (WHEN (FUNCTION-WITHOUT-SIDE-EFFECTS-P (FIRST NEW-FORM))    (RETURN-FROM USE-SPECIAL))  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET GLOBAL-SIDE-EFFECTS)))(UNLESS (OR (LOGTEST DATA-ALTERATION-BIT ALTERED-VAR-SET)    (FUNCTION-WITHOUT-SIDE-EFFECTS-P (FIRST NEW-FORM)))  (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET GLOBAL-SIDE-EFFECTS)))))    (WHEN (AND SI:FILE-IN-COLD-LOAD ; Current file has attribute COLD-LOAD:T       (CONSP NEW-FORM)       (NOT (ZEROP 1-IF-LIVE-CODE))       (NOT (AND (SYMBOLP (FIRST NEW-FORM)) (GETL (FIRST NEW-FORM) '(P2 OPCODE)))) )      (CHECK-COLD (FIRST NEW-FORM)) )    (RETURN-FROM P1 NEW-FORM)    ));Given an entry on VARS, increment the usage count.(DEFUN VAR-INCREMENT-USE-COUNT (VAR)  (LET (( COUNT (VAR-USE-COUNT VAR) ))    (WHEN (NULL COUNT) (SETQ COUNT 0))    (SETF (VAR-USE-COUNT VAR) (+ COUNT 1-IF-LIVE-CODE)) ) )(DEFUN POST-OPTIMIZE ( ORIGINAL-FORM ); Apply bottom-up optimizations  ;; 10/29/85 DNG - Allow the property to be an atom.  ;;  5/12/86 DNG - Allow optimizer to be list of function and parameters.  ;; 10/17/86 DNG - Second value returned from optimizer causes escape from loop.  (LET ((FORM ORIGINAL-FORM))    (LOOP WHILE  (AND (NOT (ATOM FORM))       (LET (( PROP (GET (CAR FORM) 'POST-OPTIMIZERS) )) (COND ((NULL PROP) NIL)       ((ATOM PROP)(MULTIPLE-VALUE-BIND (NEW QUIT)    (FUNCALL PROP FORM)  (AND (NOT (EQ FORM NEW))       (PROGN (SETQ FORM NEW)      (NOT QUIT)))))       (T(DOLIST (OPT PROP NIL)  (UNLESS (EQ FORM      (SETQ FORM    (IF (ATOM OPT)(FUNCALL OPT FORM)      (APPLY (FIRST OPT) FORM (REST OPT)))))    (RETURN T) ))))))  )    FORM ))(DEFUN P1-DEAD-FORMS ( FORMS )  ;; Process a list of forms which appeared in the source but will  ;;  never be executed.  ;; 08/27/84 DNG - Original version.  ;; 08/09/86 DNG - Deleted binding of SPECIALFLAG, which doesn't exist anymore.  ;; 09/16/86 DNG - DEAD-CODE-SKIPPED flag not needed anymore.  (UNLESS (NULL FORMS)    (IF (OR (< (OPT-SAFETY OPTIMIZE-SWITCH)       (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))    (NOT (NULL INLINE-EXPANSIONS)) );; Don't bother looking at the dead code.NIL ;;(SETQ DEAD-CODE-SKIPPED T)      ;; Else look at the dead code to get any error messages.      (LET (( P1VALUE NIL ); not using values    ( 1-IF-LIVE-CODE 0 ); increment use counts by zero    ( INLINE-ENABLE NIL ); don't optimize     ;; Protect the following variables from alteration    ( ALTERED-VAR-SET ALTERED-VAR-SET )    ( USED-VAR-SET USED-VAR-SET )    ( PROPAGATE-VAR-SET 0 )    ( SUBST-VAR-SET 0 )    ( ALLVARS ALLVARS )    ( FREEVARS FREEVARS )    ( MACROS-EXPANDED MACROS-EXPANDED )    ( BINDP BINDP )    ( TRE-OK NIL ) )(DOLIST ( FORM FORMS ); for each form  (P1 FORM); look at it to get any error messages    ) ) ) )  NIL );; Function RECORD-VARIABLES-USED-IN-LEXICAL-CLOSURES deleted 8/11/86;; Functions TRY-REF-LEXICAL-VAR and TRY-REF-LEXICAL-HOME deleted 8/8/86 (DEFUN REF-LOCAL-FUNCTION-VAR (HOME)  ;; Given a var that holds a local function, return an address form to be  ;; used in pass 2 and perform any necessary bookkeeping.  ;;  7/10/86 DNG - Original.  ;;  8/26/86 DNG - Save declared type of local function in COMPILAND-PLIST.  (LET (( INIT (SECOND (VAR-INIT HOME)) ))    (IF (EQ (CAR-SAFE INIT) 'BREAKOFF-FUNCTION);; When not a closure, just refer directly to the FEF instead of the variable.(LET ((COMPILAND (SECOND INIT)))  (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (COMPILAND-USED-VAR-SET COMPILAND)))  (SETQ ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET (COMPILAND-ALTERED-VAR-SET COMPILAND)))  (IF (EQ (COMPILAND-PARENT COMPILAND) *CURRENT-COMPILAND*)      ;; Calling a function :INTERNAL to the current one.      ;; The variable is marked as having appeared so that no "unused local      ;;  function" warning is given, but don't increment the use count so      ;;  that the variable can be optimized away.      (PROGN (WHEN (NULL (VAR-USE-COUNT HOME))       (SETF (VAR-USE-COUNT HOME) 0))     (LET ((TYPE (GETF (VAR-DECLARATIONS HOME) 'TYPE 'T)))       (UNLESS (EQ TYPE T) ;; save the type declaration for EXPR-TYPE-P to use. (SETF (GETF (COMPILAND-PLIST COMPILAND) 'TYPE)       TYPE)))     INIT)    ;; When calling a function :INTERNAL to a higher level FEF, the variable    ;; that holds it cannot be optimized away because then it would not appear    ;; in the quote-vector and QLAPP would have no place to install the function.    (PROGN (VAR-INCREMENT-USE-COUNT HOME)   `(FUNCTION ,(COMPILAND-FUNCTION-SPEC COMPILAND)))))      (PROGN(IF (EQ (CAR-SAFE INIT) 'LEXICAL-CLOSURE)    (LET ((COMPILAND (SECOND INIT)))      (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (COMPILAND-USED-VAR-SET COMPILAND))    ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET (COMPILAND-ALTERED-VAR-SET COMPILAND))))  (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET  SPECIAL-VAR-BIT)))(VAR-INCREMENT-USE-COUNT HOME)(LET (( ADDRESS (VAR-LAP-ADDRESS HOME) ))  (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (CDDR ADDRESS)))  ADDRESS)))));The SELF-FLAVOR-DECLARATION variable looks like;(flavor-name specials instance-var-names...);and describes the flavor we are compiling access to instance vars of.(DEFUN TRY-REF-SELF (VAR)  ;;  7/08/86 - Comment out use of SELF-TYPE-KNOWN; set SPECIAL-VAR-BIT in USED-VAR-SET.  (WHEN (MEMBER VAR (CDDR SELF-FLAVOR-DECLARATION) :TEST #'EQ)    (UNLESS (LOGTEST SPECIAL-VAR-BIT USED-VAR-SET)      (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))    ;; If variable is explicitly declared special, use that instead.    (COND ((LET ( #| (BARF-SPECIAL-LIST NIL) |# )     (SPECIALP VAR))   (OR (MEMBER VAR (CADR SELF-FLAVOR-DECLARATION) :TEST #'EQ)       (WARN 'SPECIAL-VARIABLE-IS-UNSPECIAL-INSTANCE-VARIABLE ':IMPOSSIBLE     "The special variable ~S is an instance variable of ~Sbut was not mentioned in a :SPECIAL-INSTANCE-VARIABLES in that flavor.This function will not execute correctly unless the DEFFLAVOR is fixed."     VAR (CAR SELF-FLAVOR-DECLARATION)))   (MAKESPECIAL VAR)   VAR)      #|  ((EQ SELF-TYPE-KNOWN (CAR SELF-FLAVOR-DECLARATION))   ;; If we know what the type of SELF is, then we don't   ;;  need to use the mapping table; tell SI:FLAVOR-VAR-SELF-REF-INDEX   ;;  to return an unmapped pointer.  [The T at the end is   ;;  just to make the length not 3 for compatibility with the   ;;  old version of SI:FLAVOR-VAR-SELF-REF-INDEX.]   `(SELF-REF ,SELF-TYPE-KNOWN ,VAR :UNMAPPED T) )    |#  ;; Otherwise, use the mapping table.  (T   (SETQ SELF-REFERENCES-PRESENT T)   `(SELF-REF ,(CAR SELF-FLAVOR-DECLARATION) ,VAR)))))(DEFUN INLINE-DECL ( FSPEC )   ;; Given a function spec, return:   ;;  'INLINE if the function has been declared INLINE   ;;  'NOTINLINE if the function has been declared NOTINLINE   ;;  NIL if there is no INLINE or NOTINLINE declaration.  ;; 7/18/84 - fixed to not blow up on :INTERNAL function -- D.N.G.  ;; 6/26/85 - Modifed to be faster.  (DECLARE (OPTIMIZE SPEED))  (LET (( TEMP (LET (( IN-DECLS INLINE-DECLARATIONS )) (COND ((NULL IN-DECLS) NIL)       ((ATOM FSPEC) (ASSOC FSPEC IN-DECLS :TEST #'EQ))       (T (ASSOC FSPEC IN-DECLS :TEST #'EQUAL)) )) ))    (COND (TEMP (CDR TEMP)) ; local declaration found  ((SYMBOLP FSPEC) (GET FSPEC 'INLINE)) ; global declaration  ((ATOM FSPEC) NIL) ; this really shouldn't be possible    ;; Special case for (:INTERNAL ...) function because not all    ;; of the information is in place to be able to process their    ;; function spec yet.  Besides, if it was going to be expanded    ;; that would have had to have been done before now.  ((EQ (CAR FSPEC) ':INTERNAL) NIL)  (T (SI:FUNCTION-SPEC-GET FSPEC 'INLINE)) ; general case  ) ) )(DEFUN INTERPRETED-DEF ( FCTN )  ;; Given a function (not a function spec), return the interpreted  ;; definition, or NIL if there isn't one.  ;; 11/02/85 - Permit use of new debug-info structure.  ;;  3/06/86 - Fix to not find debug-info list twice.  ;;  3/13/86 - Argument to DBI-INTERPRETED-DEFINITION is DBI instead of FEF.  (COND ((CONSP FCTN) FCTN)((TYPEP FCTN 'COMPILED-FUNCTION) (LET (( DEBUG-INFO (FUNCTION-DEBUGGING-INFO FCTN) ))   (IF (LISTP DEBUG-INFO)       (SECOND (ASSOC 'INTERPRETED-DEFINITION DEBUG-INFO :TEST #'EQ))     (SI:DBI-INTERPRETED-DEFINITION DEBUG-INFO) ) ) )(T NIL) ) )(DEFUN FUNCTION-EXPR-SXHASH (FUNCTION)  ;;  9/08/86 DNG - If we need to compute the hash code for a FEF, store it back  ;;into the debug-info so it won't have to be computed again.  (LET ((FUNCTION (IF (AND (CONSP FUNCTION) (EQ (CAR FUNCTION) 'MACRO))      (CDR FUNCTION)    FUNCTION)))    (COND ((TYPEP FUNCTION 'COMPILED-FUNCTION)   (LET (( DEBUG-INFO (FUNCTION-DEBUGGING-INFO FUNCTION) ))     (OR (SI:GET-DEBUG-INFO-FIELD DEBUG-INFO ':EXPR-SXHASH) (LET ((IDEF (INTERPRETED-DEF FUNCTION)))   (AND IDEF#+Elroy(LET ((HASH (FUNCTION-EXPR-SXHASH IDEF))      (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)      (SYS:%INHIBIT-READ-ONLY T))  (SETF (SI:GET-DEBUG-INFO-FIELD DEBUG-INFO ':EXPR-SXHASH)HASH))#-Elroy(FUNCTION-EXPR-SXHASH IDEF))))))  ((NULL FUNCTION) NIL)  ((SYMBOLP FUNCTION) (EXPR-SXHASH FUNCTION))  ((CONSP FUNCTION)   (SXHASH (SI:LAMBDA-EXP-ARGS-AND-BODY FUNCTION))))))       ;This must follow FUNCTION-EXPR-SXHASH or else FASLOAD bombs out;loading this file for the first time.(DEFUN EXPR-SXHASH (FUNCTION-SPEC)  "Return the SXHASH of the interpreted definition of FUNCTION-SPEC.If FUNCTION-SPEC's definition is compiled, the interpreted definitionor its SXHASH may be remembered in the debugging info.If neither is remembered, the value is NIL."  (FUNCTION-EXPR-SXHASH (DECLARED-DEFINITION FUNCTION-SPEC)))(DEFUN OPTIMIZE-TOP-LEVEL ( FORM )  ;; Perform optimization on the top level function body form  ;; returned by P1 to QCOMPILE0.  ;; 2/15/85 - Original version.  ;; 2/19/85 - Don't make FEF-ARG-AUX after a FEF-ARG-INTERNAL-AUX.  ;; 3/07/85 - Allow FORM to be a symbol.  ;; 5/01/85 - Just optimize LET*, not LET, because it was doing the wrong  ;;       thing on code like: (LET ((A NIL)(B A)) ...)  ;;       P1LET will optimize simple LETs into a LET* anyway.  ;;10/30/85 - Eliminate use of S-V-BITMAP for release 3.  (WHEN (ATOM FORM)    (RETURN-FROM OPTIMIZE-TOP-LEVEL FORM) )  (WHEN (EQ (FIRST FORM) 'THE-EXPR)    (SETQ OPTIMIZE-SWITCH (EXPR-OPTIMIZE FORM)) ; for P2, PEEP, and QLAPP    (RETURN-FROM OPTIMIZE-TOP-LEVEL      (OPTIMIZE-TOP-LEVEL (EXPR-FORM FORM)) ) )  (WHEN (AND (EQ (FIRST FORM) 'LET*)     (NOT (COMPILING-FOR-V2))     TRE-ENABLE ; not needed otherwise   )    (LET (( VARS (FOURTH FORM) ))      (DOLIST ( VAR (SECOND FORM) ); each variable in lambda list(LET (( V (LOOKUP-VAR (IF (ATOM VAR) VAR (FIRST VAR))VARS) ))  (WHEN (EQ (FIRST (VAR-INIT V)) 'FEF-INI-COMP-C)    (LET (( INIT-FORM (SECOND (VAR-INIT V)) ))      (COND ((AND (EQ (VAR-KIND V) 'FEF-ARG-INTERNAL-AUX)  (EQ (VAR-TYPE V) 'FEF-SPECIAL)  (EQ INIT-FORM 'NIL)  )     ;; Change internal binding of special variable so that     ;; the special variable bitmap will be used instead of     ;; code.     (SETF (VAR-KIND V) 'FEF-ARG-AUX)     (SETF (VAR-INIT V) '(FEF-INI-NIL NIL)) )    ((AND (EQ (FIRST FORM) 'LET*)  (NOT (CONSTANTP INIT-FORM)))     ;; In case the initialization expression might     ;; reference a special variable which will be re-bound     ;; later in this lambda list, stop optimizing.     (RETURN)) ; return from DOLIST    ) ) )  (UNLESS (LAP-ARGP V)    ;; To keep COMPUTE-S-V-MAP happy, quit when internal variable found.    (RETURN) ) ; return from DOLIST  ) ) ) )  FORM );Expand functions that want keyword arguments.;Make them take &REST args instead, and give them code to look up the keywords.#| (COMMENT  ;starting from this(DEFUN FOO (X &REST Y &KEY MUMBLE &OPTIONAL (BLETCH T BLETCHP) &AUX BAZZZ)   BODY);We create this:(DEFUN FOO (X &REST Y &AUX (MUMBLE KEYWORD-GARBAGE) (BLETCH T) BLETCHP)  (SI:STORE-KEYWORD-ARG-VALUES (%STACK-FRAME-POINTER)       Y '(:MUMBLE :BLETCH)       NIL;T if &ALLOW-OTHER-KEYS       2);1st 2 keywords required.  (AND (EQ MUMBLE KEYWORD-GARBAGE) (FERROR ...))  ((LAMBDA (&AUX BAZZZ)     BODY)))) ;end COMMENT |#;Given a lambda which uses &KEY, return an equivalent one;which does not use &KEY.  It takes a &REST arg instead;(though if the original one had a rest arg, it uses that one).;If there is no ARGLIST declaration for this function, we make one;so that the user is still told that the function wants keyword args.(DEFUN EXPAND-KEYED-LAMBDA (LAMBDA-EXP)  ;; 12/11/85 DNG - Fix to not lose local SPECIAL declaration for keyword args.  ;;  6/18/86 DNG - Remove obsolete code for creating ARGLIST declaration [now  ;;handled in SET-UP-DEBUG-INFO]; avoid using the macro WHEN in the  ;;expansion.  ;;  8/08/86 DNG - Deleted use of LEXICAL-VAR-P.  ;;  9/03/86 DNG - Fix handling of type and IGNORE declarations for keyword args.  ;;  9/16/86 DNG - Don't use KEYWORD-GARBAGE when initial value is a FUNCTION form.  ;; 10/11/86 DNG - Don't use KEYWORD-GARBAGE when initial value is a special variable.  ;; 10/17/86 DNG - Give warning on non-keyword keyword, eg (&key ((wrong nm))).  (LET (LAMBDA-LIST BODYMAYBE-REST-ARG KEYCHECKSPOSITIONAL-ARGS AUXVARS REST-ARG POSITIONAL-ARG-NAMES KEYKEYS KEYNAMES KEYINITS KEYFLAGS ALLOW-OTHER-KEYSPSEUDO-KEYNAMES DECLS)    (DECLARE (LIST POSITIONAL-ARGS AUXVARS POSITIONAL-ARG-NAMES   KEYKEYS KEYNAMES KEYINITS KEYFLAGS))    (COND ((MEMBER (CAR LAMBDA-EXP) '(GLOBAL:LAMBDA CLI:LAMBDA) :TEST #'EQ)   (SETQ LAMBDA-LIST (CADR LAMBDA-EXP) BODY (CDDR LAMBDA-EXP)))  (T   (SETQ LAMBDA-LIST (CADDR LAMBDA-EXP) BODY (CDDDR LAMBDA-EXP))))    (MULTIPLE-VALUE-SETQ (POSITIONAL-ARGS NIL AUXVARS REST-ARG POSITIONAL-ARG-NAMES  KEYKEYS KEYNAMES NIL KEYINITS KEYFLAGS ALLOW-OTHER-KEYS) (DECODE-KEYWORD-ARGLIST LAMBDA-LIST))    (DOLIST (KK KEYKEYS)      (UNLESS (KEYWORDP KK)(WARN 'KEYKEYS ':IMPLAUSIBLE      "~S should be a keyword symbol in ~S" KK (MEMBER '&KEY LAMBDA-LIST))))    (SETQ PSEUDO-KEYNAMES (COPY-LIST KEYNAMES))    ;; For each keyword arg, decide whether we need to init it to KEYWORD-GARBAGE    ;; and check explicitly whether that has been overridden.    ;; If the arg is optional    ;; and the initial value is a constant, we can really init it to that.    ;; Otherwise we create a dummy variable initialized to KEYWORD-GARBAGE;    ;; after all keywords are decoded, we bind the intended variable, in sequence.    ;; However a var that can shadow something (including any special var)    ;; must always be replaced with a dummy.    (DO ((KIS KEYINITS (CDR KIS)) (KNS KEYNAMES (CDR KNS)) (PKNS PSEUDO-KEYNAMES (CDR PKNS)) (KFS KEYFLAGS (CDR KFS)))((NULL KNS))      (LET ((KEYNAME (CAR KNS)) PSEUDO-KEYNAME    (KEYFLAG (CAR KFS)) (KEYINIT (CAR KIS)))(UNLESS (AND (NULL KEYFLAG)     (OR (CONSTANTP KEYINIT) (EQ (CAR-SAFE KEYINIT) 'FUNCTION) (AND (SYMBOLP KEYINIT)      (NULL KEYCHECKS)      (BOUNDP KEYINIT)))     (NOT (LOOKUP-VAR KEYNAME VARS))     (NOT (SPECIALP KEYNAME)))  (SETF (CAR KIS) 'SI:KEYWORD-GARBAGE)  (SETQ PSEUDO-KEYNAME (GENSYM))  (SETF (CAR PKNS) PSEUDO-KEYNAME)  (PUSH `(,KEYNAME  (COND ((EQ ,PSEUDO-KEYNAME SI:KEYWORD-GARBAGE) ,KEYINIT)(T ,(AND KEYFLAG `(SETQ ,KEYFLAG T))   ,PSEUDO-KEYNAME)))KEYCHECKS))))    (SETQ KEYFLAGS (REMOVE NIL (THE LIST KEYFLAGS) :TEST #'EQ))    (SETQ KEYCHECKS (NREVERSE KEYCHECKS))    (WHEN (EQ (CAR-SAFE (FIRST BODY)) 'DECLARE)      ;; Note: we don't need the generality of PARSE-BODY here because QCOMPILE1      ;; has already extracted the documentation and collected all declarations      ;; into a single DECLARE form.      (SETQ DECLS (REST (FIRST BODY)))      (SETQ BODY (REST BODY)))    ;; If the user didn't ask for a rest arg, make one for the    ;; outer function anyway.    (UNLESS REST-ARG      (SETQ REST-ARG (GENSYM)    MAYBE-REST-ARG (LIST '&REST REST-ARG)))    `(LAMBDA (,@POSITIONAL-ARGS ,@MAYBE-REST-ARG)       (DECLARE (.ARG.) . ,DECLS)       (LET* (,@(MAPCAR #'LIST PSEUDO-KEYNAMES KEYINITS)      ,@KEYFLAGS) (DECLARE (.AUX.) . ,DECLS) (AND ,REST-ARG   (SI:STORE-KEYWORD-ARG-VALUES (%STACK-FRAME-POINTER),REST-ARG ',KEYKEYS,ALLOW-OTHER-KEYS(VARIABLE-LOCATION ,(CAR PSEUDO-KEYNAMES)))) (LET* ,(NCONC KEYCHECKS AUXVARS)   (DECLARE (.AUX.) . ,DECLS)   . ,BODY)))))(DEFUN FUNCTION-P (X)  ;;  7/09/86 DNG - Add special handling for :INTERNAL functions to avoid  ;;error in SI:INTERNAL-FUNCTION-SPEC-HANDLER when called from  ;;FUNCTION-REFERENCED.  Removed obsolete (GETL X '(*EXPR ARGDESC)).  ;;  2/12/87 DNG - Fix to avoid error on reference to FUNCTION-SPEC-HANDLER. [SPR 3434]  (COND ((SYMBOLP X) (FBOUNDP X))((ATOM X) NIL)((EQ (CAR X) ':INTERNAL) (FUNCTION-P (SECOND X)))((FDEFINEDP X) T)(T (LET ((HANDLER (GET (CAR X) 'SYS:FUNCTION-SPEC-HANDLER)))     (AND HANDLER  (FUNCALL HANDLER 'SI:COMPILER-FDEFINEDP X))))))(DEFUN MSPL2 (X)  ;;  7/02/86 DNG - Don't give warning on a free reference to a variable which  ;;is globally special but locally declared UNSPECIAL.  This is so  ;;that (LET ((FOO FOO)) (DECLARE (UNSPECIAL FOO))...) is permitted  ;;as a binding of a local variable whose initial value is a special  ;;variable having the same name.  In other words, local UNSPECIAL  ;;declarations affect variable bindings but not free references.  ;;  9/30/86 DNG - Remove use of BARF-SPECIAL-LIST.  ;;  2/04/87 DNG - Special warnings for instance variable in wrong package and  ;;missing required flavors.  (WHEN (LET ( #| (BARF-SPECIAL-LIST THIS-FUNCTION-BARF-SPECIAL-LIST) |# )  (NOT (SPECIALP X T)))    ;; Here unless this variable was either 1) declared special, or    ;; 2) already used free in this function.    (UNLESS INHIBIT-SPECIAL-WARNINGS      (LET ((IVAR (FIND X (CDDR SELF-FLAVOR-DECLARATION) :TEST #'STRING-EQUAL)))(IF IVAR    (WARN 'FREE-VARIABLE ':MISSING-DECLARATION  "The variable ~S is used free; assumed special.But maybe you wanted the instance variable ~S ?" X IVAR)  (LET ((UNDEF (AND SELF-FLAVOR-DECLARATION    (SI:FLAVOR-UNDEFINED-COMPONENTS (CAR SELF-FLAVOR-DECLARATION)))))    (DECLARE (LIST UNDEF))    (IF UNDEF(PROGN (SETQ UNDEF (REMOVE-DUPLICATES UNDEF :TEST #'EQ))       (IF (CDR UNDEF)   (WARN 'FREE-VARIABLE ':MISSING-DECLARATION "The variable ~S is used free; assumed special.Note: flavor ~S requires flavors ~S which aren't defined yet." X (CAR SELF-FLAVOR-DECLARATION) UNDEF) (WARN 'FREE-VARIABLE ':MISSING-DECLARATION       "The variable ~S is used free; assumed special.Note: flavor ~S requires flavor ~S which isn't defined yet."       X (CAR SELF-FLAVOR-DECLARATION) (FIRST UNDEF))))      (WARN 'FREE-VARIABLE ':MISSING-DECLARATION    "The variable ~S is used free; assumed special." X))))))    (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))      #|      (UNLESS (OR INHIBIT-SPECIAL-WARNINGS ;Free var in a DEFSUBST shouldn't be special for whole file.  (MEMBER X BARF-SPECIAL-LIST :TEST #'EQ))(PUSH X BARF-SPECIAL-LIST))      |#      (PUSH X THIS-FUNCTION-BARF-SPECIAL-LIST))    (WHEN (LOOKUP-VAR X ALLVARS)      (WARN 'FREE-VARIABLE ':IMPOSSIBLE    " ~S was previously assumed local; you will lose!" X))))(DEFUN MAKESPECIAL (X)  ;;  1/31/86 - Added call to CHECK-FOR-OBSOLETE-VARIABLE.  (MSPL2 X)  (UNLESS (MEMBER X FREEVARS :TEST #'EQ)    (PUSH X FREEVARS)    (CHECK-FOR-OBSOLETE-VARIABLE X) )  T);Given a form, apply optimizations and expand macros until no more is possible;(at the top level).  Also apply style-checkers to the supplied input;but not to generated output.  This function is also in charge of checking for;too few or too many arguments so that this happens before optimizers are applied.; (This function used to be called OPTIMIZE, but the name was changed because ;  OPTIMIZE is now a global symbol.);; 1/17/85 - Allow STYLE-CHECKER property to be a list of functions.;; 1/19/85 - Add optional DONT-OPTIMIZE argument to enable suppressing;;     optimization and DEFSUBST expansion but still allow macro ;;     expansion and style checking.;; 6/26/85 - Save time by not calling LAMBDA-MACRO-EXPAND on an atom.;; 2/01/86 - Binding of MACRO-CONS-AREA moved from PRE-OPTIMIZE to PASS1.;; 2/19/86 - Use EVAL-FOR-TARGET for interpreting macro expanders to enable;;     referencing target-dependent definitions.;; 2/24/86 - Crude hack to avoid style-checking macro expansions.;; 5/12/86 DNG - Allow OPTIMIZERS property to be an atom.;; 6/21/86 DNG - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.;;10/17/86 DNG - Watch out for macros that RPLACA instead of consing a new form.(DEFUN PRE-OPTIMIZE (FORM CHECK-STYLE &OPTIONAL DONT-OPTIMIZE &AUX OPTIMIZATIONS-BEGUN-FLAG)  (DECLARE (OPTIMIZE SPEED))  (DO ((FN)) ((ATOM FORM)) ;Do until no more expansions possible    (IF (ATOM (CAR FORM))(SETQ FN (CAR FORM))      (PROGN(LET ((DEFAULT-CONS-AREA MACRO-CONS-AREA))  (SETQ FN (LAMBDA-MACRO-EXPAND (CAR FORM))))(OR (EQ FN (CAR FORM)) (SETQ FORM (CONS FN (CDR FORM)))) ) )    (UNLESS (OR OPTIMIZATIONS-BEGUN-FLAG(> (- (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)      (OPT-SAFETY OPTIMIZE-SWITCH))   1 ))      ;; Check for too few or too many arguments      (CHECK-NUMBER-OF-ARGS FORM FN))    ;; If function is redefined locally with FLET,    ;; don't use things that reflect its global definition.    (WHEN (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)      (RETURN))    (UNLESS OPTIMIZATIONS-BEGUN-FLAG      ;; Do style checking      (AND CHECK-STYLE (NULL INHIBIT-STYLE-WARNINGS-SWITCH)   (COND ((ATOM FN)  (WHEN (SYMBOLP FN)    (LET (( TM (GET FN 'STYLE-CHECKER) ))      (IF TM  (WHEN    ;; The following test attempts to distinguish original code    ;; which we want to style check from macro expansions which    ;; we don't want to check.    (OR (AND (EQ (CDR *LAST-ADDRESS-READ*) (%REGION-NUMBER FORM))     (PLUSP (%POINTER-DIFFERENCE *LAST-ADDRESS-READ* FORM)))#+compiler:debug(NOT *DEFAULT-DEFS-FROM-HOST*)   ; merciless option#+Elroy(EQ *PACKAGE* KERNEL-PACKAGE))    (IF (ATOM TM)(FUNCALL TM FORM)      (DOLIST ( HANDLER TM )(FUNCALL HANDLER FORM) )))#+Elroy(WHEN (AND COMPILING-COMMON-LISP   (EQ (SYMBOL-PACKAGE FN) ZETALISP-PACKAGE)   OBSOLETE-FUNCTION-WARNING-SWITCH   *WARN-OF-SUPERSEDED-FUNCTIONS-P*)  (WARN 'ZETALISP-PACKAGE :OBSOLETE"~S is a Zetalisp function which is considered obsolete in Common Lisp."FN) ))))) ((NOT RUN-IN-MACLISP-SWITCH)) ((MEMBER (CAR FN) '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA) :TEST #'EQ)  ;; Note: CLI:LAMBDA and CLI:NAMED-LAMBDA deliberately  ;;  omitted since this is only for MacLisp.  (LAMBDA-STYLE FN)) #-Elroy ((MEMBER (CAR FN) '(CURRY-BEFORE CURRY-AFTER) :TEST #'EQ)  (WARN 'NOT-IN-MACLISP ':MACLISP "~S does not work in Maclisp." (CAR FN)))      )))    ;; Apply optimizations    (OR (AND (SYMBOLP FN)     (NOT DONT-OPTIMIZE)     (LET (( TM (GET FN 'OPTIMIZERS) ))       (COND ((NULL TM) NIL)     ((CONSP TM)      (DOLIST (OPT TM)(UNLESS (EQ FORM (SETQ FORM (FUNCALL OPT FORM)))  ;; Optimizer changed something, don't do macros this pass  (RETURN (SETQ OPTIMIZATIONS-BEGUN-FLAG T)))))     (T (UNLESS (EQ FORM (SETQ FORM (FUNCALL TM FORM)))  ;; Optimizer changed something, don't do macros this pass  (SETQ OPTIMIZATIONS-BEGUN-FLAG T))))))(AND DONT-OPTIMIZE     ;; Expand macros but not DEFSUBSTs     (NOT (EQ (CAR-SAFE (DECLARED-DEFINITION (CAR FORM))) 'MACRO))     (RETURN) );; No optimizer did anything => try expanding macros.(WARN-ON-ERRORS ('MACRO-EXPANSION-ERROR "Error expanding macro ~S:" FN)  ;; This LET returns T if we expand something.  (LET ((OLD-FORM FORM)(DEFAULT-CONS-AREA MACRO-CONS-AREA)(RECORD-MACROS-EXPANDED T)(*EVALHOOK* #'EVAL-FOR-TARGET))    (SETQ FORM (MACROEXPAND-1 FORM *LOCAL-ENVIRONMENT*))    (IF (AND (EQ FORM OLD-FORM)     (EQ (CAR FORM) (CAR OLD-FORM)));; Stop looping, no expansions apply(RETURN)      T)));; The body of the WARN-ON-ERRORS either does RETURN or returns T.;; So if we get here, there was an error inside it.(RETURN (SETQ FORM `(ERROR-MACRO-EXPANDING ',FORM))))    ;; Only do style checking the first time around    (SETQ CHECK-STYLE NIL)    ;; If macro expansion has been done, optimize the expansion.    (SETQ DONT-OPTIMIZE NIL) )  ;; Result is FORM  FORM)(DEFPROP ERROR-MACRO-EXPANDING T :ERROR-REPORTER)(DEFUN ERROR-MACRO-EXPANDING (FORM)  (FERROR NIL "The form ~S which appeared at this pointwas not compiled due to an error in macro expansion." FORM));Given a non-atomic form issue any warnings required because of wrong number of arguments.;This function should never get an error and never warn about;anything that gets warned about elsewhere.(DEFUN CHECK-NUMBER-OF-ARGS (FORM &OPTIONAL FUNCTION)  ;; 08/06/84 DNG - Updated CHECK-NUMBER-OF-ARGS from MIT patches 98.47 and 98.50  ;;    which adds checking of keyword arguments.  ;;  4/10/85 DNG - Modified to save time by not calling the ARGLIST function  ;;    unless necessary and appropriate.  Commented out the  ;;    keyword argument checking because it was wrong.  ;;  4/15/85 DNG - Don't use ARGLIST property of %MAKE-EXPLICIT-STACK-LIST because  ;;    the compiler uses it in a way that does not exactly match the  ;;    machine instruction declared in DEFMIC.  ;;  6/26/85 DNG - For speed, avoid calling LAMBDA-MACRO-EXPAND unless really  ;;    necessary, and expand GET-FOR-TARGET inline.  ;;  7/08/85 DNG - Modify BAD-ARGUMENTS so that it is not a closure in order to  ;;    avoid a bug in microcode version 200.  ;; 10/26/85 DNG - For release 3, use GET-OPCODES instead of QINTCMP property.  ;;  4/24/86 DNG - For VM2, use ARGS-DESC instead of %ARGS-INFO; eliminate  ;;checking of Q-ARGS-PROP since it is never defined anywhere.  ;;  5/08/86 DNG - Fix VM2 handling for &REST arg.  ;;  5/15/86 DNG - Fix VM2 handling for macros.  ;;  8/09/86 DNG - Modified to use DECLARED-DEFINITION.  ;;  8/18/86 DNG - Another fix for VM2 macros; delete unused TABODY tag TOP.  ;;  8/29/86 DNG - Use argument list from function type declarations.  ;; 10/17/86 DNG - Removed use of ARGDESC property; special handling for LIST and LIST* instead.  ;;  4/06/87 DNG - Abort inline expansion that needs a macro that is not defined now. [SPR 4528]  (DECLARE (OPTIMIZE (SPEED 2)) (INLINE GET-FOR-TARGET))  (IF (NULL FUNCTION) (SETQ FUNCTION (CAR FORM)))  (LET* (TEM ARGLIST NARGS (MIN NIL) (MAX 0) #-Elroy (ARGS-INFO NIL) (LOCALP NIL) (FN FUNCTION))    (AND (SYMBOLP FN) ;; If FN is a name defined lexically by FLET or LABELS, use its definition. (SETQ LOCALP (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)) (SETQ FN (CADDR LOCALP)))    (FLET ((BAD-ARGUMENTS (NAME MSG &OPTIONAL (TYPE 'WRONG-NUMBER-OF-ARGUMENTS)        (SEVERITY ':PROBABLE-ERROR))      (WARN TYPE SEVERITY (IF (ASSOC NAME LOCAL-FUNCTIONS :TEST #'EQ)       "Locally defined function ~S called with ~A"    "Function ~S called with ~A")    NAME MSG)))      (UNLESS (ATOM FN)(SETQ FN (LAMBDA-MACRO-EXPAND FN)) )      (COND ((CONSP FN)     (IF (MEMBER (FIRST FN) SI:FUNCTION-START-SYMBOLS :TEST #'EQ) (SETQ ARGLIST (ARGLIST FN T))       (RETURN-FROM CHECK-NUMBER-OF-ARGS))     #-Elroy     (UNLESS (CONSP ARGLIST)       (RETURN-FROM CHECK-NUMBER-OF-ARGS)))    ((NOT (SYMBOLP FN))     ;;Unknown type, don't check     (RETURN-FROM CHECK-NUMBER-OF-ARGS))    ((SETQ TEM (DECLARED-DEFINITION FN))     (WHEN (EQ (CAR-SAFE TEM) 'MACRO)       ;; Don't check macros here because the expander function does it.       (RETURN-FROM CHECK-NUMBER-OF-ARGS))     #-Elroy     (SETQ ARGS-INFO (%ARGS-INFO TEM))     #+Elroy     (LET ( REST )       (MULTIPLE-VALUE-SETQ (MIN MAX REST)    (SI:ARGS-DESC TEM))       (WHEN REST (SETQ MAX MOST-POSITIVE-FIXNUM)))     #|  commented out for efficiency until the keyword     argument checking which uses it is fixed. (SETQ ARGLIST (IGNORE-ERRORS (LET ((TEM (ARGLIST FN T)))   (IF (EQ TEM 'MACRO) TEM (ARGLIST FN 'NIL))))) |#     )    ((AND (SETQ TEM (GET-OPCODES FN))  (SETQ MAX (OPCODE-NARGS TEM))))    ((AND INLINE-EXPANSIONS  (DOLIST (X (FOURTH (FIRST INLINE-EXPANSIONS)) NIL)    ;; :MACROS-EXPANDED list -- elements either NAME or (NAME . HASH)    (WHEN (IF (CONSP X) (EQ (CAR X) FN) (EQ X FN))      (RETURN T))))     ;; a macro which is not currently defined; have to abort the inline expansion.     (THROW (SECOND (FIRST INLINE-EXPANSIONS)) 'UNDEFINED-MACRO)) ; to CATCH in PROCEDURE-INTEGRATION    ((AND (SETQ TEM (OR (GET-FOR-TARGET FN 'ARGLIST) ; arglist from DEF-MISC-OP (GETDECL FN 'FUNCTION-ARG-TYPES))) ; from  DECLARE-FTYPE  (NOT (GET FN 'P2)) )   ; P2 not doing something funny     (SETQ ARGLIST TEM))    (T ;;No information available     (RETURN-FROM CHECK-NUMBER-OF-ARGS)))      (COND #-Elroy    ( ARGS-INFO     (SETQ MIN (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO)   MAX (IF (LOGTEST (LOGIOR %ARG-DESC-QUOTED-REST %ARG-DESC-EVALED-REST)    ARGS-INFO)   MOST-POSITIVE-FIXNUM (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO))) )    ( ARGLIST     (DOLIST (X ARGLIST)       (COND ((EQ X '&OPTIONAL) (SETQ MIN MAX))     ((OR (EQ X '&REST) (EQ X '&BODY) (EQ X '&KEY))      (UNLESS MIN (SETQ MIN MAX))      (SETQ MAX MOST-POSITIVE-FIXNUM)      (RETURN))     ((EQ X '&AUX) (RETURN))     ((MEMBER X LAMBDA-LIST-KEYWORDS :TEST #'EQ))     (T (INCF MAX))))     ) )      (SETQ NARGS (LENGTH (CDR FORM)));Now that we know it's not a macro      (COND ((< NARGS (OR MIN MAX))     (BAD-ARGUMENTS (CAR FORM) "too few arguments."))    ((> NARGS MAX)     (UNLESS (MEMBER (CAR FORM) '(LIST LIST* %MAKE-EXPLICIT-STACK-LIST %MAKE-EXPLICIT-STACK-LIST*))       (BAD-ARGUMENTS (CAR FORM) "too many arguments.")))    #|  -- commented out because it is wrong.  -- D.N.G. 4/12/85    ((CONSP ARGLIST)     (LET* ((KEYARGS (MEMQ '&KEY ARGLIST))    KEYFORM )       (WHEN (AND KEYARGS (SETQ KEYFORM (NTHCDR (OR MAX MIN) (CDR FORM)))) (IF (ODDP (LENGTH KEYFORM))     (BAD-ARGUMENTS (CAR FORM) "no value supplied for some keyword argument.")   (LET ((ALLOW-OTHER-KEYS (OR (MEMQ '&ALLOW-OTHER-KEYS ARGLIST)       (GETF KEYFORM ':ALLOW-OTHER-KEYS))))     (LOOP FOR KEY IN KEYFORM BY #'CDDR   WHEN (EQ (CAR-SAFE KEY) 'QUOTE) DO (SETQ KEY (CADR KEY))   DOING (COND ((KEYWORDP KEY)(UNLESS  (OR ALLOW-OTHER-KEYS      (DOLIST (X KEYARGS)(IF (MEMQ X LAMBDA-LIST-KEYWORDS)    NIL  (IF     (IF (CONSP X)(IF (CONSP (CAR X))    ;; ((:frob foo) bar)    (EQ KEY (CAAR X))  ;; (foo bar)  (STRING= KEY (CAR X)))      ;; foo      (STRING= KEY X))    (RETURN T)))))  (BAD-ARGUMENTS (CAR FORM)    (FORMAT NIL "the unrecognized keyword ~S"    KEY))))       ((CONSTANTP KEY)(BAD-ARGUMENTS (CAR FORM)  (FORMAT NIL "~S appearing where a keyword should" KEY)))   )))))))    |#     ))))(DEFUN CHECK-COLD ( FNAME )  ;; If the file being compiled has the :COLD-LOAD attribute,  ;; issue a warning message if the function with name FNAME  ;; is defined in a file which does not have the :COLD-LOAD attribute.  ;; This provides protection against trying to call something  ;; which won't be loaded yet.  ;; 1/23/85 - Original version.  ;; 2/19/85 - Temporarily suppress error in QC-FILE unless extra SAFETY.  ;; 1/31/86 - Check :COMPILATION-DEFINED pathname also.  ;; 3/14/86 - Use GET-FOR-TARGET instead of GET.  ;; 6/30/86 - Fix to not error when the pathname property is a string instead of a pathname instance.  ;;11/24/86 - Suppress warning when INHIBIT-STYLE-WARNINGS-SWITCH is true.  (DECLARE (INLINE GET-FOR-TARGET))  (WHEN (AND SI:FILE-IN-COLD-LOAD ; current file has COLD-LOAD attribute     (SYMBOLP FNAME)     ;; Temporarily suppress this check for a QC-FILE with     ;; default SAFETY; this is to avoid large numbers of errors     ;; during system builds until we are ready to clean them up.     (OR (NOT UNDO-DECLARATIONS-FLAG) (> (OPT-SAFETY OPTIMIZE-SWITCH) 1) )     #+compiler:debug     (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR) (NOT QC-FILE-IN-PROGRESS) (NOT (NULL FASD-STREAM)) )     (NULL INHIBIT-STYLE-WARNINGS-SWITCH))    (LET (( PATHNAME (GET-FOR-TARGET FNAME :SOURCE-FILE-NAME) ))      (UNLESS (ATOM PATHNAME)(SETQ PATHNAME (FIRST (LAST (ASSOC 'DEFUN PATHNAME :TEST #'EQ)))) )      ;; PATHNAME is where FNAME was defined.      (UNLESS (OR (NULL PATHNAME) ; undefined functions get another message  (MEMBER PATHNAME COLD-LOAD-FILES :TEST #'EQ)   (LET (( COMPILE-PATHNAME (GET-FOR-TARGET FNAME ':COMPILATION-DEFINED) ))    (AND (NEQ COMPILE-PATHNAME PATHNAME) (MEMBER COMPILE-PATHNAME COLD-LOAD-FILES :TEST #'EQ)))  (NOT (INSTANCEP PATHNAME)));; Not among the files that we already know are in the cold load.(LET (( PLIST (AND PATHNAME (SEND PATHNAME :PROPERTY-LIST)) ))  (IF (GETF PLIST :COLD-LOAD) ; file has COLD-LOAD attribute      ;; File is ok; add it to the list.      (LET (( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))(PUSH PATHNAME COLD-LOAD-FILES) )    ;; Check for some special cases of functions that are given    ;; temporary default definitions in SYS:SYS;LTOP.    (UNLESS (MEMBER FNAME '(FERROR CERROR SI:UNENCAPSULATE-FUNCTION-SPEC  FS:MAKE-PATHNAME-INTERNAL FS:MAKE-FASLOAD-PATHNAME  TV:WHO-LINE-FILE-STATE-SHEET  ;; the following are re-defined after the cold load  SPECIAL UNSPECIAL PROCLAIM)    :TEST #'EQ)      ;; Else, give warning.      (WARN ':COLD-LOAD ':PROBABLE-ERROR    "Warning: ~S is not available in the cold load."    FNAME) )    ) ) ) ) )  NIL );Pass 1 processing for a call to an ordinary function (ordinary, at least, for pass 1).;Processing consists of P1'ing all evaluated arguments, but not the quoted ones.;DESC is used to determine which is which.;In addition, &FUNCTIONAL arguments are broken off and separately compiled.;We process the args by copying the arglist, and rplaca'ing each arg by P1 of itself if needed.(DEFUN P1ARGC (FORM)  ;;  2/21/86 - &FUNCTIONAL implies downward funarg.  ;;  8/28/86 CLM - Changed way in which &QUOTE'd args are handled; they are  ;;                now quoted here rather than waiting until P2ARGC.  ;;  9/22/86 DNG - Bind P1VALUE to SINGLE-VALUE for use by VALUES-OPT.  ;; 11/15/86 DNG - Use %P-LDB-OFFSET instead of %P-LDB so forwarding is followed;  ;;use LET* instead of PROG.  (LET* ((ARGS-LEFT (COPY-LIST (CDR FORM))) (ARG-P1-RESULTS ARGS-LEFT) (P1VALUE 'SINGLE-VALUE) (FCTN (CAR FORM)) (def (declared-definition fctn)))    (if (or (consp def)    (and (typep def 'compiled-function) #+elroy (not (zerop (%p-ldb-offset si:%%fef-header-special-form def 0))) #-elroy (logtest (logior %arg-desc-quoted-rest %arg-desc-fef-quote-hair)  (%args-info def)) ) )(let (quote-flag functional-flag rest-flag)  ;;step through the arglist checking for quoted args  ;;creating a new arglist to return as result of p1argc  (do ((arglist (arglist def 'compile) (cdr arglist)))      ((atom args-left)       (if (null args-left)   (return-from p1argc (cons fctn arg-p1-results)) (progn   (warn ':impossible 'non-nil-end-of-form "the form ~s ends in a non-nil atomic cdr." form)   (if (atom arg-p1-results)       (return-from p1argc (list fctn))     (setf (cdr (last arg-p1-results)) nil)     (return-from p1argc (cons fctn arg-p1-results))))) )      (if (member (car arglist) lambda-list-keywords :test #'eq)(cond  ((eq (car arglist) '&quote)   (setq quote-flag t))  ((eq (car arglist) '&functional)   (setq functional-flag t))  ((eq (car arglist) '&rest)   (setq rest-flag t))  ((eq (car arglist) '&eval)   (setq quote-flag nil)) )      ;;else not a llk      (progn(cond  (quote-flag   (if rest-flag       (cond ((eql (length args-left) 1)      ;;just quote it      (setf (car args-left)    `(quote ,(car args-left))))     ((eq args-left arg-p1-results)      ;;all are rest args      (return-from p1argc(cons 'apply (cons `(function ,fctn)   (list `',arg-p1-results)))))     (t (setf (car args-left) `(quote ,(list (car args-left))))(setf (cdr (cadar args-left)) (cdr args-left))(setf (cdr args-left) nil)(return-from p1argc  (cons 'apply (cons `(function ,fctn)     arg-p1-results)))) )     (setf (car args-left)   `(quote ,(car args-left)))     ) )  (functional-flag   (setf (car args-left) (let* (( p1value 'downward-only )( tm (p1 (car args-left))))   (if (quotep tm) ;look for '(lambda...)       (p1function tm)     tm)) )   (setq functional-flag nil))  (t (setf (car args-left)    (p1 (car args-left)))     ) ) (setq args-left (cdr args-left)) )  ) )  )      ;;else follow the old way      (do ((arglist args-left (cdr arglist)))  ((atom arglist)   (if (null args-left)       (return-from p1argc (cons fctn arg-p1-results))     (progn       (warn ':impossible 'non-nil-end-of-form     "the form ~s ends in a non-nil atomic cdr."     form)       (if (atom arg-p1-results)   (return-from p1argc (list fctn)) (setf (cdr (last arg-p1-results)) nil) (return-from p1argc (cons fctn arg-p1-results)))))) ;;process the arguments (setf (car args-left)      (p1 (car args-left)) )(setq args-left (cdr args-left)))  )  )  )(DEFUN TAIL-RECURSION-ELIMINATION ( FORM AGAIN-TAG ARGLIST );; Performs tail recursion elimination by replacing function call FORM;; with a PSETQ to assign the argument variables in ARGLIST and a;; GO to AGAIN-TAG.;; Returns the expression to substitute for FORM, or NIL if unsuccessful.  ;;  2/22/86 DNG - Unshare variables used in lexical closures before looping back.  ;;  8/28/86 CLM - Add arg to call to match-args-with-values to indicate that args  ;;                have already been processed - i.e., quoted args have been quoted  ;; 12/16/86 DNG - Fix for unsharing arguments that are closed over. (LET ( ARGVARS TEMP )    (COND ( (SETQ TEMP (ASSOC AGAIN-TAG GOTAGS :TEST #'EQ)) ; tag is defined    (SETQ ARGVARS (PROGDESC-VARS (GOTAG-PROGDESC TEMP))) )       ; ARGVARS is the value of VARS saved just after the arguments were       ;     entered; this is used to bypass any shadowing of the argument names.  ( (SETQ TEMP (ASSOC (FIRST FORM) INLINE-EXPANSIONS :TEST #'EQUAL))      ; within an inline expansion; throw back to function      ;  PROCEDURE-INTEGRATION to tell it we need a tag to      ;  loop back to.    (THROW (SECOND TEMP) 'TAIL-RECURSION-ELIMINATION) )  ( T (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL) ) )   (MULTIPLE-VALUE-BIND ( PSETQVARS ; list of variable names for PSETQ of args  PSETQVALS ; list of value expressions for PSETQ  SETQVARS  ; list of defaulted variables for SETQ  SETQVALS  ; list of default values for SETQ  ERROR NIL )  (MATCH-ARGS-WITH-VALUES ARGLIST (REST FORM) t)    (WHEN ERROR (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL))    ;; Now build the replacement form, being careful to apply P1 in the    ;; correct order and in the correct lexical context.    (LET ( (SETQ-FORM NIL) PSETQ-FORM )      (LET (( VARS ARGVARS ))      (LABELS (( BUILD-PSETQ ( NAMES VALS )(IF (NULL NAMES)    NIL    (LIST* (P1SETVAR (FIRST NAMES))   (FIRST VALS)   (BUILD-PSETQ (REST NAMES) (REST VALS))   ) )))(SETQ PSETQ-FORM      (POST-OPTIMIZE (CONS 'INTERNAL-PSETQ   (BUILD-PSETQ (NREVERSE PSETQVARS)(NREVERSE PSETQVALS))))) )      (WHEN SETQVARS(SETQ SETQ-FORM      (LET ((SETQLIST NIL))(LOOP WHILE SETQVARS      DO (PROGN (PUSH (P1V (POP SETQVALS)) SETQLIST)(PUSH (P1SETVAR (POP SETQVARS)) SETQLIST) ))(CONS 'SETQ SETQLIST) ) ) ) )      (LET (( RETURN-FORM (LIST (P1 `(GO ,AGAIN-TAG))) ))(UNLESS (NULL (COMPILAND-CHILDREN *CURRENT-COMPILAND*))  (LET ((ARGS-USED-IN-CLOSURES NIL))    (DOLIST (V ARGVARS)      (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ)(PUSH (VAR-LAP-ADDRESS V) ARGS-USED-IN-CLOSURES)))    (WHEN ARGS-USED-IN-CLOSURES      (IF (VARS-USED (CONS 'PROGN (CDR FORM))     ARGS-USED-IN-CLOSURES)  (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL)(SETQ PSETQ-FORM `(PROGN (UNSHARE-STACK-CLOSURE-VARS ,ARGVARS NIL) ,PSETQ-FORM)) )))  (PUSH `(UNSHARE-STACK-CLOSURE-VARS ,VARS ,(AND (TAILP ARGVARS VARS) ARGVARS))RETURN-FORM)  (DOLIST ( HV HIDDEN-ACTIVE-VARS )    (PUSH `(UNSHARE-STACK-CLOSURE-VARS ,HV NIL) RETURN-FORM) ))#+compiler:debug(when compiler-verbose  (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA));Stream may cons    (format t "~%Tail Recursion Elimination performed on ~S" (FIRST FORM))))`(PROGN ,PSETQ-FORM,SETQ-FORM. ,RETURN-FORM) )      ))))(DEFUN MAYBE-INTEGRATE ( FSPEC ARGS &OPTIONAL MAPPING-TABLE (INDECL '?) ) ;; For a call to function spec FSPEC with argument list ARGS, return ;; either an inline expansion or NIL if a call should be done instead.  (DECLARE (OPTIMIZE SPEED)) ; since it is called very often.  ;; 12/27/84 DNG - Fix extraction of declarations from interpreted definition.  ;;  1/19/85 DNG - Receive INDECL as an argument.  ;; 11/02/85 DNG - Permit use of the new debug-info structure.  ;;  2/14/86 DNG - Use FDEFINITION-SAFE instead of FDEFINEDP and FDEFINITION;  ;;    use TYPEP instead of %DATA-TYPE; use FSYMEVAL-FOR-TARGET.  ;;  3/13/86 DNG - Check new flag *DEFAULT-DEFS-FROM-HOST*.  ;;  5/08/86 DNG - Use SI:%%FEF-HEADER-SELF-MAPPING-TABLE for VM2.  ;;  5/21/86 DNG - For VM2, use %FEF-STORAGE-LENGTH-WORD instead of %FEFHI-STORAGE-LENGTH.  ;;  7/08/86 DNG - Modified to use COMPILAND structure.  ;;  7/17/86 DNG - Don't do automatic inline expansion when cross-compiling from VM1 to VM2.  ;;  9/16/86 DNG - In native compile, use SYMBOL-FUNCTION instead of FSYMEVAL-FOR-TARGET to save time.  ;; 11/15/86 DNG - Use %P-LDB-OFFSET instead of %P-LDB so forwarding is followed;  ;;use PARSE-BODY instead of EXTRACT-DECLARATIONS.  (LET ( FDEF INTERP-DEF DBUG-INFO SIZE CALLED-FLAVOR-NAME )    (AND INLINE-ENABLE (>= (OPT-SPEED OPTIMIZE-SWITCH)     (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)) (COND ((EQUAL FSPEC (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))(AND (NULL INLINE-EXPANSIONS)     (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SPACE OPTIMIZE-SWITCH))     (SETQ FDEF (COMPILAND-DEFINITION *CURRENT-COMPILAND*)) ))       ((AND QC-FILE-IN-PROGRESS     (NOT QC-FILE-LOAD-FLAG)     ;; When compiling to a file, if the function being     ;;  called was declared earlier in this same file, get     ;;  the new definition saved by QCOMPILE0 instead of     ;;  using the older version that is currently loaded.     ;; (Note: don't check UNDO-DECLARATIONS-FLAG because     ;;  it is reset by QC-FILE-COMMON when compiling     ;;  combined flavor methods.)     (LOOP FOR D IN FILE-LOCAL-DECLARATIONS   WHEN (AND (EQ (FIRST D) 'DEF)     (EQUAL (SECOND D) FSPEC) )     RETURN (SETQ FDEF (CDDR D))   FINALLY NIL ) ))       ((AND UNDO-DECLARATIONS-FLAG      FDEFINE-FILE-PATHNAME     (EQUAL (SI:FUNCTION-SPEC-GET FSPEC ':SOURCE-FILE-NAME) FDEFINE-FILE-PATHNAME ) )  ;; Declared in same file but new definition not recorded.NIL )       ((SYMBOLP FSPEC)(AND (FBOUNDP FSPEC)     (NOT (GET FSPEC 'P2)) ; not expanded by pass 2     #+Elroy     (NOT (GET-OPCODES FSPEC)) ; not a machine instruction     (SETQ FDEF (IF (EQ *DEFAULT-DEFS-FROM-HOST* 'T)    (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)(SYMBOL-FUNCTION FSPEC)      (LET (( FILE-LOCAL-DECLARATIONS NIL ))(FSYMEVAL-FOR-TARGET FSPEC)))  (LET (( FILE-LOCAL-DECLARATIONS NIL )( LOCAL-DECLARATIONS NIL ))    (DECLARED-DEFINITION FSPEC) )))))       ((CONSP FSPEC)(AND (EQ *DEFAULT-DEFS-FROM-HOST* 'T)     (VALIDATE-FUNCTION-SPEC FSPEC)     (SETQ FDEF (SI:FDEFINITION-SAFE FSPEC)) ))       (T NIL) ) (OR ;; Called routine needs to either not be a flavor method, or be   ;; for a flavor compatible with the current method.   (NULL (COND ((TYPEP FDEF 'COMPILED-FUNCTION)(AND (NOT (ZEROP (%P-LDB-OFFSET   #+Elroy SI:%%FEF-HEADER-SELF-MAPPING-TABLE   #-Elroy %%FEFH-GET-SELF-MAPPING-TABLE   FDEF 0)))     (SETQ CALLED-FLAVOR-NAME       #-Elroy       (%P-CONTENTS-OFFSET FDEF (1- (%P-LDB-OFFSET %%FEFHI-MS-ARG-DESC-ORG  FDEF %FEFHI-MISC)))       #+Elroy       (FEF-FLAVOR-NAME FDEF) ) ) )       ((CONSP FDEF)(MULTIPLE-VALUE-BIND ( BODY DECLARES DOC )    (SI:PARSE-BODY (CDR (SI:LAMBDA-EXP-ARGS-AND-BODY FDEF)) NIL T)  (DECLARE (IGNORE BODY DOC))  (DOLIST (DECLS DECLARES) ; for each DECLARE form    (WHEN (SETQ CALLED-FLAVOR-NAME(SECOND (ASSOC ':SELF-FLAVOR (CDR DECLS) :TEST #'EQ)))      (RETURN) ))))       (T NIL) ) )   (INCLUDED-FLAVOR-P CALLED-FLAVOR-NAME (CAR SELF-FLAVOR-DECLARATION)) ) (OR (AND ;; check criteria for inline expansion        (OR (PROGN (WHEN (EQ INDECL '?)    (SETQ INDECL (INLINE-DECL FSPEC)))  (EQ INDECL 'INLINE) )   (EQ INDECL 'TRY-INLINE)   (AND (EQL (OPT-SAFETY OPTIMIZE-SWITCH) 0)(NEQ INDECL 'NOTINLINE)(> (OPT-SPEED OPTIMIZE-SWITCH)   (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))#-Elroy (NOT (COMPILING-FOR-V2))#+Elroy (COMPILING-FOR-V2)(IF (TYPEP FDEF 'COMPILED-FUNCTION)    (OR (< (SETQ SIZE (%P-CONTENTS-OFFSETFDEF#+Elroy SI:%FEF-STORAGE-LENGTH-WORD#-Elroy %FEFHI-STORAGE-LENGTH))   16.)(AND (< SIZE 50.)     (NOT (NULL ARGS))     (SOME #'QUOTEP ARGS) ) )  (EQ FDEF (COMPILAND-DEFINITION *CURRENT-COMPILAND*)) ))   (AND (CONSP (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))(CONSP FSPEC)(EQ (FIRST (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) ':METHOD)(MEMBER (THIRD (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))'(:COMBINED SI:FASLOAD-COMBINED):TEST #'EQ)(NEQ INDECL 'NOTINLINE)(> (OPT-SPEED OPTIMIZE-SWITCH)   (OPT-SAFETY OPTIMIZE-SWITCH))(EQ (FIRST FSPEC) ':METHOD) ) )       (NULL (IF (LISTP (SETQ DBUG-INFO (FUNCTION-DEBUGGING-INFO FDEF))) (ASSOC 'SI:ENCAPSULATED-DEFINITION DBUG-INFO :TEST #'EQ)  ; no encapsulations       (SI:GET-DEBUG-INFO-FIELD DBUG-INFO ':ENCAPSULATED-DEFINITION)) )       (IF (CONSP FDEF)   (SETQ INTERP-DEF FDEF) (IF (LISTP DBUG-INFO)     (AND (SETQ INTERP-DEF (ASSOC 'INTERPRETED-DEFINITION DBUG-INFO :TEST #'EQ))  (SETQ INTERP-DEF (SECOND INTERP-DEF) ) )   (SETQ INTERP-DEF (INTERPRETED-DEF FDEF))) )       (PROCEDURE-INTEGRATION FSPEC ARGS INTERP-DEF INDECL DBUG-INFO) )     ;; Here when we can't do inline expansion, but maybe we can     ;;  improve the call.     (AND (NOT (NULL SELF-FLAVOR-DECLARATION))  ;; here when compiling a flavor method  (NOT (NULL CALLED-FLAVOR-NAME))  ;; here when calling a flavor method  (NULL MAPPING-TABLE); not already passing a mapping table  (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))  (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SPACE  OPTIMIZE-SWITCH))  (SETQ MAPPING-TABLE(IF (LOOKUP-VAR 'SI:.DAEMON-MAPPING-TABLE. VARS)    (IF (EQ (CAR SELF-FLAVOR-DECLARATION) CALLED-FLAVOR-NAME)'SI:.DAEMON-MAPPING-TABLE.      `(SELF-REF ,(CAR SELF-FLAVOR-DECLARATION) T ,CALLED-FLAVOR-NAME) )  (IF (EQ (CAR SELF-FLAVOR-DECLARATION) CALLED-FLAVOR-NAME)      'SYS:SELF-MAPPING-TABLE    NIL ) ) )  (EQ (CAR SELF-FLAVOR-DECLARATION) CALLED-FLAVOR-NAME) ; Temporary fix  ;; Change the call into a FUNCALL-WITH-MAPPING-TABLE so that the  ;;  mapping table can be passed to the called function instead of  ;;  it having to hunt for it.  (LIST* (IF (EQ (CAR SELF-FLAVOR-DECLARATION) CALLED-FLAVOR-NAME)     'FUNCALL-WITH-MAPPING-TABLE-INTERNAL   'FUNCALL-WITH-MAPPING-TABLE ) (LIST 'FUNCTION FSPEC) (P1V MAPPING-TABLE) ARGS )  ) ) ) ) )(DEFUN PROCEDURE-INTEGRATION ( FNAME ARGS INTERP-DEF IN-DECL DBUG-INFO      &OPTIONAL INTERNAL-COMPILAND )  ;; FNAME is the function spec of a function to be called.  ;; ARGS is the list of actual arguments for the call (already processed by P1).  ;; INTERP-DEF is the interpreted definition for the function to be called.  ;; IN-DECL is 'INLINE if function is explicitly declared INLINE.  ;; DBUG-INFO is the function's debugging information A-list.  ;; Returns the in-line expansion of the function call   ;; or returns NIL if the expansion is unsuccesful.  ;; 1/26/85 - Use P1-WITH-ANNOTATION.  ;; 2/20/85 - Restore ...-VAR-SET after aborted expansion.  ;; 11/2/85 - Modified for new debug-info structure.  ;; 3/14/86 - Don't need to save and restore FUNCTIONS-REFERENCED because it is  ;;not updated until the QLAPP phase anyway.  ;; 7/25/86 - Updated to allow integration of local functions.  ;; 8/28/86 - Added argument to expand-lambda to indicate that args have been processed  ;;           already (in particular, args have already been quoted if necessary)  ;; 8/29/86 - Pass declared function result type to P1-WITH-ANNOTATION.  ;; 9/20/86 - Use a larger size limit for breakoff functions for which this is the only reference.  ;;11/24/86 - Fix to allow a local INLINE declaration to force expansion of a  ;;function that was too large for automatic expansion.  ;; 2/05/87 - Fix for local INLINE of failed TRY-INLINE.  ;; 4/06/87 - Include the :MACROS-EXPANDED list from the debug-info in INLINE-EXPANSIONS  ;;so we can make sure that the macros we need are defined.  [SPR 4528]  (UNLESS (MEMBER (FIRST INTERP-DEF)  '(GLOBAL:NAMED-LAMBDA NAMED-LAMBDA GLOBAL:LAMBDA CLI:LAMBDA)  :TEST #'EQ)    (RETURN-FROM PROCEDURE-INTEGRATION NIL) )  (LET (( TAG (GENSYM) )( ABORT-REASON (IF (LISTP DBUG-INFO)   (CDR (ASSOC 'NOTINLINE DBUG-INFO :TEST #'EQ)) (SI:GET-DEBUG-INFO-FIELD DBUG-INFO 'NOTINLINE) ))( AGAIN-TAG NIL ) FORM( OLD-ALLVARS ALLVARS )( OLD-FREEVARS FREEVARS )( OLD-MACROS-EXPANDED MACROS-EXPANDED )( OLD-SELF-REFERENCES-PRESENT SELF-REFERENCES-PRESENT )( OLD-EXPRESSION-SIZE EXPRESSION-SIZE )( OLD-PROPAGATE PROPAGATE-VAR-SET )( OLD-USED USED-VAR-SET )( OLD-ALTERED ALTERED-VAR-SET )( OLD-SUBST SUBST-VAR-SET )( OLD-PLIST (COMPILAND-PLIST *CURRENT-COMPILAND*) ) ; SPECIALFLAG( OLD-VAR-LEVEL-COUNTS (AND INTERNAL-COMPILAND    *VAR-LEVEL-COUNTS*     (COPY-LIST *VAR-LEVEL-COUNTS*)) )( COMPILING-COMMON-LISP  (COND ((EQ (FIRST INTERP-DEF) 'NAMED-LAMBDA) T)((EQ (FIRST INTERP-DEF) 'GLOBAL:NAMED-LAMBDA) NIL)(T COMPILING-COMMON-LISP)) ))    (TAGBODY CHECK-REASON     (COND ((NULL ABORT-REASON))   ((AND (EQ ABORT-REASON 'TAIL-RECURSION-ELIMINATION) (NULL AGAIN-TAG))    (SETQ AGAIN-TAG TAG) )   ((AND (EQ ABORT-REASON 'SIZE) (OR (AND (EQ IN-DECL 'INLINE)  (SYMBOLP FNAME)  (NEQ (GET FNAME 'INLINE) 'INLINE))      (AND (NOT (NULL ARGS))   (SOME #'QUOTEP ARGS)))))   (T (RETURN-FROM PROCEDURE-INTEGRATION NIL)) )     (SETQ ABORT-REASON      (CATCH TAG(LET (( WARN-CATCHER TAG )); cause WARN to THROW back to here  ;; Create a LET-FOR-LAMBDA form which binds the function arguments.  (SETQ FORM (EXPAND-LAMBDA INTERP-DEF ARGS AGAIN-TAG t))  (UNLESS (EQ (FIRST FORM) 'LET-FOR-LAMBDA)    (RETURN-FROM PROCEDURE-INTEGRATION NIL) )  (LET ( NEW-FORM )    (SETQ NEW-FORM   (LET* (( X (LIST FNAME   TAG   (FIRST (SI:LAMBDA-EXP-ARGS-AND-BODY INTERP-DEF))   (SI:GET-DEBUG-INFO-FIELD DBUG-INFO :MACROS-EXPANDED) ; for CHECK-NUMBER-OF-ARGS   )) ( INLINE-EXPANSIONS (CONS X INLINE-EXPANSIONS) ) ( TRE-OK (CONS X TRE-OK) ) ( P1VALUE (IF (ATOM P1VALUE)       (LIST X)     (CONS X P1VALUE) ) ) ( EXPRESSION-SIZE-LIMIT  (+ EXPRESSION-SIZE      (COND ((EQ IN-DECL 'INLINE) 100.)   ((AND INTERNAL-COMPILAND (GETF (COMPILAND-PLIST INTERNAL-COMPILAND)       'USED-ONLY-ONCE))    50.)   ((AND (EQ (CAR-SAFE (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))     ':METHOD) (CONSP FNAME) (EQ (FIRST FNAME) ':METHOD) )    40. )   (T    ;; if the function was not explicitely declared INLINE,    ;; then abort the expansion if it turns out to be    ;; significantly longer than a call would have been.    (+ (LENGTH ARGS) 1       (OPT-SPEED OPTIMIZE-SWITCH)       ) ) ) ) ) ( *P-I-COMPILAND* INTERNAL-COMPILAND ))    (DECLARE (SPECIAL *P-I-COMPILAND*))    (P1-WITH-ANNOTATION      FORM #'P1-LET-FOR-P-I      (IF (> (OPT-SAFETY OPTIMIZE-SWITCH)     (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))  'UNKNOWN(IF INTERNAL-COMPILAND    (LET ((TYPE (GETF (COMPILAND-PLIST INTERNAL-COMPILAND) 'TYPE)))      (IF (EQ (CAR-SAFE TYPE) 'FUNCTION)  (THIRD TYPE)'UNKNOWN))  (GETDECL FNAME 'FUNCTION-RESULT-TYPE 'UNKNOWN)))    ) ) )    ;; expansion has been successfully completed.    (if-debug      (when compiler-verbose(LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))   ;Stream may cons  (format t "~%Function ~S expanded inline in ~S"  FNAME  (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*) ) ) ) )    (UNLESS (OR (EQ FNAME (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))(EQ (CAR-SAFE FNAME) ':INTERNAL))      (PUSHNEW FNAME MACROS-EXPANDED :TEST 'EQUAL) )    (RETURN-FROM PROCEDURE-INTEGRATION NEW-FORM) )    ));; end of CATCH; here if the expansion was aborted  ) ; end of SETQ ABORT-REASON;; finish un-doing the side-effects of the failed expansion(SETF ALLVARS OLD-ALLVARS      FREEVARS OLD-FREEVARS      MACROS-EXPANDED OLD-MACROS-EXPANDED      SELF-REFERENCES-PRESENT OLD-SELF-REFERENCES-PRESENT      EXPRESSION-SIZE OLD-EXPRESSION-SIZE      PROPAGATE-VAR-SET OLD-PROPAGATE      USED-VAR-SET OLD-USED      ALTERED-VAR-SET OLD-ALTERED      SUBST-VAR-SET OLD-SUBST      (COMPILAND-PLIST *CURRENT-COMPILAND*) OLD-PLIST ; SPECIALFLAG     )        (WHEN OLD-VAR-LEVEL-COUNTS  (SETQ *VAR-LEVEL-COUNTS* OLD-VAR-LEVEL-COUNTS))(if-debug  (when (and compiler-verbose     (string-equal user-id "GRAY"))   ; no one else is interested    (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))   ;Stream may cons      (format t "~%Expansion of ~S in ~S failed, reason = ~S"      FNAME (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*) ABORT-REASON) ) ) )(WHEN (OR (NEQ ABORT-REASON 'SIZE)  (NOT (IF (LISTP DBUG-INFO)   (ASSOC 'NOTINLINE DBUG-INFO :TEST #'EQ) (SI:GET-DEBUG-INFO-FIELD DBUG-INFO 'NOTINLINE) )) );;  don't try to expand this one again.;; (If expansion failed because it was too big, that does not;;  necessarily rule out trying again with different arguments.)   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) (SYS:%INHIBIT-READ-ONLY T))     (COND ((CONSP DBUG-INFO)    (SETF (CDR DBUG-INFO)  (CONS `(NOTINLINE . ,ABORT-REASON) (CDR DBUG-INFO))) )   ((ARRAYP DBUG-INFO)    (SI:PUT-DEBUG-INFO-FIELD DBUG-INFO 'NOTINLINE ABORT-REASON))   (T (PUSH (CONS FNAME 'NOTINLINE) INLINE-DECLARATIONS) ) ) ) )(UNLESS (EQ ABORT-REASON 'SIZE)  (GO CHECK-REASON) )) )     NIL  )(DEFUN P1-LET-FOR-P-I ( FORM )  ;; The code that follows has been adapted from the handler  ;;  for LET-FOR-LAMBDA; it differs from an internal lambda in that  ;;  the lexical environment is not inherited within the body.  ;; 1/26/85 - Separated from PROCEDURE-INTEGRATION to facilitate use of P1-WITH-ANNOTATION.  ;; 6/21/86 - Bind *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.  ;; 7/07/86 - Include old VARS in result form instead of declarations.  ;; 7/10/86 - To allow integrating local functions, move the binding of  ;;LOCAL-DECLARATIONS to PROCEDURE-INTEGRATION and use *P-I-VARS* to  ;;initialize VARS.  ;; 9/16/86 - Add call to VARIABLE-WRAPUP.  ;; 9/20/86 - Move the binding of INHIBIT-STYLE-WARNINGS-SWITCH to include the call to VARIABLE-WRAPUP.  ;; 12/15/86 DNG - Add use of DYNAMIC-BINDING-HACK.  (LET ((VARS VARS) (OLD-VARS VARS) NEW-VARS(BINDP) (BODY) (VLIST)(INLINE-DECLARATIONS INLINE-DECLARATIONS)(LOCAL-DECLARATIONS NIL); NIL to prevent inheritance in FIND-TYPE(THIS-FRAME-DECLARATIONS NIL)(ENTRY-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)(INHIBIT-STYLE-WARNINGS-SWITCH T))    ;; Take all DECLAREs off the body.    (SETF (VALUES BODY THIS-FRAME-DECLARATIONS)  (EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR FORM) NIL))        ;; Bind the arguments        (SETQ VLIST (P1SBIND (CADR FORM) 'FEF-ARG-INTERNAL-AUX 'DONT-P1 NIL THIS-FRAME-DECLARATIONS))    (SETQ NEW-VARS VARS)        ;; Now P1 process the body, in a context that    ;;  does not allow any lexical inheritance from the calling function.    (LET* (( HIDDEN-ACTIVE-VARS (CONS OLD-VARS HIDDEN-ACTIVE-VARS) )   ( VARS (LOOP FOR V ON VARSUNTIL (EQ V OLD-VARS); keep just the local argsCOLLECT (FIRST V) ) )   ( OUTER-GOTAGS GOTAGS )   ( GOTAGS NIL )   ( PROGDESCS NIL )   ( RETPROGDESC NIL )   ( LOCAL-FUNCTIONS NIL )   ( *LOCAL-ENVIRONMENT* NIL )   )      (DECLARE (SPECIAL *P-I-COMPILAND*))      (UNLESS (NULL *P-I-COMPILAND*)(SETQ VARS (NCONC VARS (COMPILAND-INHERITED-VARS *P-I-COMPILAND*)))(SETQ GOTAGS(COMPILAND-INHERITED-GOTAGS *P-I-COMPILAND*)      PROGDESCS (COMPILAND-INHERITED-PROGDESCS *P-I-COMPILAND*)      RETPROGDESC (COMPILAND-INHERITED-RETPROGDESC *P-I-COMPILAND*)      LOCAL-DECLARATIONS (COMPILAND-DECLARATIONS *P-I-COMPILAND*)      LOCAL-FUNCTIONS (COMPILAND-INHERITED-LOCAL-FUNCTIONS *P-I-COMPILAND*)      *LOCAL-ENVIRONMENT* (COMPILAND-INHERITED-LOCAL-MACROS *P-I-COMPILAND*)) )      (UNLESS (NULL SELF-FLAVOR-DECLARATION)(LET (( TEM (LOOKUP-VAR 'SI:.DAEMON-MAPPING-TABLE. OLD-VARS) ))  (UNLESS (NULL TEM)    ;; In a combined flavor method, this magic variable which    ;;  holds the current mapping table needs to be kept visible.    (PUSH TEM VARS) ) ) )      (DOLIST ( P (REST P1VALUE) );; keep tags that may be needed for tail recursion elimination(PUSH (ASSOC (SECOND P) OUTER-GOTAGS :TEST #'EQ)      GOTAGS) )      (SETQ LOCAL-DECLARATIONS    (PROCESS-PERVASIVE-DECLARATIONS THIS-FRAME-DECLARATIONS))      (SETQ BODY (P1PROGN-1 BODY)); process the body      ); end of LET*    (VARIABLE-WRAPUP NEW-VARS OLD-VARS)    ;; expansion has been successfully completed.    (DYNAMIC-BINDING-HACK BINDP VLIST)    (LIST* (FIRST FORM) VLIST OLD-VARS NEW-VARS BINDP   ENTRY-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT   BODY )    ) )(DEFUN MATCH-ARGS-WITH-VALUES ( LAMBDA-LIST ACTUAL-ARGS ARGS-PROCESSED)  (DECLARE (VALUES PVARS PVALS DEFAULTVARS DEFAULTVALS ERROR SPECIAL-VARS))  ;; Matches formal arguments with actual argument values.  ;; The arguments to this function are:  ;;    LAMBDA-LIST = The formal argument list.  ;;    ACTUAL-ARGS = A list of actual argument values from a function call.  ;; Returns the following six values.  Each list returned is in  ;; reverse order.  Any &AUX variables are not returned.  ;;   ;;   1. PVARS = List of argument variables to be assigned values  ;;in parallel.  ;;   2. PVALS = List of actual value expressions corresponding to PVARS.  ;;   3. DEFAULTVARS = List of argument variables which are to be  ;;       assigned values serially after the parallel assignments  ;;       have been done.  These are unsupplied optional arguments  ;;       which are being assigned their default value, which might  ;;       reference previous arguments.  ;;   4. DEFAULTVALS = List of value expressions corresponding to DEFAULTVARS.  ;;   5. ERROR = NIL if successful, non-NIL if anything is wrong.  ;;       Note that since this routine is only used for performing  ;;       optimizations, it does not issue any error messages, nor does it  ;;       need to be able to handle all legal situations -- it just has  ;;       to indicate when the optimization cannot be done.  ;;   6. SPECIAL-VARS = List of argument variables that are declared special by  ;;       the use of a &SPECIAL in the lambda list.  ;;   ;; For example, given LAMBDA-LIST = (A &OPTIONAL B (C A) D &AUX E)  ;; and ACTUAL-ARGS = (X Y) then the values returned are:  ;; PVARS = (B A), PVALS = (Y X), DEFAULTVARS = (D C), DEFAULTVALS = (NIL A),  ;; ERROR = NIL, and SPECIAL-VARS = NIL.  ;;         ;;  1/17/85 - Allow &EXTENSION.  ;;  3/31/86 - Eliminate obsolete distinction between optional and required &KEY args.  ;;  8/28/86 - Add argument ARGS-PROCESSED to indicate that args have already been  ;;            processed, in particular, quoted args have already been quoted.  (LET ( ARGS1 VAR VAL(PVARS NIL)(PVALS NIL)(DEFAULTVARS NIL)(DEFAULTVALS NIL)(SUPPLIED-KEYS NIL) (IGNORED-VALUES NIL)(ERROR NIL)(SPECIAL-VARS NIL)(SPECIAL-FLAG NIL) (OPTIONAL NIL) (QUOTEFLAG NIL))    (SETQ ARGS1 ACTUAL-ARGS)    (DO ((ARGLIST1 LAMBDA-LIST (REST ARGLIST1))); scan formal arguments((NULL ARGLIST1) (UNLESS (NULL ARGS1) (SETQ ERROR 'MAX)) ); too many actual arguments      (SETQ VAR (FIRST ARGLIST1))      (COND ((MEMBER VAR LAMBDA-LIST-KEYWORDS :TEST #'EQ)     (COND       ((EQ VAR '&KEY)(MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL      KEYKEYS KEYNAMES KEYOPTFS KEYINITS KEYFLAGS      ALLOW-OTHER-KEYS)    (DECODE-KEYWORD-ARGLIST LAMBDA-LIST)  (DECLARE (IGNORE KEYOPTFS)) ; not used anymore  ;; first scan the actual arguments so that the actual  ;; argument expressions will be evaluated in the correct  ;; left-to-right order.  (DO ((AAS ARGS1 (CDDR AAS)))      ((NULL AAS) NIL )    (WHEN (NULL (REST AAS)) (SETQ ERROR 'ODD))    (LET ((AA (FIRST AAS)))      (WHEN (QUOTEP AA) (SETQ AA (SECOND AA)))      (WHEN (AND (EQ AA ':ALLOW-OTHER-KEYS) (NOT (NULL (SECOND AAS))))(SETQ ALLOW-OTHER-KEYS T))      (IF (MEMBER AA SUPPLIED-KEYS :TEST #'EQ); duplicate key  (PUSH (SECOND AAS) IGNORED-VALUES)(DO ((KNS KEYNAMES (CDR KNS)); keyword arg variable names     (KKS KEYKEYS  (CDR KKS))); key symbols (in keyword package)    ((NULL KKS); actual key not in lambda list     (UNLESS ALLOW-OTHER-KEYS       (SETQ ERROR 'ALLOW-OTHER-KEYS) )     (UNLESS (KEYWORDP AA)       (SETQ ERROR 'KEYWORDP) )     (PUSH (SECOND AAS) IGNORED-VALUES) )  (WHEN (EQ AA (FIRST KKS))    (LET (( VAL (SECOND AAS) ))      (WHEN IGNORED-VALUES(SETQ VAL (LIST VAL))(LOOP WHILE IGNORED-VALUES      DO (PUSH (POP IGNORED-VALUES) VAL) )(PUSH 'PROGN VAL) )      (PUSH (FIRST KNS) PVARS); variable      (PUSH VAL PVALS); value      (PUSH AA SUPPLIED-KEYS)      (RETURN) ) ) ) ) ) )  (WHEN ERROR (RETURN))  (WHEN IGNORED-VALUES    (IF (NULL PVALS)(RETURN (SETQ ERROR 'IGNORE))      (SETF (FIRST PVALS)    (LIST* 'PROG1 (FIRST PVALS) (NREVERSE IGNORED-VALUES)) )))  ;; now scan the formal arguments to take care of any  ;; which did not have actual values supplied.  (DO ((KIS KEYINITS (CDR KIS)); default initial values       (KNS KEYNAMES (CDR KNS)); keyword arg variable names       (KKS KEYKEYS  (CDR KKS)); key symbols (in keyword package)       (KFS KEYFLAGS (CDR KFS))); supplied-flag name, or NIL if none      ((NULL KNS))    (LET* ((KEYFLAG (CAR KFS))   (KEYKEY  (CAR KKS))   (SUPPLIED (IF (MEMBER KEYKEY SUPPLIED-KEYS :TEST #'EQ) T NIL) ) )      (UNLESS SUPPLIED (PUSH (CAR KNS) DEFAULTVARS)   ; variable name(PUSH (CAR KIS) DEFAULTVALS)   ; default value)      (WHEN KEYFLAG; "supplied-p" variable(PUSH KEYFLAG  PVARS)(PUSH (LIST 'QUOTE SUPPLIED) PVALS) )      ))  (RETURN (SETQ ARGS1 NIL)) ))       ((EQ VAR '&REST)(POP ARGLIST1)(IF (AND (REST ARGLIST1) (NEQ (SECOND ARGLIST1) '&AUX))    (SETQ ERROR '&REST)) ; can't handle both &REST and &KEY(PUSH (FIRST ARGLIST1) PVARS)(PUSH (COND ( (AND QUOTEFLAG   ARGS-PROCESSED)      ARGS1)    ( QUOTEFLAG (LIST 'QUOTE ARGS1) )    ((NULL ARGS1) ''NIL)    ( T `(LIST . ,ARGS1) ) )      PVALS )(RETURN (SETQ ARGS1 NIL)))       ((EQ VAR '&OPTIONAL)(SETQ OPTIONAL T))       ((EQ VAR '&QUOTE)(SETQ QUOTEFLAG T))       ((EQ VAR '&EVAL)(SETQ QUOTEFLAG NIL))       ((EQ VAR '&SPECIAL)(SETQ SPECIAL-FLAG T))       ((EQ VAR '&LOCAL)(SETQ SPECIAL-FLAG NIL))       ((EQ VAR '&FUNCTIONAL)(IF (QUOTEP (FIRST ARGS1))    (SETQ ARGS1 (CONS (CONS 'FUNCTION (REST (FIRST ARGS1)))      (REST ARGS1) )) ) )       ((EQ VAR '&AUX) (SETQ ARGLIST1 NIL))       ((EQ VAR '&EXTENSION))       ( T (SETQ ERROR 'LAMBDA-LIST-KEYWORDS))  ;; some other keyword we don't know how to handle here.       ) ); end of COND on &... lambda keywords    (T (IF (NULL ARGS1)   (SETQ VAL ''NIL) (PROGN (SETQ VAL (FIRST ARGS1))(WHEN QUOTEFLAG (SETQ VAL      (if args-processed val  (LIST 'QUOTE val))) )))       (COND ((SYMBOLP VAR)      (WHEN SPECIAL-FLAG (PUSH VAR SPECIAL-VARS) )      (WHEN (AND (NULL ARGS1) (NOT OPTIONAL)); too few actual arguments(SETQ ERROR 'MIN)(RETURN) )      (PUSH VAR PVARS)      (PUSH VAL PVALS) )     ((ATOM VAR) (SETQ ERROR 'SYMBOLP))     (T      (WHEN (NOT OPTIONAL) (SETQ ERROR 'LIST))      (WHEN SPECIAL-FLAG (PUSH (FIRST VAR) SPECIAL-VARS) )      (COND ( ARGS1; actual argument supplied     (PUSH (FIRST VAR) PVARS)     (PUSH VAL PVALS ) )    ( T; use default value     (PUSH (FIRST VAR) DEFAULTVARS)     (PUSH (SECOND VAR) DEFAULTVALS)     ))      (WHEN (CDDR VAR); "supplied-p" variable(PUSH (THIRD VAR) PVARS)(PUSH (LIST 'QUOTE (IF ARGS1 T NIL)) PVALS))      ))       (POP ARGS1))))    (VALUES PVARS PVALS DEFAULTVARS DEFAULTVALS ERROR SPECIAL-VARS)  ))(DEFUN P1-WITH-ANNOTATION ( FORM &OPTIONAL HANDLER (TYPE 'UNKNOWN) DONT-OPTIMIZE)  ;; Do the P1 transformation on a form and attach some information to it  ;;  for use by optimizers.  This must be used to surround forms such as  ;;  LET which create new variables and may optionaly be used around any  ;;  form for which we may want to know which variables were referenced.  ;; The resulting form returned is:  ;; (THE-EXPR <form> <used> <altered> <optimize> <type>)  ;;  where: <form> is the result of applying P1 to the input form.  ;;     <used> is the set of local variables whose values are referenced  ;;     within <form>.  ;;     <altered> is the set of local variables whose values are altered  ;;     within <form>.  This does not include initial bindings of  ;;     variables whose scope is entirely within <form>, but does  ;;     reflect SETQ and such.  ;;     <optimize> holds the value of the optimization switches.  If the  ;;     <form> contains a (DECLARE (OPTIMIZE ...)) at the top  ;;     level, then this reflects the effect of that local  ;;     declaration.  ;;     <type> if supplied and not UNKNOWN, specifies the data type of  ;;     the value of <form>.   It is a type specifier such as  ;;     FIXNUM or ARRAY that indicates whatever is known about  ;;     the type.  This used by EXPR-TYPE-P.  ;; Note that if the form is a LET, the <used> and <altered> sets include  ;;  variables local to the LET as well as those outside.  (DECLARE (ARGLIST FORM &OPTIONAL (HANDLER #'P1) (TYPE 'UNKNOWN) DONT-OPTIMIZE))  ;;  ;; 1/24/85 DNG - Original version.  ;; 1/28/85 DNG - Don't bind ALTERED-VAR-SET for a LET-FOR-LAMBDA.  ;; 3/10/86 DNG - Add TYPE argument.  ;; 9/19/86 DNG - Call POST-OPTIMIZE here instead of in THE-EXPR-OPT.  ;;10/15/86 DNG - Added DONT-OPTIMIZE argument.  (LET ( UV AV BIT NEW-FORM RESULT-FORM )    (LET-IF (NEQ (CAR-SAFE FORM) 'LET-FOR-LAMBDA)    ;; Don't bind these on a LET-FOR-LAMBDA because the binding    ;; values have already been processed by P1.    ((USED-VAR-SET 0)     (ALTERED-VAR-SET 0))      (LET ((VAR-BIT VAR-BIT)    (OPTIMIZE-SWITCH OPTIMIZE-SWITCH) )(IF HANDLER    (PROGN (SETQ NEW-FORM (FUNCALL HANDLER FORM))   (UNLESS DONT-OPTIMIZE     (SETQ NEW-FORM (POST-OPTIMIZE NEW-FORM))))  (SETQ NEW-FORM(P1 FORM DONT-OPTIMIZE)))(SETQ UV USED-VAR-SET)(SETQ AV ALTERED-VAR-SET)(SETQ BIT VAR-BIT)(SETQ RESULT-FORM      (MAKE-EXPR :EXPR-FORM NEW-FORM :EXPR-USED UV :EXPR-ALTERED AV :EXPR-OPTIMIZE OPTIMIZE-SWITCH :EXPR-TYPE TYPE) )) )    (UNLESS (= BIT VAR-BIT)      ;; Now that VAR-BIT has been restored to its original value, mask the      ;; variable sets to remove the local variables whose scope has ended.      (LET (( MASK (- VAR-BIT 1)))(SETQ AV (LOGAND AV MASK))(SETQ UV (LOGAND UV MASK))(SETQ PROPAGATE-VAR-SET (LOGAND PROPAGATE-VAR-SET MASK))(SETQ SUBST-VAR-SET   (LOGAND SUBST-VAR-SET   MASK)) ) )    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET UV))    (SETQ ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET AV))    RESULT-FORM ) );;When a var is handled by P1BINDVAR which is an optional arg with a specified-flag,;;we push the flag name onto SPECIFIED-FLAGS so that a home will be made for the flag.(DEFVAR SPECIFIED-FLAGS);Process a Lambda-list (X), making the variables by default of kind KIND;(FEF-ARG-REQ for the top-level lambda,; FEF-ARG-AUX or FEF-ARG-INTERNAL-AUX for progs).;Return a prog variable list for the same variables with their initializations if any,;with P1 done on each initialization.;This function gobbles down the variables and processes keywords.;Each variable, with its appropeiate keyword info, is passed to P1LMB.;We can do either sequential or parallel binding.;Processing of variables is done in two steps:;First, create the homes;Second, if these are not FEF-ARG-INTERNAL-AUX vars,; put the homes on VARS and ALLVARS.;Third, process all the variables' initializations.;Finally, put the homes on VARS and ALLVARS if not already there.;For variables whose scope is the whole function (not FEF-ARG-INTERNAL-AUX),;the order is designed so that variables bound inside their initializations;all come after all the variables of the original (higher) level.;This is needed to make sure that (DEFUN FOO (&OPTIONAL (A (LET ((C ...)) ...)) B) ...);does not put C into VARS before B.;For FEF-ARG-INTERNAL-AUX variables, we want the variables bound;inside the initializations to come first, since they are used first.;That way, our own variables overlap with them rather than vice versa.;As a result, the variable with the original home is always the first one used.;This is important for deciding which variables need explicit initialization.;The IGNORE-NIL-P argument is used by MULTIPLE-VALUE-BIND to say; that if NIL appears as a variable, its initial value should be evaluated; and discarded.(DEFUN P1SBIND (X KIND PARALLEL IGNORE-NIL-P THIS-FRAME-DECLARATIONS)  ;;  7/18/85 - Add check for binding of a DEFCONSTANT; previously done in VAR-MAKE-HOME. [SPR 194]  ;;  9/14/85 - Use EQ instead of STRING-EQUAL to test for IGNORE.  ;;  1/09/86 - Allow "variable appears twice" message to be suppressed by INHIBIT-STYLE-WARNINGS-SWITCH.  ;;  3/07/86 - Don't set LOCAL-DECLARATIONS from redundant &SPECIAL flag.  (LET (TM EVALCODE VARN MYVARS MISC-TYPESSPECIFIED-FLAGS (SPECIALNESS NIL) ALREADY-REST-ARG)    ;; First look at the var specs and make homes, pushing them on MYVARS (reversed).    (PROG ()  (SETQ EVALCODE 'FEF-QT-DONTCARE)       A  (COND ((NULL X) (RETURN))((SETQ TM (ASSOC (CAR X)'((&OPTIONAL . FEF-ARG-OPT)  (&REST . FEF-ARG-REST) (&AUX . FEF-ARG-AUX)):TEST #'EQ)) (COND ((OR (EQ KIND 'FEF-ARG-AUX)    (EQ KIND 'FEF-ARG-INTERNAL-AUX))(WARN 'BAD-BINDING-LIST ':IMPOSSIBLE      "A lambda-list keyword (~S) appears in an internal binding list."      (CAR X)))       (T (SETQ KIND (CDR TM)))) (GO B))((SETQ TM (ASSOC (CAR X) '((&EVAL . FEF-QT-EVAL)   (&QUOTE . FEF-QT-QT)   (&QUOTE-DONTCARE . FEF-QT-DONTCARE)) :TEST #'EQ)) (SETQ EVALCODE (CDR TM)) (GO B))((SETQ TM (ASSOC (CAR X) '((&FUNCTIONAL . FEF-FUNCTIONAL-ARG)) :TEST #'EQ)) (PUSH (CDR TM) MISC-TYPES) (GO B))((EQ (CAR X) '&SPECIAL) (SETQ SPECIALNESS T) (GO B))((EQ (CAR X) '&LOCAL) (SETQ SPECIALNESS NIL) (GO B))((MEMBER (CAR X) LAMBDA-LIST-KEYWORDS :TEST #'EQ) (GO B)))  ;; LAMBDA-list keywords have jumped to B.  ;; Now (CAR X) should be a variable or (var init).  (SETQ VARN (COND ((ATOM (CAR X)) (CAR X)) (T (CAAR X))))  (UNLESS (SYMBOLP VARN)    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE  "~S appears in a list of variables to be bound." VARN)    (GO B))  (WHEN (KEYWORDP VARN) ; this check added 8/13/84 by D.N.G.    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE  "The keyword ~S appears in a list of variables to be bound.Keywords are constants and so cannot be used as names of variables." VARN)    (GO B))  (WHEN (AND (OR (GET-FOR-TARGET VARN 'SYSTEM-CONSTANT) (ASSOC VARN FILE-CONSTANTS-LIST :TEST #'EQ))     (NOT (EQ VARN 'NIL)) ; permitted in MULTIPLE-VALUE-BIND     (EQ (FIND-TYPE VARN THIS-FRAME-DECLARATIONS) 'FEF-SPECIAL) )    (WARN 'SYSTEM-CONSTANT-BOUND ':IMPLAUSIBLE  "Attempt to bind the constant ~S; the new binding will be local.If that is what you want, this message can be suppressed by (DECLARE (UNSPECIAL ~S))."  VARN VARN)    (PUSH `(UNSPECIAL ,VARN) THIS-FRAME-DECLARATIONS) )  (WHEN (AND (NOT (OR (EQ VARN 'LISP:IGNORE)      (STRING-EQUAL VARN "IGNORED")      (NULL VARN)))     ;; Does this variable appear again later?     ;; An exception is made in that a function argument can be repeated     ;; after an &AUX.     (DOLIST (X1 (CDR X))       (COND ((EQ X1 '&AUX) (RETURN NIL))     ((OR (EQ X1 VARN)  (AND (NOT (ATOM X1)) (EQ (CAR X1) VARN)))      (RETURN T))))     (OR PARALLEL (NOT INHIBIT-STYLE-WARNINGS-SWITCH)) )    (WARN 'BAD-BINDING-LIST ':IMPLAUSIBLE  "The variable ~S appears twice in one binding list."  VARN) )  (WHEN (CHAR= (CHAR (SYMBOL-NAME VARN) 0) #\&)    (WARN 'MISSPELLED-KEYWORD ':IMPLAUSIBLE  "~S is probably a misspelled keyword." VARN))  (WHEN ALREADY-REST-ARG    (WARN 'BAD-LAMBDA-LIST ':IMPOSSIBLE  "Argument ~S comes after the &REST argument." VARN))  (WHEN (EQ KIND 'FEF-ARG-REST)    (SETQ ALREADY-REST-ARG T))  (COND ((AND IGNORE-NIL-P (NULL VARN)) (LET ((P1VALUE NIL))   (P1 (CADAR X))))    ;Out of order, but works in these simple cases((OR (NULL VARN) (EQ VARN T)) (WARN 'NIL-OR-T-SET ':IMPOSSIBLE "There is an attempt to bind ~S." VARN))(T ;; Make the variable's home. (IF SPECIALNESS     (LET ((DECL (LIST 'SPECIAL       (COND ((SYMBOLP (CAR X)) (CAR X))     ((SYMBOLP (CAAR X)) (CAAR X))     (T (CADAAR X))))))       (UNLESS (SPECIALP (SECOND DECL)) ;; If already special anyway, don't put it on LOCAL-DECLARATIONS ;; to avoid warning from FIND-TYPE on a later binding. (PUSH DECL LOCAL-DECLARATIONS) )       (PUSH DECL THIS-FRAME-DECLARATIONS))) (PUSH (P1BINDVAR (CAR X) KIND EVALCODE MISC-TYPES  THIS-FRAME-DECLARATIONS)       MYVARS)))  (SETQ MISC-TYPES NIL)       B  (SETQ X (CDR X))  (GO A))           ;; Arguments should go on ALLVARS now, so all args precede all boundvars.    (OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)(EQ KIND 'FEF-ARG-AUX)(SETQ ALLVARS (APPEND SPECIFIED-FLAGS MYVARS ALLVARS)))    (MAPC #'VAR-COMPUTE-INIT SPECIFIED-FLAGS (CIRCULAR-LIST NIL))    (PROCESS-BINDING-DECLARATIONS MYVARS THIS-FRAME-DECLARATIONS)    ;; Now do pass 1 on the initializations for the variables.    (DO ((ACCUM) (VS (REVERSE MYVARS) (CDR VS)))((NULL VS) ;; If parallel binding, put all var homes on VARS ;; after all the inits are thru. (COND (PARALLEL(UNLESS (ZEROP ALTERED-VAR-SET)  ;; Prevent propagation of new variables whose initial  ;; values are local variables which were changed as  ;; a side effect of a parallel binding.  (LET ( LAPAD INIT )    (DOLIST ( V MYVARS )      (WHEN (ZEROP PROPAGATE-VAR-SET) (RETURN))      (WHEN (AND (CONSP (SETQ INIT (SECOND (VAR-INIT V)))) (EQ (CAR INIT) 'LOCAL-REF) (LOGTEST (CDDR INIT) ALTERED-VAR-SET) (CONSP (SETQ LAPAD (VAR-LAP-ADDRESS V))) (EQ (CAR LAPAD) 'LOCAL-REF))(SETQ PROPAGATE-VAR-SET      (LOGDIF PROPAGATE-VAR-SET      (CDDR LAPAD))))) ) )(SETQ VARS (APPEND MYVARS VARS))(COND ((OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)   (EQ KIND 'FEF-ARG-AUX))       (MAPC #'VAR-CONSIDER-OVERLAP MYVARS)       (SETQ ALLVARS (APPEND MYVARS ALLVARS)))))) (NREVERSE ACCUM))      (PUSH (VAR-COMPUTE-INIT (CAR VS) PARALLEL) ACCUM)      ;; For sequential binding, put each var on VARS      ;; after its own init.      (OR PARALLEL  (PROGN (COND ((OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)    (EQ KIND 'FEF-ARG-AUX))(VAR-CONSIDER-OVERLAP (CAR VS))(PUSH (CAR VS) ALLVARS))) (PUSH (CAR VS) VARS) (LET ((TEM (CDDR (VAR-INIT (CAR VS)))))   (AND TEM (PUSH TEM VARS))))))))(DEFUN PROCESS-BINDING-DECLARATIONS ( BOUND-VARS DECL-LIST )  ;; This function records the information specified by any  ;;  declarations that are associated with variable bindings,  ;;  except for SPECIAL which is handled in FIND-TYPE.  ;;  Declarations currently implemented here are TYPE and IGNORE.  ;;  Other declarations are handled by PROCESS-PERVASIVE-DECLARATIONS  ;;  which also issues warnings for unrecognized declarations.  ;;  ;;  8/27/86 DNG - Use new function STANDARD-TYPE-NAME-P; make  ;;RECORD-VAR-DECLARATIONS a local function; recognize dummy  ;;declarations .AUX. and .ARG.; use CANONICALIZE-TYPE-FOR-COMPILER .  ;; 10/20/86 DNG - Warn about variables declared both SPECIAL and IGNORE.  (LET ((DUPLICATED NIL))    (FLET ((RECORD-VAR-DECLARATIONS ( DECL-KIND DECL-VALUE VAR-NAME-LIST )     ;; Enters data into the VAR-DECLARATIONS slot of a variable.     (DOLIST ( VARNAME VAR-NAME-LIST )       (LET (( V (LOOKUP-VAR VARNAME BOUND-VARS) )) (COND   ((NULL V)    (UNLESS DUPLICATED      (WARN 'VAR-DECLARATIONS ':IMPLAUSIBLE    "~S declaration given for variable ~S which is not bound at the current level."    DECL-KIND VARNAME) ))   ((GETF (VAR-DECLARATIONS V) DECL-KIND)    (WARN 'VAR-DECLARATIONS ':IMPLAUSIBLE  "There is more than one ~S declaration for variable ~S."  DECL-KIND VARNAME))   ((AND (EQ DECL-KIND 'IGNORE) (EQ (VAR-TYPE V) 'FEF-SPECIAL))    (WARN 'IGNORE-SPECIAL ':IMPLAUSIBLE  "IGNORE declaration given for special variable ~S." VARNAME))   (T    (SETF (GETF (VAR-DECLARATIONS V) DECL-KIND) DECL-VALUE)    (WHEN (AND (EQ DECL-KIND 'TYPE)       (EQ (VAR-TYPE V) 'FEF-SPECIAL))      (PUSH `(VARIABLE-TYPE ,VARNAME ,DECL-VALUE)    LOCAL-DECLARATIONS) )))))) )      (DOLIST ( DECL DECL-LIST )(WHEN (CONSP DECL)  (LET (( DT (FIRST DECL) ))    (COND ((NOT (SYMBOLP DT)) NIL) ; avoid error on GETL  ((EQ DT 'IGNORE)   (RECORD-VAR-DECLARATIONS 'IGNORE 'T (REST DECL)) )  ((EQ DT 'TYPE)   (RECORD-VAR-DECLARATIONS     'TYPE (CANONICALIZE-TYPE-FOR-COMPILER (SECOND DECL) 'DECLARE)     (CDDR DECL)) )  ((STANDARD-TYPE-NAME-P DT)   (RECORD-VAR-DECLARATIONS 'TYPE DT (REST DECL)) )  ((MEMBER DT '(.AUX. .ARG.))   ;; Function P1AUX, EXPAND-LAMBDA, or EXPAND-KEYED-LAMBDA has   ;; split a lambda-list into args and aux-vars and duplicated   ;; the declarations.  Thus we might see declarations   ;; that refer to variables not bound here.   (SETQ DUPLICATED T))  (T NIL) )   ; ignore others here    ))))));Create a home for a variable.;We fill the variable's INIT slot with a list whose car is the init form;and whose cadr may be the supplied-flag-name, or with nil if there is no init at all,;rather than what is ultimately to go there (which gets there in VAR-COMPUTE-INIT).(DEFUN P1BINDVAR (VARSPEC KIND EVAL-TYPE MISC-TYPES THIS-FRAME-DECLARATIONS)  (LET (TYPE INIT-SPECS)    (COND ((NOT (ATOM VARSPEC))   (SETQ INIT-SPECS (CDR VARSPEC))   (SETQ VARSPEC (CAR VARSPEC))))    (IF (OR (EQ VARSPEC NIL) (EQ VARSPEC T))(WARN 'NIL-OR-T-SET ':IMPOSSIBLE "There is an attempt to bind ~S." VARSPEC);; If this variable is an optional arg with a specified-flag,;; remember to make a home for the flag as well.(AND (CADR INIT-SPECS)     (COND ((NEQ KIND 'FEF-ARG-OPT)    (WARN 'BAD-ARGUMENT-LIST ':IMPOSSIBLE  "The bound variable ~S has a specified-flag but isn't an optional arg."  VARSPEC))   ((NOT (SYMBOLP (CADR INIT-SPECS)))    (WARN 'BAD-ARGUMENT-LIST ':IMPOSSIBLE  "The bound variable ~S has a specified-flag ~S which isn't a symbol."  VARSPEC (CADR INIT-SPECS)))   (T    (PUSH (CREATE-SPECIFIED-FLAG-HOME (CADR INIT-SPECS)      THIS-FRAME-DECLARATIONS)  SPECIFIED-FLAGS))))(UNLESS (SYMBOLP VARSPEC)  (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE"~S, not a symbol, appears as a variable to be bound."VARSPEC))(SETQ TYPE (FIND-TYPE VARSPEC THIS-FRAME-DECLARATIONS))(WHEN (AND (EQ TYPE 'FEF-SPECIAL)   (NOT (ZEROP 1-IF-LIVE-CODE)))  (SETF (COMPILAND-SPECIAL-FLAG *CURRENT-COMPILAND*) T)  (SETQ TRE-OK NIL))(VAR-MAKE-HOME VARSPEC TYPE KIND INIT-SPECS       EVAL-TYPE MISC-TYPES))))       ;Make a home for the "specified-flag" of an optional variable;(such as, FOOP in &OPTIONAL (FOO 69 FOOP)).;It is marked with FEF-ARG-SPECIFIED-FLAG in the misc flags.;This home is pushed on VARS right after the last argument, before;the first actual aux variable, and also before any locals bound;in initializations of optionals, and its scope is the entire function.;It is of kind "aux" and initialized to the constant T;regardless of the fact that TLFUNINIT is already set and so;(usually) only FEF-INI-COMP-C is allowed at this point.(DEFUN CREATE-SPECIFIED-FLAG-HOME (NAME THIS-FRAME-DECLARATIONS)  (VAR-MAKE-HOME NAME (FIND-TYPE NAME THIS-FRAME-DECLARATIONS) 'FEF-ARG-AUX '('T) 'FEF-QT-DONTCARE '(FEF-ARG-SPECIFIED-FLAG))) (DEFUN SPECIALP (SYMBOL &OPTIONAL FREE-REFERENCE-P) ; is this symbol a special variable?  ;; Note: declarations SPECIAL and UNSPECIAL are the preferred form, but  ;;  :SPECIAL and :UNSPECIAL are also supported because they are documented in  ;;  the fifth edition of the "Lisp Machine Manual" (the 'green book'); they  ;;  may be removed at some future time.    -- D.N.G. 8/6/84  ;; 3/7/86 DNG - Don't need to check the SYSTEM-CONSTANT property.  ;; 7/2/86 DNG - Modify so that local UNSPECIAL declarations do not affect free references.  ;;9/30/86 DNG - Test THIS-FUNCTION-BARF-SPECIAL-LIST instead of BARF-SPECIAL-LIST so  ;;that errors in one function do not affect the compilation of others.  (IF (DOLIST (DECL LOCAL-DECLARATIONS    ;; Here if no local declaration says anything.    ;; Try FILE-(UN)SPECIAL-LIST which reflect global decls in the file.    (OR (MEMBER SYMBOL FILE-SPECIAL-LIST :TEST #'EQ)(AND (NOT (MEMBER SYMBOL FILE-UNSPECIAL-LIST :TEST #'EQ))     (OR ALL-SPECIAL-SWITCH (GET SYMBOL 'SPECIAL) #-Elroy ; constants in QCOM don't have SPECIAL property (GET SYMBOL 'SYSTEM-CONSTANT) (MEMBER SYMBOL THIS-FUNCTION-BARF-SPECIAL-LIST :TEST #'EQ) (MEMBER (SYMBOL-PACKAGE SYMBOL) SPECIAL-PKG-LIST :TEST #'EQ)))))(WHEN (AND (MEMBER (CAR DECL) '(SPECIAL UNSPECIAL :SPECIAL :UNSPECIAL) :TEST #'EQ)   (MEMBER SYMBOL (CDR DECL) :TEST #'EQ)   (OR (NOT FREE-REFERENCE-P) ; local UNSPECIAL doesn't affect free references       (MEMBER (CAR DECL) '(SPECIAL :SPECIAL) :TEST #'EQ)))  (RETURN (MEMBER (CAR DECL) '(SPECIAL :SPECIAL) :TEST #'EQ))))      T    NIL))(DEFUN FIND-TYPE (SYMBOL THIS-FRAME-DECLARATIONS)  ;; 8/13/84 DNG - Fix bug 401 by not doing SPECIAL inheritance in Common Lisp mode.  ;; 3/07/86 DNG - Don't need to check the SYSTEM-CONSTANT property;  ;;in C.L. mode handle UNSPECIAL scope consistently with SPECIAL  ;;and don't warn about local declarations that don't make a  ;;difference anyway.  ;; 9/30/86 DNG - Test THIS-FUNCTION-BARF-SPECIAL-LIST instead of BARF-SPECIAL-LIST so  ;;that errors in one function do not affect the compilation of others.  (OR (DOLIST (DECL THIS-FRAME-DECLARATIONS)(WHEN (AND (MEMBER (CAR DECL) '(SPECIAL UNSPECIAL :SPECIAL :UNSPECIAL) :TEST #'EQ)   (MEMBER SYMBOL (CDR DECL) :TEST #'EQ))  (RETURN (IF (MEMBER (CAR DECL) '(SPECIAL :SPECIAL) :TEST #'EQ)      'FEF-SPECIAL    'FEF-LOCAL))))      (DOLIST (DECL LOCAL-DECLARATIONS)(WHEN (AND (MEMBER (CAR DECL) '(SPECIAL UNSPECIAL :SPECIAL :UNSPECIAL) :TEST #'EQ)    (MEMBER SYMBOL (CDR DECL) :TEST #'EQ))  (LET (( LOCAL-TYPE (IF (MEMBER (CAR DECL) '(SPECIAL :SPECIAL) :TEST #'EQ) 'FEF-SPECIAL       'FEF-LOCAL) )( GLOBAL-TYPE (LET ((LOCAL-DECLARATIONS NIL))(FIND-TYPE SYMBOL NIL)) ))    (RETURN      (IF COMPILING-COMMON-LISP ; this flag is set in QCOMPILE0  (PROGN    (UNLESS (OR (EQ LOCAL-TYPE GLOBAL-TYPE)INHIBIT-STYLE-WARNINGS-SWITCH)      (WARN 'INHERITED-SPECIAL-DECLARATION ':IMPLAUSIBLE "Warning: There is a local ~A declaration for ~S outside of its binding.It needs to be at the beginning of the body of the construct that binds thevariable for it to have any effect."    (CAR DECL) SYMBOL) )    GLOBAL-TYPE );; Else Zetalisp(PROGN  (UNLESS (OR (AND (EQ LOCAL-TYPE 'FEF-LOCAL)   (EQ GLOBAL-TYPE 'FEF-LOCAL))      (NOT OBSOLETE-FUNCTION-WARNING-SWITCH)      RUN-IN-MACLISP-SWITCH )    (WARN 'INHERITED-SPECIAL-DECLARATION ':OBSOLETE  "A local ~A declaration for ~S is being inherited.The declaration should be at the beginning of the construct that binds the variable.It still works now, but fix it quickly before it stops working." (CAR DECL) SYMBOL) )  LOCAL-TYPE ))))))      (IF (OR (MEMBER SYMBOL FILE-SPECIAL-LIST :TEST #'EQ)       (AND (NOT (MEMBER SYMBOL FILE-UNSPECIAL-LIST :TEST #'EQ))   (OR ALL-SPECIAL-SWITCH       (GET SYMBOL 'SPECIAL)       #-Elroy ; constants in QCOM don't have SPECIAL property       (GET SYMBOL 'SYSTEM-CONSTANT)       (MEMBER SYMBOL THIS-FUNCTION-BARF-SPECIAL-LIST :TEST #'EQ)       (MEMBER (SYMBOL-PACKAGE SYMBOL) SPECIAL-PKG-LIST :TEST #'EQ))))  'FEF-SPECIAL'FEF-LOCAL)));Construct and return a variable home to go on VARS and ALLVARS.;This home has, in the VAR-INIT slot, not what is supposed to be there;but the actual initialization-form for the variable.;Later, VAR-COMPUTE-INIT is called to fix that up.(DEFUN VAR-MAKE-HOME (NAME TYPE KIND INIT-SPECS EVAL-TYPE MISC-TYPES &AUX HOME)  ;;  7/18/85 - Moved check for binding of DEFCONSTANT from here to P1SBIND so  ;;that the binding can be discarded.  [SPR 194]  ;; 12/07/85 - For release 3, special arguments are temporarily given addresses  ;;as arguments instead of special variables.  ;;  1/31/86 - Added call to CHECK-FOR-OBSOLETE-VARIABLE.  ;;  6/25/86 - Fixed to not do special binding for (LET ((x x)) (DECLARE (UNSPECIAL x))).    #+compiler:debug    (UNLESS (MEMBER KIND '(FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-REST FEF-ARG-AUX   FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ)      (BARF KIND 'BAD-KIND 'BARF))    (WHEN (EQ (SYMBOL-PACKAGE NAME) SI:PKG-KEYWORD-PACKAGE)(WARN 'KEYWORD-BOUND ':IMPOSSIBLE      "Binding the keyword symbol ~S." NAME))    (WHEN (AND (MEMBER NAME (CDDR SELF-FLAVOR-DECLARATION) :TEST #'EQ)        (EQ TYPE 'FEF-LOCAL))(WARN 'INSTANCE-VARIABLE-BOUND ':IMPLAUSIBLE      "Rebinding the instance variable ~S.  The new binding will be local."      NAME))    (UNLESS (COMPILING-FOR-V2)      ;; Rest args interfere with fast arg option except when there are no specials.      ;; We need to look at this to      ;;  decide how to process all the AUX variables and can't tell when processing      ;;  the first one whether the next will be special.      ;;  In any case, being wrong about this should not be able to produce      ;;  incorrect code.      (COND ((EQ KIND 'FEF-ARG-REST)     (SETQ FAST-ARGS-POSSIBLE NIL)))      (COND ((MEMBER KIND '(FEF-ARG-REQ FEF-ARG-OPT) :TEST #'EQ)     (AND INIT-SPECS (SETQ FAST-ARGS-POSSIBLE NIL)))) )    ;; Detect vars bound to themselves which fail to be special.    (WHEN (AND (EQ NAME (CAR INIT-SPECS))       (NOT (LOOKUP-VAR NAME VARS))       ;; If variable is globaly special but this binding has not already been       ;; made special, then there must have been an UNSPECIAL declaration which       ;; needs to be observed.       (NOT (OR (GET NAME 'SPECIAL)(MEMBER NAME FILE-SPECIAL-LIST :TEST #'EQ))) )      (MSPL2 NAME)      (SETQ TYPE 'FEF-SPECIAL))    (WHEN (EQ TYPE 'FEF-SPECIAL)      (CHECK-FOR-OBSOLETE-VARIABLE NAME) )    ;; Cons up the variable descriptor.    ;; Note that INIT-SPECS is not the final value that will go in the INIT slot.    (SETQ HOME (MAKE-VAR NAME NAME KIND KIND TYPE TYPE USE-COUNT NIL INIT INIT-SPECS EVAL EVAL-TYPE MISC MISC-TYPES))    (SETF (VAR-LAP-ADDRESS HOME)  ;; Not the real lap address,  ;; but something for P1 to use for the value of the variable  (IF (AND (EQ TYPE 'FEF-SPECIAL)   (OR (NOT (COMPILING-FOR-V2))       (MEMBER KIND '(FEF-ARG-AUX FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ)))      NAME      (PROG1 `(LOCAL-REF ,HOME . ,VAR-BIT)     (debug-assert (or (> var-bit propagate-var-set) ;normal case       (= 0 var-bit propagate-var-set) ; within EXTEND-LOCAL-VARIABLES       ))     (SETQ VAR-BIT (ASH VAR-BIT 1))) ) )    HOME)(DEFUN MAKE-FREE-VAR-HOME (NAME)  (MAKE-VAR NAME NAME KIND 'FEF-ARG-FREE TYPE 'FEF-SPECIAL USE-COUNT NIL    LAP-ADDRESS NAME))(DEFUN VARIABLE-WRAPUP ( NEW-VARS OLD-VARS )  ;; This function should be called by the pass 1 handler for any form that  ;; creates local variables, after the body has been processed so that all  ;; references to the variables have been seen.  It issues warnings for  ;; unused variables and flags variables that are unaltered.    ;;  9/10/86 - Original version adapted from CHECK-FOR-UNUSED-VARIABLES.  ;;  9/26/86 - Fixed suppression of warning on unused gensym variable -- this  ;;check is now done before the optimization to delete them.  (DO ((VS NEW-VARS (CDR VS)))      ((EQ VS OLD-VARS))    (LET* ((V (FIRST VS))   (ADDR (VAR-LAP-ADDRESS V))   (USE-COUNT (VAR-USE-COUNT V)))      (COND (INHIBIT-STYLE-WARNINGS-SWITCH NIL)    ((OR (EQ (VAR-NAME V) 'LISP:IGNORE) (STRING-EQUAL (VAR-NAME V) "IGNORED"))     (UNLESS (NULL USE-COUNT)       (WARN 'NOT-IGNORED ':IMPLAUSIBLE     "The variable ~S is bound and not ignored." (VAR-NAME V))))    ((GETF (VAR-DECLARATIONS V) 'IGNORE)     (UNLESS (NULL USE-COUNT)       (WARN 'NOT-IGNORED ':IMPLAUSIBLE     "The variable ~S, which is declared to be ignored, was referenced."     (VAR-NAME V))))    ((AND (NULL USE-COUNT)  (EQ (VAR-TYPE V) 'FEF-LOCAL)  (NOT (GET-FOR-TARGET (VAR-NAME V) 'IGNORABLE-VARIABLE))  (SYMBOL-PACKAGE (VAR-NAME V))  ; not a gensym  ;; make sure P1-DEAD-FORMS hasn't been skipping dead code:  (>= (OPT-SAFETY OPTIMIZE-SWITCH)      (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))  )     (LET ((FUNCTION-NAME (GET (VAR-NAME V) 'LOCAL-FUNCTION-NAME)))       (IF FUNCTION-NAME   (WARN 'NOT-USED ':IMPLAUSIBLE "The local function ~S is never used." FUNCTION-NAME) (WARN 'NOT-USED ':IMPLAUSIBLE       "The variable ~S is bound but never used." (VAR-NAME V))))))      (WHEN (AND (EQ (CAR-SAFE ADDR) 'LOCAL-REF) (NOT (LOGTEST (CDDR ADDR) ALTERED-VAR-SET)) PROPAGATE-ENABLE (COMPILING-FOR-V2)) ; don't mess up ADL;; There have been no assignments to this variable after its initial binding.;;(FORMAT T "~& Not Altered: ~A" (VAR-NAME V))(PUSH 'FEF-ARG-NOT-ALTERED (VAR-MISC V)) ))));; For a variable whose scope is ready to begin (it's about to be put on VARS),;; look for another variable whose scope already ended, to share a slot with.;; If we find a suitable one, just clobber it in.(DEFUN VAR-CONSIDER-OVERLAP (VAR)  ;;  7/11/85 - Don't share slots used in lexical closures.  ;; 12/17/85 - Simplify by using DOLIST instead of DO.  ;;  9/24/86 - Use *OVERLAP-CANDIDATES* in preference to ALLVARS.  ;; 10/10/86 - Don't overlap variable overlapped by one not in *OVERLAP-CANDIDATES*.  (AND (EQ (VAR-KIND VAR) 'FEF-ARG-INTERNAL-AUX)       (LET (( NAME (VAR-NAME VAR) )) (DOLIST ( VA (IF (LISTP *OVERLAP-CANDIDATES*)   *OVERLAP-CANDIDATES*ALLVARS)  NIL )   ;; Look for other vars with the same name;   ;; for a gensym, look for another gensym.   (WHEN (AND (OR (EQ NAME (VAR-NAME VA))  (AND (NULL (SYMBOL-PACKAGE (VAR-NAME VA)))       (NULL (SYMBOL-PACKAGE NAME))))      ;; But don't try to overlap a local with a special that      ;; happens to have the same name.      (NEQ (VAR-TYPE VA) 'FEF-SPECIAL)      ;; And don't overlap with arguments      ;; (in (LAMBDA (&OPTIONAL (A (LET (B)...)) B) ...) we      ;;  might otherwise try to do it)      (EQ (VAR-KIND VA) 'FEF-ARG-INTERNAL-AUX)      (NOT (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC VA)))      ;; Insist on a slot that represents a canonical home (does not         ;; map to another slot), and that is not currently in use      (NOT (OR (VAR-OVERLAP-VAR VA)       (BLOCK LOOK (DOLIST ( VARLIST (CONS VARS HIDDEN-ACTIVE-VARS) )   (DOLIST (V VARLIST)     (WHEN (OR (EQ V VA)       (EQ (VAR-OVERLAP-VAR V) VA))(RETURN-FROM LOOK T)))) (WHEN (LISTP *OVERLAP-CANDIDATES*)   (DO ((NEWVARS ALLVARS (CDR NEWVARS)))       ((EQ NEWVARS *OVERLAP-CANDIDATES*))     (WHEN (EQ (VAR-OVERLAP-VAR (CAR NEWVARS)) VA)(RETURN-FROM LOOK T)))) NIL ))) )     (RETURN (SETF (VAR-OVERLAP-VAR VAR) VA)))))));Given a variable home, compute its VAR-INIT and install it.;When we are called, the VAR-INIT contains the data for us to work on;which looks like (init-form arg-supplied-flag-name).;Note that for a FEF-ARG-INTERNAL-AUX variable, the init-type will;always be FEF-INI-COMP-C.;At time of call, VARS should be bound to the environment for;execution of the init form for this variable.(DEFUN VAR-COMPUTE-INIT (HOME PARALLEL)  (DECLARE (OPTIMIZE (SPEED 2)) (INLINE ADRREFP P1V))  ;; 12/07/85 - Simplified for release 3 -- no more ADL.  ;;  1/06/86 - Fix binding of special variable to (UNDEFINED-VALUE).  ;;  6/02/86 - Report error on &REST arg with default value.  ;;  7/02/86 - Allow BREAKOFF-FUNCTIONs to be value-propagated.  ;;  7/30/86 - Fix to always call P1 for initial value so EXPRESSION-SIZE is incremented.  ;;  2/04/87 DNG - Check for discrepency between declared type and initial value.  (LET* ( INIT-TYPE ( INIT-DATA NIL ) ( NAME (VAR-NAME HOME) ) ( KIND (VAR-KIND HOME) ) ( TYPE (VAR-TYPE HOME) ) ( INIT-SPECS (VAR-INIT HOME) ) ( INIT-FORM (CAR INIT-SPECS) ) ( SPECIFIED-FLAG-NAME (CADR INIT-SPECS) ) )    (DECLARE (TYPE SYMBOL NAME KIND TYPE))    (IF (COMPILING-FOR-V2);; Explorer release 3(COND ((OR (EQ KIND 'FEF-ARG-REQ)   (EQ KIND 'FEF-ARG-REST))       (UNLESS (NULL INIT-FORM) (WARN 'BAD-ARGUMENT-LIST ':IMPOSSIBLE       "The ~A argument ~S was given a default value."       (IF (EQ KIND 'FEF-ARG-REQ) "required" "&REST")       NAME) )       (SETQ INIT-TYPE 'FEF-INI-NONE) )      ((NULL INIT-FORM)       (SETQ INIT-TYPE (IF (EQ KIND 'FEF-ARG-OPT)   'FEF-INI-NIL 'FEF-INI-COMP-C)))      ((OR (EQUAL INIT-FORM '(UNDEFINED-VALUE))   #+compiler:debug   ; temporary while COMPILER2 package is used.   (EQUAL INIT-FORM '(COMPILER:UNDEFINED-VALUE)) )       (IF (EQ TYPE 'FEF-LOCAL)   (SETQ INIT-TYPE 'FEF-INI-NONE) (SETQ INIT-FORM NIL       INIT-TYPE 'FEF-INI-COMP-C) ) )      (T (UNLESS (EQ PARALLEL 'DONT-P1)   ; unless P1 was already applied   (LET ((TLEVEL NIL))     (SETQ INIT-FORM (P1V INIT-FORM))) ) (IF (AND (EQUAL INIT-FORM '(QUOTE NIL))  (EQ KIND 'FEF-ARG-OPT))     (SETQ INIT-TYPE 'FEF-INI-NIL)   (SETQ INIT-TYPE 'FEF-INI-COMP-C) ) (SETQ INIT-DATA INIT-FORM) ) )      ;; Else compiling for Explorer release 1 or 2.      (PROGN(COND ((NULL INIT-FORM))      ;; The following commented out so P1 will update EXPRESSION-SIZE. #|   ((AND (NOT (ATOM INIT-FORM))    (EQ (CAR INIT-FORM) 'QUOTE)))      ((OR (NUMBERP INIT-FORM)   (STRINGP INIT-FORM)   (EQ INIT-FORM T) )       (SETQ INIT-FORM `',INIT-FORM))  |#      ((OR (EQUAL INIT-FORM '(UNDEFINED-VALUE))   #+compiler:debug   ; temporary while COMPILER2 package is used.   (EQUAL INIT-FORM '(COMPILER:UNDEFINED-VALUE)))       ;;This is simplest thing that works.       ;; More hair is not needed for the ways these are usually generated by SETF.       (SETQ TLFUNINIT T))      (T       ;; Init is not NIL, constant or self => must P1 it, and maybe set TLFUNINIT.       (UNLESS (EQ PARALLEL 'DONT-P1)   ; unless P1 was already applied (LET ((TLEVEL NIL))   (SETQ INIT-FORM (P1V INIT-FORM))) )       (COND ((EQUAL INIT-FORM '(QUOTE NIL))      (SETQ INIT-FORM NIL))     ((NOT (ADRREFP INIT-FORM))      (SETQ TLFUNINIT T)))));; Now that we have processed the init form, determine the ADL initialization field.;; First, must we, or would we rather, use code to initialize the variable?;; Note: specified-flags MUST be initted at entry time regardless of anything else.(COND ((AND (NOT (MEMBER 'FEF-ARG-SPECIFIED-FLAG (VAR-MISC HOME)))    (OR (MEMBER KIND '(FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ)TLFUNINIT;; Don't spoil the fast arg option with nontrivial inits for aux's.(AND (EQ KIND 'FEF-ARG-AUX)     FAST-ARGS-POSSIBLE     (NOT (NULL INIT-FORM)))(COND (PARALLEL (NEQ TYPE 'FEF-LOCAL)))))       (SETQ INIT-TYPE 'FEF-INI-COMP-C)       (SETQ INIT-DATA INIT-FORM)  ; for value propagation       ;; Note: if we are initting by code, there is no advantage       ;; in binding at function entry, and doing so would       ;; make lap stupidly turn off the fast arg option!       (WHEN (EQ KIND 'FEF-ARG-AUX) (SETF (VAR-KIND HOME) (SETQ KIND 'FEF-ARG-INTERNAL-AUX)))       (SETQ TLFUNINIT T)));; If we aren't forced already not to use an init, figure out;; what type of init to use if there's no init-form: either "none" or "nil".(WHEN (NULL INIT-TYPE)  (SETQ INIT-TYPE(COND ((OR (EQ KIND 'FEF-ARG-OPT)   (AND (EQ KIND 'FEF-ARG-AUX)(EQ TYPE 'FEF-SPECIAL)))       'FEF-INI-NIL)      (T 'FEF-INI-NONE))));; Then, if there is an init form, gobble it.(COND ((AND INIT-FORM    (NEQ INIT-TYPE 'FEF-INI-COMP-C))       (COND ((NOT (MEMBER KIND '(FEF-ARG-OPT FEF-ARG-AUX FEF-ARG-INTERNAL-AUX FEF-ARG-KEY)   :TEST #'EQ))      (WARN 'BAD-ARGUMENT-LIST ':IMPOSSIBLE    "The mandatory argument ~S was given a default value."    NAME))     ;; There's a hack for binding a special var to itself.     ((AND (EQ NAME INIT-FORM)   (NEQ TYPE 'FEF-LOCAL))      (SETQ INIT-TYPE 'FEF-INI-SELF))     ((ATOM INIT-FORM)      (SETQ INIT-TYPE 'FEF-INI-C-PNTR)      (SETQ INIT-DATA (LIST 'LOCATIVE-TO-S-V-CELL INIT-FORM)))     ((EQ (CAR INIT-FORM) 'LOCAL-REF)      (SETQ INIT-TYPE 'FEF-INI-EFF-ADR)   ;Initted to value of local var      (SETQ INIT-DATA (LIST 'FIXE INIT-FORM)))     ((MEMBER (CAR INIT-FORM) '(QUOTE FUNCTION BREAKOFF-FUNCTION SELF-REF) :TEST #'EQ)       (SETQ INIT-TYPE 'FEF-INI-PNTR)      (SETQ INIT-DATA INIT-FORM))     (T (BARF INIT-FORM "init-form calculation confused" 'BARF)))))(WHEN (AND (EQ KIND 'FEF-ARG-OPT)   (OR TLFUNINIT SPECIFIED-FLAG-NAME))  ;; Once an opt arg gets an alternate starting address,  ;; all following args must be similar or else FEF-INI-COMP-C.  (SETQ TLFUNINIT T)  (SETQ INIT-TYPE 'FEF-INI-OPT-SA)  (SETQ INIT-DATA (GENSYM)) )) )   ; end of not compiling for VM2    (UNLESS (EQ KIND 'FEF-ARG-OPT)      ;; If something not an optional arg was given a specified-flag,      ;; discard that flag now.  There has already been an error message.      (SETQ SPECIFIED-FLAG-NAME NIL) )    (SETF (VAR-INIT HOME)  (LIST* INIT-TYPE INIT-DATA (AND SPECIFIED-FLAG-NAME      (DOLIST (V ALLVARS)(AND (EQ (VAR-NAME V) SPECIFIED-FLAG-NAME)     (MEMBER 'FEF-ARG-SPECIFIED-FLAG (VAR-MISC V))     (RETURN V))))))    (WHEN (AND (EQ KIND 'FEF-ARG-INTERNAL-AUX)       (EQ TYPE 'FEF-LOCAL)       (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)       (EQ INIT-FORM INIT-DATA)       (OR (NULL INIT-FORM)   (AND (CONSP INIT-DATA)(MEMBER (FIRST INIT-DATA)'(QUOTE LOCAL-REF FUNCTION BREAKOFF-FUNCTION):TEST #'EQ)) ))      ;; Record this variable as eligible to have references to it replaced       ;;  by the variable's initial value.       (SETQ PROPAGATE-VAR-SET (LOGIOR PROPAGATE-VAR-SET (CDDR (VAR-LAP-ADDRESS HOME))))      (WHEN (EQ (FIRST INIT-DATA) 'LOCAL-REF)(SETQ SUBST-VAR-SET (LOGIOR SUBST-VAR-SET (CDDR INIT-DATA))) )      )    (UNLESS (EQ KIND 'FEF-ARG-REQ)      (BLOCK CHECK-DECLARATION(LET ((DECLARED-TYPE (GETF (VAR-DECLARATIONS HOME) 'TYPE 'UNKNOWN)))  (IF (OR (EQ DECLARED-TYPE 'UNKNOWN)  (NOT (SI:TYPE-SPECIFIER-P DECLARED-TYPE)))      (RETURN-FROM CHECK-DECLARATION)    (IF (OR (NULL INIT-FORM) (QUOTEP INIT-FORM))(IF (TYPEP (SECOND INIT-FORM) DECLARED-TYPE)    (RETURN-FROM CHECK-DECLARATION)  (WARN 'SI:DISJOINT-TYPEP ':IMPOSSIBLE"(DECLARE (TYPE ~S ~S) is inconsistent with its initial value of ~S."DECLARED-TYPE NAME (SECOND INIT-FORM)) )      (LET ((INIT-TYPE (TYPE-OF-EXPRESSION INIT-FORM)))(IF (AND (NEQ INIT-TYPE 'T) (SI:DISJOINT-TYPEP INIT-TYPE DECLARED-TYPE))    (WARN 'SI:DISJOINT-TYPEP ':IMPOSSIBLE  "~S is declared to be of type ~S but its initial value is a ~S."  NAME DECLARED-TYPE INIT-TYPE)  (RETURN-FROM CHECK-DECLARATION)  ))))  (REMF (VAR-DECLARATIONS HOME) 'TYPE) ; discard the bad declaration  )))    (IF (NULL INIT-FORM)NAME      (LIST NAME INIT-FORM))))   ; end of VAR-COMPUTE-INIT (EXPORT '(*LOCAL-DECLARATIONS-SPECIFIERS*))(DEFVAR *LOCAL-DECLARATIONS-SPECIFIERS*'(SPECIAL :SPECIAL UNSPECIAL :UNSPECIAL DEF #-Elroy SI:OPEN-CODE)  "Names of declaration specifiers that will be pushed on the LOCAL-DECLARATIONS list."  ;; This is a variable so that users can push additional entries on it.  )(DEFUN PROCESS-PERVASIVE-DECLARATIONS (DECLS &OPTIONAL LOCAL-DECLS EXPR-DEBUG-INFO JUNK-ALLOWED-P)  ;; This function handles any pervasive declarations appearing within a  ;; function being compiled.  Declarations which affect variable  ;; binding are processed in P1SBIND and are ignored here.  ;; Top-level declarations are handled separately by functions  ;; DECLARE and PROCLAIM.  ;; 8/13/84 DNG - Removed (PUSHNEW VARNAME FREEVARS) since it will be  ;;done by P1 for any special variables which are actually  ;;referenced.  This avoids allocating space in the FEF for  ;;pointers to the value cells of variables declared  ;;SPECIAL but never actually referenced.  ;; 9/06/84 DNG - Changed function name from PROCESS-SPECIAL-DECLARATIONS.  ;; 9/11/84 DNG - Add error check for :SELF-FLAVOR declarations.  ;;12/07/84 DNG - Allow SELF-FLAVOR without colon.  ;; 1/18/85 DNG - Fix message to say DECLARATION instead of DECLARATIONS;  ;;   check SI:INTERPRETER-DECLARATION-TYPE-ALIST.  ;; 2/20/85 DNG - Suppress :SELF-REF error message in a certain case.  ;; 3/09/85 DNG - Disallow :SELF-REF declaration within a binding of SELF.  ;; 1/23/86 DNG - Obsolete warning on keyword declaration names.  ;; 6/18/86 DNG - Major changes to handling of debug-info declarations.  Push  ;;on LOCAL-DECLARATIONS only what is needed there.  Avoid processing  ;;top-level declarations twice.  ;; 6/20/86 DNG - Add JUNK-ALLOWED-P option.  ;; 7/02/86 DNG - Fix to allow :INTERNAL function to have :SELF-FLAVOR different from parent.  ;; 7/10/86 DNG - Fix the JUNK-ALLOWED-P option.  ;; 7/17/86 DNG - Add SYS:DOWNWARD-FUNCTION declaration.  ;; 8/26/86 DNG - Add handling for FTYPE and FUNCTION declarations [previously ignored].  ;; 9/02/86 DNG - SI:INTERPRETER-DECLARATION-TYPE-ALIST no longer used in release 3.  ;;10/01/86 DNG - Add special warning for RETURN-LIST.  ;;10/11/86 DNG - Permit :EXPR-SXHASH declaration.  ;;10/17/86 DNG - Warn on non-symbol in SPECIAL declaration.  ;;11/14/86 DNG - Fix to allow an UNSPECIAL declaration to shadow a previous SPECIAL declaration.  (DECLARE (ARGLIST THIS-FRAME-DECLARATIONS &OPTIONAL OLD-LOCAL-DECLARATIONS OLD-EXPR-DEBUG-INFO)   (VALUES NEW-LOCAL-DECLARATIONS NEW-EXPR-DEBUG-INFO))  (DOLIST (DECL DECLS)    (IF (OR (ATOM DECL) (NOT (SYMBOLP (FIRST DECL))))(WARN 'PROCESS-PERVASIVE-DECLARATIONS ':IMPOSSIBLE      "Invalid declaration syntax: (DECLARE ~S)" DECL)      (LET (( DT (FIRST DECL) ) DSTRING )(DECLARE (SYMBOL DT))(BLOCK WARNING  (COND    ( (MEMBER DT '( TYPE IGNORE .ARG. SI:DOWNWARD-FUNARG ) :TEST #'EQ)     ;; Ignore these here.  They are handled by function     ;;   PROCESS-BINDING-DECLARATIONS which is called by P1SBIND.     ;; [SYS:DOWNWARD-FUNARG is for brand S compatibility.]     )    ( (MEMBER DT '(INLINE NOTINLINE TRY-INLINE) :TEST #'EQ)     (DOLIST ( FN (REST DECL))       (IF (SI:VALIDATE-FUNCTION-SPEC FN)   (PUSH (CONS (IF (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)   (LIST ':INTERNAL (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*) FN) FN)       DT) INLINE-DECLARATIONS) (WARN 'SI:VALIDATE-FUNCTION-SPEC ':IGNORABLE-MISTAKE       "Invalid function spec ~S in ~S declaration."       FN DT) )))    ( (EQ DT 'OPTIMIZE)     (DECLARE-OPTIMIZE (REST DECL)) )    ( (EQ DT '.AUX.)     ;; duplicate declarations created by P1AUX for P1SBIND; ignore here.     (RETURN) )    ( (MEMBER DT '( FTYPE FUNCTION ) :TEST #'EQ)     (SETQ LOCAL-DECLS (DECLARE-FTYPE DECL LOCAL-FUNCTIONS LOCAL-DECLS)) )    ((MEMBER DT *LOCAL-DECLARATIONS-SPECIFIERS* :TEST #'EQ)     (COND ((MEMBER DT '(SPECIAL :SPECIAL) :TEST #'EQ)     (DOLIST (VARNAME (CDR DECL))      (IF (SYMBOLP VARNAME)  (PUSH (MAKE-FREE-VAR-HOME VARNAME) VARS)(WARN 'SPECIAL :IMPOSSIBLE      "Non-symbol ~S in (DECLARE ~S)" VARNAME DECL))))   ((MEMBER DT '(UNSPECIAL :UNSPECIAL) :TEST #'EQ)     (DOLIST (VARNAME (CDR DECL))      (IF (SYMBOLP VARNAME)  (LET ((SPECIAL NIL))    (DOLIST (V VARS)      (WHEN (EQ VARNAME (VAR-NAME V))(COND ((EQ (VAR-TYPE V) 'FEF-SPECIAL)       (SETQ SPECIAL V))      (SPECIAL       (PUSH V VARS)       (RETURN))      (T (RETURN))))))(WARN 'SPECIAL :IMPOSSIBLE      "Non-symbol ~S in (DECLARE ~S)" VARNAME DECL)))))     ;; Push these on LOCAL-DECLARATIONS for future reference.     ;;   SPECIAL and UNSPECIAL are noticed in FIND-TYPE;     ;;  DEF is used by SYS:DECLARED-DEFINITION in file MINDEFS.     ;;  SI:OPEN-CODE is used in function SI:OPEN-CODE-P which is     ;;  called by MACROEXPAND-1.     (PUSH DECL LOCAL-DECLS) )    ((STRING-EQUAL (SETQ DSTRING (STRING DT)) "SELF-FLAVOR")     (COND ((AND (OR (NULL SELF-FLAVOR-DECLARATION) ; not already declared     ;; The following test is to permit an :INTERNAL function to     ;; have a different flavor from its parent.     (AND (ZEROP EXPRESSION-SIZE) (NULL ALLVARS))) (NOT (LOOKUP-VAR 'SELF ALLVARS)))    ;; We can make this function into a method for the indicated    ;; flavor providing that SELF has been set up before the    ;; function is entered so that the microcode can get the    ;; right mapping table at function entry.    (SETF SELF-FLAVOR-DECLARATION (REST DECL))    (WHEN (AND SELF-FLAVOR-DECLARATION       ;; If the user just did (declare (:self-flavor flname)),       ;; compute the full declaration for that flavor.       (NULL (CDR SELF-FLAVOR-DECLARATION)))      (SETF SELF-FLAVOR-DECLARATION    (CDR (SI:FLAVOR-DECLARATION (CAR SELF-FLAVOR-DECLARATION)))) ))   ((INCLUDED-FLAVOR-P (SECOND DECL) (CAR SELF-FLAVOR-DECLARATION))    ;; Redundant declaration, ignore.    )   #-Elroy   ((MEMBER DECL LOCAL-DECLARATIONS :TEST #'EQ)     ;; Here when the creation of a combined method has been    ;; invoked by the compilation of a new component method.    ;; Because of the way the flavor system pushes the    ;; :SELF-FLAVOR declaration onto LOCAL-DECLARATIONS    ;; instead of putting it in a DECLARE inside the function,    ;; both flavors will have been pushed onto LOCAL-DECLARATIONS.    ;; This is not a good way of doing things, but we will    ;; allow it here temporarily until it can be cleaned up.    )   (T (WARN ':SELF-FLAVOR ':IMPOSSIBLE    "In a method for flavor ~S, there is a :SELF-FLAVOR declaration forflavor ~S, which is not included in ~S."    (CAR SELF-FLAVOR-DECLARATION) (SECOND DECL)    (CAR SELF-FLAVOR-DECLARATION) ) ) )     (RETURN-FROM WARNING) )    ( (EQ DT 'SI:DOWNWARD-FUNCTION) ; for brand S compatibility     (WHEN (AND (ZEROP (COMPILAND-EXPRESSION-SIZE *CURRENT-COMPILAND*)) ; at beginning of function(>= (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH)))       (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'SI:DOWNWARD-FUNCTION)     T))) ; used by BREAKOFF    ( (ASSOC DT #+Elroy SI:*DEBUG-STRUCT-LOCAL-DECLARATION-TYPES*#-Elroy    *DEBUG-INFO-LOCAL-DECLARATION-TYPES*:TEST #'EQ)     ;; These declarations have no effect other than to be copied into     ;; the function's debugging info.  They are significant only at the     ;; top level of the function.     (PUSH DECL EXPR-DEBUG-INFO) )    ( (EQ DT ':EXPR-SXHASH)     (PUSH (IF (COMPILING-FOR-V2) (CONS DT (SECOND DECL)) DECL)   EXPR-DEBUG-INFO)     (RETURN-FROM WARNING) )    ( (STANDARD-TYPE-NAME-P DT T)     ;; The name of a standard type; ignore here since this is     ;;  handled in PROCESS-BINDING-DECLARATIONS .     )    ( (MEMBER DT DECLARATIONS-IGNORED :TEST #'EQ)     (RETURN-FROM WARNING) )    ( (MEMBER DT '(SI:ARRAY-REGISTER SI:ARRAY-REGISTER-1D)       :TEST #'EQ)     ;; ignored for brand S compatibility     (RETURN-FROM WARNING) )    ((STRING-EQUAL DSTRING "RETURN-LIST") ; now in ZLC package     (WARN 'RETURN-LIST ':IGNORABLE-MISTAKE   "(DECLARE ~S) doesn't work anymore, use (DECLARE (VALUES ...))"   DECL)     (RETURN-FROM WARNING))        ( JUNK-ALLOWED-P     ;; At top level, LOCAL-DECLARATIONS may contain things other than     ;; valid declaration specifiers.  Just pass them through in same order.     (SETQ LOCAL-DECLS (NCONC LOCAL-DECLS (CONS DECL NIL))) )    ( T (WARN 'PROCESS-PERVASIVE-DECLARATIONS ':PROBABLE-ERROR      "Unrecognized declaration: (DECLARE ~S)If you want it allowed and ignored, do (PROCLAIM '(DECLARATION ~S))" DECL DT)(RETURN-FROM WARNING) )    )   ; end of COND  (WHEN (AND COMPILING-COMMON-LISP     (NOT INHIBIT-STYLE-WARNINGS-SWITCH)     (KEYWORDP DT))    (WARN ':DECLARE ':OBSOLETE  "(DECLARE (~S ...)) is obsolete; use (DECLARE (~A ...))."  DT DT) )  ) ; end of BLOCK WARNING))) ; end of DOLIST  (VALUES LOCAL-DECLS EXPR-DEBUG-INFO) ) ; end of PROCESS-PERVASIVE-DECLARATIONS (DEFUN DECLARE-OPTIMIZE ( CLAUSES )  (SETQ OPTIMIZE-SWITCH (COPY-OPTIMIZE-SWITCHES OPTIMIZE-SWITCH))  (DOLIST ( CLAUSE CLAUSES )    (LET ( KIND VALUE )      (IF (ATOM CLAUSE)  (SETQ  KIND CLAUSE  VALUE 3)  (SETQ  KIND (FIRST CLAUSE)  VALUE (SECOND CLAUSE)) )      (CHECK-ARG VALUE (AND (FIXNUMP VALUE) (<= 0 VALUE 3)) "an integer from 0 to 3" FIXNUMP )      (CASE KIND( SPEED (SETF (OPT-SPEED OPTIMIZE-SWITCH) VALUE) )( SPACE (SETF (OPT-SPACE OPTIMIZE-SWITCH) VALUE) )( SAFETY (SETF (OPT-SAFETY OPTIMIZE-SWITCH) VALUE) )( COMPILATION-SPEED    (SETF (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH) VALUE) )( OTHERWISE   (FERROR NIL "Invalid OPTIMIZE declaration kind: ~S" KIND) ) )     )   )  (SETF (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)(MAX (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SPACE OPTIMIZE-SWITCH)) ) )(DEFUN (:PROPERTY DECLARE P1) ( FORM )  ;; Ordinarily, DECLARE forms are processed by PROCESS-PERVASIVE-DECLARATIONS    ;; and PROCESS-BINDING-DECLARATIONS.  This handler is simply to catch  ;; declarations that have been placed where a declaration is not allowed.  (WARN 'DECLARE ':IGNORABLE-MISTAKE "Misplaced declaration: ~S" FORM)  '(QUOTE DECLARE) )(DEFUN EXTRACT-DECLARATIONS-RECORD-MACROS (BODY &OPTIONAL INITIAL-DECLS DOC-STRING-VALID-P)  "Like EXTRACT-DECLARATIONS, but also record names of macros that expand into declarations."  (DECLARE (VALUES BODY DECLARATIONS DOC-STRING))  ;;  9/11/86 Fix SPR-1308 by using PARSE-BODY instead of EXTRACT-DECLARATIONS.  ;;  9/24/86 Bind *EVALHOOK* to #'EVAL-FOR-TARGET to enable referencing things  ;;defined earlier in the same file during macro expansion.  ;;  9/26/86 Ignore errors during macro expansion.  ;; 11/15/86 Remove IGNORE-ERRORS since PARSE-BODY now does its own error recovery.  (DEBUG-ASSERT (NULL INITIAL-DECLS)) ; this arg not used anymore.  INITIAL-DECLS   (LET ((RECORD-MACROS-EXPANDED T)(*EVALHOOK* #'EVAL-FOR-TARGET))    (MULTIPLE-VALUE-BIND (NEW-BODY DECLARES DOCUMENTATION)(SI:PARSE-BODY BODY *LOCAL-ENVIRONMENT* DOC-STRING-VALID-P)      ;; PARSE-BODY returns a list of DECLARE forms but this function returns      ;; just a list of declaration specifiers.      (VALUES NEW-BODY      (IF (NULL (CDR DECLARES)) ; no more than one DECLARE  (CDR (CAR DECLARES))(LOOP FOR D IN DECLARES      APPENDING (CDR D)))      DOCUMENTATION))));Turn an internal lambda containing &AUX variables;into one containing a LET* and having no &AUX variables.(DEFUN P1AUX ( LAMBDA AGAIN-TAG )  ;; AGAIN-TAG, if not NIL, is a tag to be inserted for Tail Recursion Elim.  ;;  5/31/86 DNG - Modify to not copy the arglist unless necessary.  ;;  6/18/86 DNG - Don't duplicate the declarations when there aren't any aux vars.  ;;  8/27/86 DNG - Dummy declaration (.ARG.).  (LET (STANDARDIZED AUXVARS AUXLIST NONAUXLIST DECLS BODY(AUXDECLS NIL))    (SETQ STANDARDIZED (SI:LAMBDA-EXP-ARGS-AND-BODY LAMBDA))    (SETQ NONAUXLIST (CAR STANDARDIZED))    (SETQ AUXLIST (MEMBER '&AUX NONAUXLIST))    (IF (NULL AUXLIST)(WHEN (NULL AGAIN-TAG) (RETURN-FROM P1AUX LAMBDA))      (SETQ AUXVARS (CDR AUXLIST)    NONAUXLIST (LDIFF NONAUXLIST AUXLIST)))    (DO ((VARLIST NONAUXLIST (CDR VARLIST)) SPECIAL-FLAG)((NULL VARLIST) (IF SPECIAL-FLAG     (PUSH '&SPECIAL AUXVARS)))      (COND ((EQ (CAR VARLIST) '&SPECIAL)     (SETQ SPECIAL-FLAG T))    ((EQ (CAR VARLIST) '&LOCAL)     (SETQ SPECIAL-FLAG NIL))))    (SETQ BODY (CDR STANDARDIZED))    ;; Take all DECLAREs off the body and put them on DECLS.    (SETF (VALUES BODY DECLS)  (EXTRACT-DECLARATIONS-RECORD-MACROS BODY))    (WHEN DECLS      ;; The following second copy of the declarations which accompanies the      ;; binding of the &AUX vars is only for P1SBIND.  The dummy declaration      ;; .AUX. tells PROCESS-PERVASIVE-DECLARATIONS to ignore it.  The dummy      ;; declaration .ARG. tells PROCESS-BINDING-DECLARATIONS to not worry      ;; about references to variables that have not been defined yet.      (WHEN AUXVARS(IF (NULL NONAUXLIST)    (SETQ AUXDECLS `((DECLARE . ,DECLS))  DECLS NIL)  (PROGN    (SETQ AUXDECLS `((DECLARE (.AUX.) . ,DECLS)))    (PUSH '(.ARG.) DECLS))))      (SETQ DECLS `((DECLARE . ,DECLS))))    `(LAMBDA ,NONAUXLIST ,@DECLS        ,(IF (AND AGAIN-TAG   ; need to insert a TAGBODY (CONSP (FIRST BODY)) (EQ (FIRST (FIRST BODY)) 'BLOCK) (NULL (REST BODY)) )    `(BLOCK ,(SECOND (FIRST BODY))       (TAGBODY ,AGAIN-TAG   (RETURN-FROM ,(SECOND (FIRST BODY))     (LET* ,AUXVARS       ,@AUXDECLS       . ,(CDDR (FIRST BODY)))     )))  `(LET* ,AUXVARS ,@AUXDECLS . ,BODY)  ))    ));Turn a call to a lambda expression into a LET.;All &AUX variables in the lambda list are extracted by P1AUX.;We generate a LET, since the lambda variables should all be computed and then bound.(DEFUN EXPAND-LAMBDA (LAMBDA-EXP ARGS AGAIN-TAG ARGS-PROCESSED)  ;;  8/27/85 - Allow documentation string in lambda expressions.  [SPR 596]  ;;  8/28/86 CLM - Add arg ARGS-PROCESSED to indicate whether the form has been  ;;                through p1argc. This will affect the treatment of quoted args  ;;                later in match-args-with-values  ;;  9/16/86 DNG - Generate .ARG. and .AUX. markers for duplicated declarations.  (LET ( BODY DECLS ARGS-AND-BODY )    (SETQ ARGS-AND-BODY  (SI:LAMBDA-EXP-ARGS-AND-BODY (P1AUX LAMBDA-EXP AGAIN-TAG)))    (SETQ BODY (CDR ARGS-AND-BODY))    (MULTIPLE-VALUE-BIND ( PROGVARS PROGVALS DEFAULT-VARS DEFAULT-VALS  ERROR SPECIAL-VARS )(MATCH-ARGS-WITH-VALUES (FIRST ARGS-AND-BODY) ARGS args-processed)      (IF ERROR; too complicated to handle with inline expansion  `(DONT-OPTIMIZE (FUNCALL (FUNCTION ,LAMBDA-EXP) . ,ARGS)) ; force breakoff;; else generate inline expansion(FLET (( LIST-PAIRS ( VARS VALS );; merge args (A B) and (X Y) into ((B Y)(A X))(LET (( X NIL ))  (LOOP WHILE VARSDO (PUSH (LIST (POP VARS) (POP VALS)) X) )  X )))  ;; Take all DECLAREs off the body and put them on DECLS.  ;; Remove any documentation string since LAMBDA permits one  ;; but LET does not.  (SETF (VALUES BODY DECLS)(EXTRACT-DECLARATIONS-RECORD-MACROS BODY NIL T))  (WHEN SPECIAL-VARS    (PUSH `(SPECIAL . ,SPECIAL-VARS) DECLS))  (WHEN DEFAULT-VARS    (SETQ BODY `((LET* ,(LIST-PAIRS DEFAULT-VARS DEFAULT-VALS)   (DECLARE (.AUX.) . ,DECLS) . ,BODY)) )    (WHEN DECLS      (PUSH '(.ARG.) DECLS)))  (WHEN DECLS    (PUSH `(DECLARE . ,DECLS) BODY))  `(LET-FOR-LAMBDA ,(LIST-PAIRS PROGVARS PROGVALS) . ,BODY))))))didn't ask for a rest arg, make one for the    ;; outer function anyway.    (UNLESS REST-ARG      (SETQ REST-ARG (GENSYM)    MAYBE-REST-ARG (LIST '&REST REST-ARG)))    `(LAMBDA (,@POSITIONAL-ARGS ,@MAYBE-REST-ARG)       (DECLARE (.ARG.) . ,DECLS)       (LET* (,@(MAPCAR #'LIST PSEUDO-KEYNAMES KEYINITS)      ,@KEYFLAGS) (DECLARE (.AUX.) . ,DECLS) (AND ,REST-ARG   (SI:STORE-KEYWORD-ARG-VALUES (%STACK-FRAME-POINTER),REST-ARG ',KEYKEYS,ALLOW-OTHER-KEYS(VARIABLE-LOCATION ,(CAR PSEUDO-KEYNAMES)))) (LET* ,(NCONC KEYCHECKS AUXVARS)   (DECLARE (.AUX.) . ,DECLS)   . ,BODY)))))(DEFUN FUNCTION-P (X)  ;;  7/09/86 DNG - Add special handling for :INTERNAL functions to avoid  ;;error in SI:INTERNAL-FUNCTION-SPEC-HANDLER when called from  ;;FUNCTION-REFERENCED.  Removed obsolete (GETL X '(*EXPR ARGDESC)).  ;;  2/12/87 DNG - Fix to avoid error on reference to FUNCTION-SPEC-HANDLER. [SPR 3434]  (COND ((SYMBOLP X) (FBOUNDP X))((ATOM X) NIL)((EQ (CAR X) ':INTERNAL) (FUNCTION-P (SECOND X)))((FDEFINEDP X) T)(T (LET ((HANDLER (GET (CAR X) 'SYS:FUNCTION-SPEC-HANDLER)))     (AND HANDLER  (FUNCALL HANDLER 'SI:COMPILER-FDEFINEDP X))))))(DEFUN MSPL2 (X)  ;;  7/02/86 DNG - Don't give warning on a free reference to a variable which  ;;is globally special but locally declared UNSPECIAL.  This is so  ;;that (LET ((FOO FOO)) (DECLARE (UNSPECIAL FOO))...) is permitted  ;;as a binding of a local variable whose initial value is a special  ;;variable having the same name.  In other words, local UNSPECIAL  ;;declarations affect variable bindings but not free references.  ;;  9/30/86 DNG - Remove use of BARF-SPECIAL-LIST.  ;;  2/04/87 DNG - Special warnings for instance variable in wrong package and  ;;missing required flavors.  (WHEN (LET ( #| (BARF-SPECIAL-LIST THIS-FUNCTION-BARF-SPECIAL-LIST) |# )  (NOT (SPECIALP X T)))    ;; Here unless this variable was either 1) declared special, or    ;; 2) already used free in this function.    (UNLESS INHIBIT-SPECIAL-WARNINGS      (LET ((IVAR (FIND X (CDDR SELF-FLAVOR-DECLARATION) :TEST #'STRING-EQUAL)))(IF IVAR    (WARN 'FREE-VARIABLE ':MISSING-DECLARATION  "The variable ~S is used free; assumed special.But maybe you wanted the instance variable ~S ?" X IVAR)  (LET ((UNDEF (AND SELF-FLAVOR-DECLARATION    (SI:FLAVOR-UNDEFINED-COMPONENTS (CAR SELF-FLAVOR-DECLARATION)))))    (DECLARE (LIST UNDEF))    (IF UNDEF(PROGN (SETQ UNDEF (REMOVE-DUPLICATES UNDEF :TEST #'EQ))       (IF (CDR UNDEF)   (WARN 'FREE-VARIABLE ':MISSING-DECLARATION "The variable ~S is used free; assumed special.Note: flavor ~S requires flavors ~S which aren't defined yet." X (CAR SELF-FLAVOR-DECLARATION) UNDEF) (WARN 'FREE-VARIABLE ':MISSING-DECLARATION       "The variable ~S is used free; assumed special.Note: flavor ~S requires flavor ~S which isn't defined yet."       X (CAR SELF-FLAVOR-DECLARATION) (FIRST UNDEF))))      (WARN 'FREE-VARIABLE ':MISSING-DECLARATION    "The variable ~S is used free; assumed special." X))))))    (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))      #|      (UNLESS (OR INHIBIT-SPECIAL-WARNINGS ;Free var in a DEFSUBST shouldn't be special for whole file.  (MEMBER X BARF-SPECIAL-LIST :TEST #'EQ))(PUSH X BARF-SPECIAL-LIST))      |#      (PUSH X THIS-FUNCTION-BARF-SPECIAL-LIST))    (WHEN (LOOKUP-VAR X ALLVARS)      (WARN 'FREE-VARIABLE ':IMPOSSIBLE    " ~S was previously assumed local; you will lose!" X))))(DEFUN MAKESPECIAL (X)  ;;  1/31/86 - Added call to CHECK-FOR-OBSOLETE-VARIABLE.  (MSPL2 X)  (UNLESS (MEMBER X FREEVARS :TEST #'EQ)    (PUSH X FREEVARS)    (CHECK-FOR-OBSOLETE-VARIABLE X) )  T);Given a form, apply optimizations and expand macros until no more is possible;(at the top level).  Also apply style-checkers to the supplied input;but not to generated output.  This function is also in charge of checking for;too few or too many arguments so that this happens before optimizers are applied.; (This function used to be called OPTIMIZE, but the name was changed because ;  OPTIMIZE is now a global symbol.);; 1/17/85 - Allow STYLE-CHECKER property to be a list of functions.;; 1/19/85 - Add optional DONT-OPTIMIZE argument to enable suppressing;;     optimization and DEFSUBST expansion but still allow macro ;;     expansion and style checking.;; 6/26/85 - Save time by not calling LAMBDA-MACRO-EXPAND on an atom.;; 2/01/86 - Binding of MACRO-CONS-AREA moved from PRE-OPTIMIZE to PASS1.;; 2/19/86 - Use EVAL-FOR-TARGET for interpreting macro expanders to enable;;     referencing target-dependent definitions.;; 2/24/86 - Crude hack to avoid style-checking macro expansions.;; 5/12/86 DNG - Allow OPTIMIZERS property to be an atom.;; 6/21/86 DNG - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.;;10/17/86 DNG - Watch out for macros that RPLACA instead of consing a new form.(DEFUN PRE-OPTIMIZE (FORM CHECK-STYLE &OPTIONAL DONT-OPTIMIZE &AUX OPTIMIZATIONS-BEGUN-FLAG)  (DECLARE (OPTIMIZE SPEED))  (DO ((FN)) ((ATOM FORM)) ;Do until no more expansions possible    (IF (ATOM (CAR FORM))(SETQ FN (CAR FORM))      (PROGN(LET ((DEFAULT-CONS-AREA MACRO-CONS-AREA))  (SETQ FN (LAMBDA-MACRO-EXPAND (CAR FORM))))(OR (EQ FN (CAR FORM)) (SETQ FORM (CONS FN (CDR FORM)))) ) )    (UNLESS (OR OPTIMIZATIONS-BEGUN-FLAG(> (- (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)      (OPT-SAFETY OPTIMIZE-SWITCH))   1 ))      ;; Check for too few or too many arguments      (CHECK-NUMBER-OF-ARGS FORM FN))    ;; If function is redefined locally with FLET,    ;; don't use things that reflect its global definition.    (WHEN (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)      (RETURN))    (UNLESS OPTIMIZATIONS-BEGUN-FLAG      ;; Do style checking      (AND CHECK-STYLE (NULL INHIBIT-STYLE-WARNINGS-SWITCH)   (COND ((ATOM FN)  (WHEN (SYMBOLP FN)    (LET (( TM (GET FN 'STYLE-CHECKER) ))      (IF TM  (WHEN    ;; The following test attempts to distinguish original code    ;; which we want to style check from macro expansions which    ;; we don't want to check.    (OR (AND (EQ (CDR *LAST-ADDRESS-READ*) (%REGION-NUMBER FORM))     (PLUSP (%POINTER-DIFFERENCE *LAST-ADDRESS-READ* FORM)))#+compiler:debug(NOT *DEFAULT-DEFS-FROM-HOST*)   ; merciless option#+Elroy(EQ *PACKAGE* KERNEL-PACKAGE))    (IF (ATOM TM)(FUNCALL TM FORM)      (DOLIST ( HANDLER TM )(FUNCALL HANDLER FORM) )))#+Elroy(WHEN (AND COMPILING-COMMON-LISP   (EQ (SYMBOL-PACKAGE FN) ZETALISP-PACKAGE)   OBSOLETE-FUNCTION-WARNING-SWITCH   *WARN-OF-SUPERSEDED-FUNCTIONS-P*)  (WARN 'ZETALISP-PACKAGE :OBSOLETE"~S is a Zetalisp function which is considered obsolete in Common Lisp."FN) ))))) ((NOT RUN-IN-MACLISP-SWITCH)) ((MEMBER (CAR FN) '(GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA) :TEST #'EQ)  ;; Note: CLI:LAMBDA and CLI:NAMED-LAMBDA deliberately  ;;  omitted since this is only for MacLisp.  (LAMBDA-STYLE FN)) #-Elroy ((MEMBER (CAR FN) '(CURRY-BEFORE CURRY-AFTER) :TEST #'EQ)  (WARN 'NOT-IN-MACLISP ':MACLISP "~S does not work in Maclisp." (CAR FN)))      )))    ;; Apply optimizations    (OR (AND (SYMBOLP FN)     (NOT DONT-OPTIMIZE)     (LET (( TM (GET FN 'OPTIMIZERS) ))       (COND ((NULL TM) NIL)     ((CONSP TM)      (DOLIST (OPT TM)(UNLESS (EQ FORM (SETQ FORM (FUNCALL OPT FORM)))  ;; Optimizer changed something, don't do macros this pass  (RETURN (SETQ OPTIMIZATIONS-BEGUN-FLAG T)))))     (T (UNLESS (EQ FORM (SETQ FORM (FUNCALL TM FORM)))  ;; Optimizer changed something, don't do macros this pass  (SETQ OPTIMIZATIONS-BEGUN-FLAG T))))))(AND DONT-OPTIMIZE     ;; Expand macros but not DEFSUBSTs     (NOT (EQ (CAR-SAFE (DECLARED-DEFINITION (CAR FORM))) 'MACRO))     (RETURN) );; No optimizer did anything => try expanding macros.(WARN-ON-ERRORS ('MACRO-EXPANSION-ERROR "Error expanding macro ~S:" FN)  ;; This LET returns T if we expand something.  (LET ((OLD-FORM FORM)(DEFAULT-CONS-AREA MACRO-CONS-AREA)(RECORD-MACROS-EXPANDED T)(*EVALHOOK* #'EVAL-FOR-TARGET))    (SETQ FORM (MACROEXPAND-1 FORM *LOCAL-ENVIRONMENT*))    (IF (AND (EQ FORM OLD-FORM)     (EQ (CAR FORM) (CAR OLD-FORM)));; Stop looping, no expansions apply(RETURN)      T)));; The body of the WARN-ON-ERRORS either does RETURN or returns T.;; So if we get here, there was an error inside it.(RETURN (SETQ FORM `(ERROR-MACRO-EXPANDING ',FORM))))    ;; Only do style checking the first time around    (SETQ CHECK-STYLE NIL)    ;; If macro expansion has been done, optimize the expansion.    (SETQ DONT-OPTIMIZE NIL) )  ;; Result is FORM  FORM)(DEFPROP ERROR-MACRO-EXPANDING T :ERROR-REPORTER)(DEFUN ERROR-MACRO-EXPANDING (FORM)  (FERROR NIL "The form ~S which appeared at this pointwas not compiled due to an error in macro expansion." FORM));Given a non-atomic form issue any warnings required because of wrong number of arguments.;This function should never get an error and never warn about;anything that gets warned about elsewhere.(DEFUN CHECK-NUMBER-OF-ARGS (FORM &OPTIONAL FUNCTION)  ;; 08/06/84 DNG - Updated CHECK-NUMBER-OF-ARGS from MIT patches 98.47 and 98.50  ;;    which adds checking of keyword arguments.  ;;  4/10/85 DNG - Modified to save time by not calling the ARGLIST function  ;;    unless necessary and appropriate.  Commented out the  ;;    keyword argument checking because it was wrong.  ;;  4/15/85 DNG - Don't use ARGLIST property of %MAKE-EXPLICIT-STACK-LIST because  ;;    the compiler uses it in a way that does not exactly match the  ;;    machine instruction declared in DEFMIC.  ;;  6/26/85 DNG - For speed, avoid calling LAMBDA-MACRO-EXPAND unless really  ;;    necessary, and expand GET-FOR-TARGET inline.  ;;  7/08/85 DNG - Modify BAD-ARGUMENTS so that it is not a closure in order to  ;;    avoid a bug in microcode version 200.  ;; 10/26/85 DNG - For release 3, use GET-OPCODES instead of QINTCMP property.  ;;  4/24/86 DNG - For VM2, use ARGS-DESC instead of %ARGS-INFO; eliminate  ;;checking of Q-ARGS-PROP since it is never defined anywhere.  ;;  5/08/86 DNG - Fix VM2 handling for &REST arg.  ;;  5/15/86 DNG - Fix VM2 handling for macros.  ;;  8/09/86 DNG - Modified to use DECLARED-DEFINITION.  ;;  8/18/86 DNG - Another fix for VM2 macros; delete unused TABODY tag TOP.  ;;  8/29/86 DNG - Use argument list from function type declarations.  ;; 10/17/86 DNG - Removed use of ARGDESC property; special handling for LIST and LIST* instead.  ;;  4/06/87 DNG - Abort inline expansion that needs a macro that is not defined now. [SPR 4528]  (DECLARE (OPTIMIZE (SPEED 2)) (INLINE GET-FOR-TARGET))  (IF (NULL FUNCTION) (SETQ FUNCTION (CAR FORM)))  (LET* (TEM ARGLIST NARGS (MIN NIL) (MAX 0) #-Elroy (ARGS-INFO NIL) (LOCALP NIL) (FN FUNCTION))    (AND (SYMBOLP FN) ;; If FN is a name defined lexically by FLET or LABELS, use its definition. (SETQ LOCALP (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)) (SETQ FN (CADDR LOCALP)))    (FLET ((BAD-ARGUMENTS (NAME MSG &OPTIONAL (TYPE 'WRONG-NUMBER-OF-ARGUMENTS)        (SEVERITY ':PROBABLE-ERROR))      (WARN TYPE SEVERITY (IF (ASSOC NAME LOCAL-FUNCTIONS :TEST #'EQ)       "Locally defined function ~S called with ~A"    "Function ~S called with ~A")    NAME MSG)))      (UNLESS (ATOM FN)(SETQ FN (LAMBDA-MACRO-EXPAND FN)) )      (COND ((CONSP FN)     (IF (MEMBER (FIRST FN) SI:FUNCTION-START-SYMBOLS :TEST #'EQ) (SETQ ARGLIST (ARGLIST FN T))       (RETURN-FROM CHECK-NUMBER-OF-ARGS))     #-Elroy     (UNLESS (CONSP ARGLIST)       (RETURN-FROM CHECK-NUMBER-OF-ARGS)))    ((NOT (SYMBOLP FN))     ;;Unknown type, don't check     (RETURN-FROM CHECK-NUMBER-OF-ARGS))    ((SETQ TEM (DECLARED-DEFINITION FN))     (WHEN (EQ (CAR-SAFE TEM) 'MACRO)       ;; Don't check macros here because the expander function does it.       (RETURN-FROM CHECK-NUMBER-OF-ARGS))     #-Elroy     (SETQ ARGS-INFO (%ARGS-INFO TEM))     #+Elroy     (LET ( REST )       (MULTIPLE-VALUE-SETQ (MIN MAX REST)    (SI:ARGS-DESC TEM))       (WHEN REST (SETQ MAX MOST-POSITIVE-FIXNUM)))     #|  commented out for efficiency until the keyword     argument checking which uses it is fixed. (SETQ ARGLIST (IGNORE-ERRORS (LET ((TEM (ARGLIST FN T)))   (IF (EQ TEM 'MACRO) TEM (ARGLIST FN 'NIL))))) |#     )    ((AND (SETQ TEM (GET-OPCODES FN))  (SETQ MAX (OPCODE-NARGS TEM))))    ((AND INLINE-EXPANSIONS  (DOLIST (X (FOURTH (FIRST INLINE-EXPANSIONS)) NIL)    ;; :MACROS-EXPANDED list -- elements either NAME or (NAME . HASH)    (WHEN (IF (CONSP X) (EQ (CAR X) FN) (EQ X FN))      (RETURN T))))     ;; a macro which is not currently defined; have to abort the inline expansion.     (THROW (SECOND (FIRST INLINE-EXPANSIONS)) 'UNDEFINED-MACRO)) ; to CATCH in PROCEDURE-INTEGRATION    ((AND (SETQ TEM (OR (GET-FOR-TARGET FN 'ARGLIST) ; arglist from DEF-MISC-OP (GETDECL FN 'FUNCTION-ARG-TYPES))) ; from  DECLARE-FTYPE  (NOT (GET FN 'P2)) )   ; P2 not doing something funny     (SETQ ARGLIST TEM))    (T ;;No information available     (RETURN-FROM CHECK-NUMBER-OF-ARGS)))      (COND #-Elroy    ( ARGS-INFO     (SETQ MIN (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO)   MAX (IF (LOGTEST (LOGIOR %ARG-DESC-QUOTED-REST %ARG-DESC-EVALED-REST)    ARGS-INFO)   MOST-POSITIVE-FIXNUM (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO))) )    ( ARGLIST     (DOLIST (X ARGLIST)       (COND ((EQ X '&OPTIONAL) (SETQ MIN MAX))     ((OR (EQ X '&REST) (EQ X '&BODY) (EQ X '&KEY))      (UNLESS MIN (SETQ MIN MAX))      (SETQ MAX MOST-POSITIVE-FIXNUM)      (RETURN))     ((EQ X '&AUX) (RETURN))     ((MEMBER X LAMBDA-LIST-KEYWORDS :TEST #'EQ))     (T (INCF MAX))))     ) )      (SETQ NARGS (LENGTH (CDR FORM)));Now that we know it's not a macro      (COND ((< NARGS (OR MIN MAX))     (BAD-ARGUMENTS (CAR FORM) "too few arguments."))    ((> NARGS MAX)     (UNLESS (MEMBER (CAR FORM) '(LIST LIST* %MAKE-EXPLICIT-STACK-LIST %MAKE-EXPLICIT-STACK-LIST*))       (BAD-ARGUMENTS (CAR FORM) "too many arguments.")))    #|  -- commented out because it is wrong.  -- D.N.G. 4/12/85    ((CONSP ARGLIST)     (LET* ((KEYARGS (MEMQ '&KEY ARGLIST))    KEYFORM )       (WHEN (AND KEYARGS (SETQ KEYFORM (NTHCDR (OR MAX MIN) (CDR FORM)))) (IF (ODDP (LENGTH KEYFORM))     (BAD-ARGUMENTS (CAR FORM) "no value supplied for some keyword argument.")   (LET ((ALLOW-OTHER-KEYS (OR (MEMQ '&ALLOW-OTHER-KEYS ARGLIST)       (GETF KEYFORM ':ALLOW-OTHER-KEYS))))     (LOOP FOR KEY IN KEYFORM BY #'CDDR   WHEN (EQ (CAR-SAFE KEY) 'QUOTE) DO (SETQ KEY (CADR KEY))   DOING (COND ((KEYWORDP KEY)(UNLESS  (OR ALLOW-OTHER-KEYS      (DOLIST (X KEYARGS)(IF (MEMQ X LAMBDA-LIST-KEYWORDS)    NIL  (IF     (IF (CONSP X)(IF (CONSP (CAR X))    ;; ((:frob foo) bar)    (EQ KEY (CAAR X))  ;; (foo bar)  (STRING= KEY (CAR X)))      ;; foo      (STRING= KEY X))    (RETURN T)))))  (BAD-ARGUMENTS (CAR FORM)    (FORMAT NIL "the unrecognized keyword ~S"    KEY))))       ((CONSTANTP KEY)(BAD-ARGUMENTS (CAR FORM)  (FORMAT NIL "~S appearing where a keyword should" KEY)))   )))))))    |#     ))))(DEFUN CHECK-COLD ( FNAME )  ;; If the file being compiled has the :COLD-LOAD attribute,  ;; issue a warning message if the function with name FNAME  ;; is defined in a file which does not have the :COLD-LOAD attribute.  ;; This provides protection against trying to call something  ;; which won't be loaded yet.  ;; 1/23/85 - Original version.  ;; 2/19/85 - Temporarily suppress error in QC-FILE unless extra SAFETY.  ;; 1/31/86 - Check :COMPILATION-DEFINED pathname also.  ;; 3/14/86 - Use GET-FOR-TARGET instead of GET.  ;; 6/30/86 - Fix to not error when the pathname property is a string instead of a pathname instance.  ;;11/24/86 - Suppress warning when INHIBIT-STYLE-WARNINGS-SWITCH is true.  (DECLARE (INLINE GET-FOR-TARGET))  (WHEN (AND SI:FILE-IN-COLD-LOAD ; current file has COLD-LOAD attribute     (SYMBOLP FNAME)     ;; Temporarily suppress this check for a QC-FILE with     ;; default SAFETY; this is to avoid large numbers of errors     ;; during system builds until we are ready to clean them up.     (OR (NOT UNDO-DECLARATIONS-FLAG) (> (OPT-SAFETY OPTIMIZE-SWITCH) 1) )     #+compiler:debug     (OR (EQ TARGET-PROCESSOR HOST-PROCESSOR) (NOT QC-FILE-IN-PROGRESS) (NOT (NULL FASD-STREAM)) )     (NULL INHIBIT-STYLE-WARNINGS-SWITCH))    (LET (( PATHNAME (GET-FOR-TARGET FNAME :SOURCE-FILE-NAME) ))      (UNLESS (ATOM PATHNAME)(SETQ PATHNAME (FIRST (LAST (ASSOC 'DEFUN PATHNAME :TEST #'EQ)))) )      ;; PATHNAME is where FNAME was defined.      (UNLESS (OR (NULL PATHNAME) ; undefined functions get another message  (MEMBER PATHNAME COLD-LOAD-FILES :TEST #'EQ)   (LET (( COMPILE-PATHNAME (GET-FOR-TARGET FNAME ':COMPILATION-DEFINED) ))    (AND (NEQ COMPILE-PATHNAME PATHNAME) (MEMBER COMPILE-PATHNAME COLD-LOAD-FILES :TEST #'EQ)))  (NOT (INSTANCEP PATHNAME)));; Not among the files that we already know are in the cold load.(LET (( PLIST (AND PATHNAME (SEND PATHNAME :PROPERTY-LIST)) ))  (IF (GETF PLIST :COLD-LOAD) ; file has COLD-LOAD attribute      ;; File is ok; add it to the list.      (LET (( DEFAULT-CONS-AREA BACKGROUND-CONS-AREA ))(PUSH PATHNAME COLD-LOAD-FILES) )    ;; Check for some special cases of functions that are given    ;; temporary default definitions in SYS:SYS;LTOP.    (UNLESS (MEMBER FNAME '(FERROR CERROR SI:UNENCAPSULATE-FUNCTION-SPEC  FS:MAKE-PATHNAME-INTERNAL FS:MAKE-FASLOAD-PATHNAME  TV:WHO-LINE-FILE-STATE-SHEET  ;; the following are re-defined after the cold load  SPECIAL UNSPECIAL PROCLAIM)    :TEST #'EQ)      ;; Else, give warning.      (WARN ':COLD-LOAD ':PROBABLE-ERROR    "Warning: ~S is not available in the cold load."    FNAME) )    ) ) ) ) )  NIL );Pass 1 processing for a call to an ordinary function (ordinary, at least, for pass 1).;Processing consists of P1'ing all evaluated arguments, but not the quoted ones.;DESC is used to determine which is which.;In addition, &FUNCTIONAL arguments are broken off and separately compiled.;We process the args by copying the arglist, and rplaca'ing each arg by P1 of itself if needed.(DEFUN P1ARGC (FORM)  ;;  2/21/86 - &FUNCTIONAL implies downward funarg.  ;;  8/28/86 CLM - Changed way in which &QUOTE'd args are handled; they are  ;;                now quoted here rather than waiting until P2ARGC.  ;;  9/22/86 DNG - Bind P1VALUE to SINGLE-VALUE for use by VALUES-OPT.  ;; 11/15/86 DNG - Use %P-LDB-OFFSET instead of %P-LDB so forwarding is followed;  ;;use LET* instead of PROG.  (LET* ((ARGS-LEFT (COPY-LIST (CDR FORM))) (ARG-P1-RESULTS ARGS-LEFT) (P1VALUE 'SINGLE-VALUE) (FCTN (CAR FORM)) (def (declared-definition fctn)))    (if (or (consp def)    (and (typep def 'compiled-function) #+elroy (not (zerop (%p-ldb-offset si:%%fef-header-special-form def 0))) #-elroy (logtest (logior %arg-desc-quoted-rest %arg-desc-fef-quote-hair)  (%args-info def)) ) )(let (quote-flag functional-flag rest-flag)  ;;step through the arglist checking for quoted args  ;;creating a new arglist to return as result of p1argc  (do ((arglist (arglist def 'compile) (cdr arglist)))      ((atom args-left)       (if (null args-left)   (return-from p1argc (cons fctn arg-p1-results)) (progn   (warn ':impossible 'non-nil-end-of-form "the form ~s ends in a non-nil atomic cdr." form)   (if (atom arg-p1-results)       (return-from p1argc (list fctn))     (setf (cdr (last arg-p1-results)) nil)     (return-from p1argc (cons fctn arg-p1-results))))) )      (if (member (car arglist) lambda-list-keywords :test #'eq)(cond  ((eq (car arglist) '&quote)   (setq quote-flag t))  ((eq (car arglist) '&functional)   (setq functional-flag t))  ((eq (car arglist) '&rest)   (setq rest-flag t))  ((eq (car arglist) '&eval)   (setq quote-flag nil)) )      ;;else not a llk      (progn(cond  (quote-flag   (if rest-flag       (cond ((eql (length args-left) 1)      ;;just quote it      (setf (car args-left)    `(quote ,(car args-left))))     ((eq args-left arg-p1-results)      ;;all are rest args      (return-from p1argc(cons 'apply (cons `(function ,fctn)   (list `',arg-p1-results)))))     (t (setf (car args-left) `(quote ,(list (car args-left))))(setf (cdr (cadar args-left)) (cdr args-left))(setf (cdr args-left) nil)(return-from p1argc  (cons 'apply (cons `(function ,fctn)     arg-p1-results)))) )     (setf (car args-left)   `(quote ,(car args-left)))     ) )  (functional-flag   (setf (car args-left) (let* (( p1value 'downward-only )( tm (p1 (car args-left))))   (if (quotep tm) ;look for '(lambda...)       (p1function tm)     tm)) )   (setq functional-flag nil))  (t (setf (car args-left)    (p1 (car args-left)))     ) ) (setq args-left (cdr args-left)) )  ) )  )      ;;else follow the old way      (do ((arglist args-left (cdr arglist)))  ((atom arglist)   (if (null args-left)       (return-from p1argc (cons fctn arg-p1-results))     (progn       (warn ':impossible 'non-nil-end-of-form     "the form ~s ends in a non-nil atomic cdr."     form)       (if (atom arg-p1-results)   (return-from p1argc (list fctn)) (setf (cdr (last arg-p1-results)) nil) (return-from p1argc (cons fctn arg-p1-results)))))) ;;process the arguments (setf (car args-left)      (p1 (car args-left)) )(setq args-left (cdr args-left)))  )  )  )(DEFUN TAIL-RECURSION-ELIMINATION ( FORM AGAIN-TAG ARGLIST );; Performs tail recursion elimination by replacing function call FORM;; with a PSETQ to assign the argument variables in ARGLIST and a;; GO to AGAIN-TAG.;; Returns the expression to substitute for FORM, or NIL if unsuccessful.  ;;  2/22/86 DNG - Unshare variables used in lexical closures before looping back.  ;;  8/28/86 CLM - Add arg to call to match-args-with-values to indicate that args  ;;                have already been processed - i.e., quoted args have been quoted  ;; 12/16/86 DNG - Fix for unsharing arguments that are closed over. (LET ( ARGVARS TEMP )    (COND ( (SETQ TEMP (ASSOC AGAIN-TAG GOTAGS :TEST #'EQ)) ; tag is defined    (SETQ ARGVARS (PROGDESC-VARS (GOTAG-PROGDESC TEMP))) )       ; ARGVARS is the value of VARS saved just after the arguments were       ;     entered; this is used to bypass any shadowing of the argument names.  ( (SETQ TEMP (ASSOC (FIRST FORM) INLINE-EXPANSIONS :TEST #'EQUAL))      ; within an inline expansion; throw back to function      ;  PROCEDURE-INTEGRATION to tell it we need a tag to      ;  loop back to.    (THROW (SECOND TEMP) 'TAIL-RECURSION-ELIMINATION) )  ( T (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL) ) )   (MULTIPLE-VALUE-BIND ( PSETQVARS ; list of variable names for PSETQ of args  PSETQVALS ; list of value expressions for PSETQ  SETQVARS  ; list of defaulted variables for SETQ  SETQVALS  ; list of default values for SETQ  ERROR NIL )  (MATCH-ARGS-WITH-VALUES ARGLIST (REST FORM) t)    (WHEN ERROR (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL))    ;; Now build the replacement form, being careful to apply P1 in the    ;; correct order and in the correct lexical context.    (LET ( (SETQ-FORM NIL) PSETQ-FORM )      (LET (( VARS ARGVARS ))      (LABELS (( BUILD-PSETQ ( NAMES VALS )(IF (NULL NAMES)    NIL    (LIST* (P1SETVAR (FIRST NAMES))   (FIRST VALS)   (BUILD-PSETQ (REST NAMES) (REST VALS))   ) )))(SETQ PSETQ-FORM      (POST-OPTIMIZE (CONS 'INTERNAL-PSETQ   (BUILD-PSETQ (NREVERSE PSETQVARS)(NREVERSE PSETQVALS))))) )      (WHEN SETQVARS(SETQ SETQ-FORM      (LET ((SETQLIST NIL))(LOOP WHILE SETQVARS      DO (PROGN (PUSH (P1V (POP SETQVALS)) SETQLIST)(PUSH (P1SETVAR (POP SETQVARS)) SETQLIST) ))(CONS 'SETQ SETQLIST) ) ) ) )      (LET (( RETURN-FORM (LIST (P1 `(GO ,AGAIN-TAG))) ))(UNLESS (NULL (COMPILAND-CHILDREN *CURRENT-COMPILAND*))  (LET ((ARGS-USED-IN-CLOSURES NIL))    (DOLIST (V ARGVARS)      (WHEN (MEMBER 'FEF-ARG-USED-IN-LEXICAL-CLOSURES (VAR-MISC V) :TEST #'EQ)(PUSH (VAR-LAP-ADDRESS V) ARGS-USED-IN-CLOSURES)))    (WHEN ARGS-USED-IN-CLOSURES      (IF (VARS-USED (CONS 'PROGN (CDR FORM))     ARGS-USED-IN-CLOSURES)  (RETURN-FROM TAIL-RECURSION-ELIMINATION NIL)(SETQ PSETQ-FORM `(PROGN (UNSHARE-STACK-CLOSURE-VARS ,ARGVARS NIL) ,PSETQ-FORM)) )))  (PUSH `(UNSHARE-STACK-CLOSURE-VARS ,VARS ,(AND (TAILP ARGVARS VARS) ARGVARS))RETURN-FORM)  (DOLIST ( HV HIDDEN-ACTIVE-VARS )    (PUSH `(UNSHARE-STACK-CLOSURE-VARS ,HV NIL) RETURN-FORM) ))#+compiler:debug(when compiler-verbose  (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA));Stream may cons    (format t "~%Tail Recursion Elimination performed on ~S" (FIRST FORM))))`(PROGN ,PSETQ-FORM,SETQ-FORM. ,RETURN-FORM) )      ))))(DEFUN MAYBE-INTEGRATE ( FSPEC ARGS &OPTIONAL MAPPING-TABLE (INDECL '?) ) ;; For a call to function spec FSPEC with argument list ARGS, return ;; either an inline expansion or NIL if a call should be done instead.  (DECLARE (OPTIMIZE SPEED)) ; since it is called very often.  ;; 12/27/84 DNG - Fix extraction of declarations from interpreted definition.  ;;  1/19/85 DNG - Receive INDECL as an argument.  ;; 11/02/85 DNG - Permit use of the new debug-info structure.  ;;  2/14/86 DNG - Use FDEFINITION-SAFE instead of FDEFINEDP and FDEFINITION;  ;;    use TYPEP instead of %DATA-TYPE; use FSYMEVAL-FOR-TARGET.  ;;  3/13/86 DNG - Check new flag *DEFAULT-DEFS-FROM-HOST*.  ;;  5/08/86 DNG - Use SI:%%FEF-HEADER-SELF-MAPPING-TABLE for VM2.  ;;  5/21/86 DNG - For VM2, use %FEF-STORAGE-LENGTH-WORD instead of %FEFHI-STORAGE-LENGTH.  ;;  7/08/86 DNG - Modified to use COMPILAND structure.  ;;  7/17/86 DNG - Don't do automatic inline expansion when cross-compiling from VM1 to VM2.  ;;  9/16/86 DNG - In native compile, use SYMBOL-FUNCTION instead of FSYMEVAL-FOR-TARGET to save time.  ;; 11/15/86 DNG - Use %P-LDB-OFFSET instead of %P-LDB so forwarding is followed;  ;;use PARSE-BODY instead of EXTRACT-DECLARATIONS.  (LET ( FDEF INTERP-DEF DBUG-INFO SIZE CALLED-FLAVOR-NAME )    (AND INLINE-ENABLE (>= (OPT-SPEED OPTIMIZE-SWITCH)     (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH)) (COND ((EQUAL FSPEC (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))(AND (NULL INLINE-EXPANSIONS)     (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SPACE OPTIMIZE-SWITCH))     (SETQ FDEF (COMPILAND-DEFINITION *CURRENT-COMPILAND*)) ))       ((AND QC-FILE-IN-PROGRESS     (NOT QC-FILE-LOAD-FLAG)     ;; When compiling to a file, if the function being     ;;  called was declared earlier in this same file, get     ;;  the new definition saved by QCOMPILE0 instead of     ;;  using the older version that is currently loaded.     ;; (Note: don't check UNDO-DECLARATIONS-FLAG because     ;;  it is reset by QC-FILE-COMMON when compiling     ;;  combined flavor methods.)     (LOOP FOR D IN FILE-LOCAL-DECLARATIONS   WHEN (AND (EQ (FIRST D) 'DEF)     (EQUAL (SECOND D) FSPEC) )     RETURN (SETQ FDEF (CDDR D))   FINALLY NIL ) ))       ((AND UNDO-DECLARATIONS-FLAG      FDEFINE-FILE-PATHNAME     (EQUAL (SI:FUNCTION-SPEC-GET FSPEC ':SOURCE-FILE-NAME) FDEFINE-FILE-PATHNAME ) )  ;; Declared in same file but new definition not recorded.NIL )       ((SYMBOLP FSPEC)(AND (FBOUNDP FSPEC)     (NOT (GET FSPEC 'P2)) ; not expanded by pass 2     #+Elroy     (NOT (GET-OPCODES FSPEC)) ; not a machine instruction     (SETQ FDEF (IF (EQ *DEFAULT-DEFS-FROM-HOST* 'T)    (IF (EQ TARGET-PROCESSOR HOST-PROCESSOR)(SYMBOL-FUNCTION FSPEC)      (LET (( FILE-LOCAL-DECLARATIONS NIL ))(FSYMEVAL-FOR-TARGET FSPEC)))  (LET (( FILE-LOCAL-DECLARATIONS NIL )( LOCAL-DECLARATIONS NIL ))    (DECLARED-DEFINITION FSPEC) )))))       ((CONSP FSPEC)(AND (EQ *DEFAULT-DEFS-FROM-HOST* 'T)     (VALIDATE-FUNCTION-SPEC FSPEC)     (SETQ FDEF (SI:FDEFINITION-SAFE FSPEC)) ))       (T NIL) ) (OR ;; Called routine needs to either not be a flavor method, or be   ;; for a flavor compatible with the current method.   (NULL (COND ((TYPEP FDEF 'COMPILED-FUNCTION)(AND (NOT (ZEROP (%P-LDB-OFFSET   #+Elroy SI:%%FEF-HEADER-SELF-MAPPING-TABLE   #-Elroy %%FEFH-GET-SELF-MAPPING-TABLE   FDEF 0)))     (SETQ CALLED-FLAVOR-NAME       #-Elroy       (%P-CONTENTS-OFFSET FDEF (1- (%P-LDB-OFFSET %%FEFHI-MS-ARG-DESC-ORG  FDEF %FEFHI-MISC)))       #+Elroy       (FEF-FLAVOR-NAME FDEF) ) ) )       ((CONSP FDEF)(MULTIPLE-VALUE-BIND ( BODY DECLARES DOC )    (SI:PARSE-BODY (CDR (SI:LAMBDA-EXP-ARGS-AND-BODY FDEF)) NIL T)  (DECLARE (IGNORE BODY DOC))  (DOLIST (DECLS DECLARES) ; for each DECLARE form    (WHEN (SETQ CALLED-FLAVOR-NAME(SECOND (ASSOC ':SELF-FLAVOR (CDR DECLS) :TEST #'EQ)))      (RETURN) ))))       (T NIL) ) )   (INCLUDED-FLAVOR-P CALLED-FLAVOR-NAME (CAR SELF-FLAVOR-DECLARATION)) ) (OR (AND ;; check criteria for inline expansion        (OR (PROGN (WHEN (EQ INDECL '?)    (SETQ INDECL (INLINE-DECL FSPEC)))  (EQ INDECL 'INLINE) )   (EQ INDECL 'TRY-INLINE)   (AND (EQL (OPT-SAFETY OPTIMIZE-SWITCH) 0)(NEQ INDECL 'NOTINLINE)(> (OPT-SPEED OPTIMIZE-SWITCH)   (OPT-COMPILATION-SPEED OPTIMIZE-SWITCH))#-Elroy (NOT (COMPILING-FOR-V2))#+Elroy (COMPILING-FOR-V2)(IF (TYPEP FDEF 'COMPILED-FUNCTION)    (OR (< (SETQ SIZE (%P-CONTENTS-OFFSETFDEF#+Elroy SI:%FEF-STORAGE-LENGTH-WORD#-Elroy %FEFHI-STORAGE-LENGTH))   16.)(AND (< SIZE 50.)     (NOT (NULL ARGS))     (SOME #'QUOTEP ARGS) ) )  (EQ FDEF (COMPILAND-DEFINITION *CURRENT-COMPILAND*)) ))   (AND (CONSP (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))(CONSP FSPEC)(EQ (FIRST (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) ':METHOD)(MEMBER (THIRD (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))'(:COMBINED SI:FASLOAD-COMBINED):TEST #'EQ)(NEQ INDECL 'NOTINLINE)(> (OPT-SPEED OPTIMIZE-SWITCH)   (OPT-SAFETY OPTIMIZE-SWITCH))(EQ (FIRST FSPEC) ':METHOD) ) )       (NULL (IF (LISTP (SETQ DBUG-INFO (FUNCTION-DEBUGGING-INFO FDEF))) (ASSOC 'SI:ENCAPSULATED-DEFINITION DBUG-INFO :TEST #'EQ)  ; no encapsulations       (SI:GET-DEBUG-INFO-FIELD DBUG-INFO ':ENCAPSULATED-DEFINITION)) )       (IF (CONSP FDEF)   (SETQ INTERP-DEF FDEF) (IF (LISTP DBUG-INFO)     (AND (SETQ INTERP-DEF (ASSOC 'INTERPRETED-DEFINITION DBUG-INFO :TEST #'EQ))  (SETQ INTERP-DEF (SECOND INTERP-DEF) ) )   (SETQ INTERP-DEF (INTERPRETED-DEF FDEF))) )       (PROCEDURE-INTEGRATION FSPEC ARGS INTERP-DEF INDECL DBUG-INFO) )     ;; Here when we can't do inline expansion, but maybe we can     ;;  improve the call.     (AND (NOT (NULL SELF-FLAVOR-DECLARATION))  ;; here when compiling a flavor method  (NOT (NULL CALLED-FLAVOR-NAME))  ;; here when calling a flavor method  (NULL MAPPING-TABLE); not already passing a mapping table  (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SAFETY OPTIMIZE-SWITCH))  (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SPACE  OPTIMIZE-SWITCH))  (SETQ MAPPING-TABLE(IF (LOOKUP-VAR 'SI:.DAEMON-MAPPING-TABLE. VARS)    (IF (EQ (CAR SELF-FLAVOR-DECLARATION) CALLED-FLAVOR-NAME)'SI:.DAEMON-MAPPING-TABLE.      `(SELF-REF ,(CAR SELF-FLAVOR-DECLARATION) T ,CALLED-FLAVOR-NAME) )  (IF (EQ (CAR SELF-FLAVOR-DECLARATION) CALLED-FLAVOR-NAME)      'SYS:SELF-MAPPING-TABLE    NIL ) ) )  (EQ (CAR SELF-FLAVOR-DECLARATION) CALLED-FLAVOR-NAME) ; Temporary fix  ;; Change the call into a FUNCALL-WITH-MAPPING-TABLE so that the  ;;  mapping table can be passed to the called function instead of  ;;  it having to hunt for it.  (LIST* (IF (EQ (CAR SELF-FLAVOR-DECLARATION) CALLED-FLAVOR-NAME)     'FUNCALL-WITH-MAPPING-TABLE-INTERNAL   'FUNCALL-WITH-MAPPING-TABLE ) (LIST 'FUNCTION FSPEC) (P1V MAPPING-TABLE) ARGS )  ) ) ) ) )(DEFUN PROCEDURE-INTEGRATION ( FNAME ARGS INTERP-DEF IN-DECL DBUG-INFO      &OPTIONAL INTERNAL-COMPILAND )  ;; FNAME is the function spec of a function to be called.  ;; ARGS is the list of actual arguments for the call (already processed by P1).  ;; INTERP-DEF is the interpreted definition for the function to be called.  ;; IN-DECL is 'INLINE if function is explicitly declared INLINE.  ;; DBUG-INFO is the function's debugging information A-list.  ;; Returns the in-line expansion of the function call   ;; or returns NIL if the expansion is unsuccesful.  ;; 1/26/85 - Use P1-WITH-ANNOTATION.  ;; 2/20/85 - Restore ...-VAR-SET after aborted expansion.  ;; 11/2/85 - Modified for new debug-info structure.  ;; 3/14/86 - Don't need to save and restore FUNCTIONS-REFERENCED because it is  ;;not updated until the QLAPP phase anyway.  ;; 7/25/86 - Updated to allow integration of local functions.  ;; 8/28/86 - Added argument to expand-lambda to indicate that args have been processed  ;;           already (in particular, args have already been quoted if necessary)  ;; 8/29/86 - Pass declared function result type to P1-WITH-ANNOTATION.  ;; 9/20/86 - Use a larger size limit for breakoff functions for which this is the only reference.  ;;11/24/86 - Fix to allow a local INLINE declaration to force expansion of a  ;;function that was too large for automatic expansion.  ;; 2/05/87 - Fix for local INLINE of failed TRY-INLINE.  ;; 4/06/87 - Include the :MACROS-EXPANDED list from the debug-info in INLINE-EXPANSIONS  ;;so we can make sure that the macros we need are defined.  [SPR 4528]  (UNLESS (MEMBER (FIRST INTERP-DEF)  '(GLOBAL:NAMED-LAMBDA NAMED-LAMBDA GLOBAL:LAMBDA CLI:LAMBDA)  :TEST #'EQ)    (RETURN-FROM PROCEDURE-INTEGRATION NIL) )  (LET (( TAG (GENSYM) )( ABORT-REASON (IF (LISTP DBUG-INFO)   (CDR (ASSOC 'NOTINLINE DBUG-INFO :TEST #'EQ)) (SI:GET-DEBUG-INFO-FIELD DBUG-INFO 'NOTINLINE) ))( AGAIN-TAG NIL ) FORM( OLD-ALLVARS ALLVARS )( OLD-FREEVARS FREEVARS )( OLD-MACROS-EXPANDED MACROS-EXPANDED )( OLD-SELF-REFERENCES-PRESENT SELF-REFERENCES-PRESENT )( OLD-EXPRESSION-SIZE EXPRESSION-SIZE )( OLD-PROPAGATE PROPAGATE-VAR-SET )( OLD-USED USED-VAR-SET )( OLD-ALTERED ALTERED-VAR-SET )( OLD-SUBST SUBST-VAR-SET )( OLD-PLIST (COMPILAND-PLIST *CURRENT-COMPILAND*) ) ; SPECIALFLAG( OLD-VAR-LEVEL-COUNTS (AND INTERNAL-COMPILAND    *VAR-LEVEL-COUNTS*     (COPY-LIST *VAR-LEVEL-COUNTS*)) )( COMPILING-COMMON-LISP  (COND ((EQ (FIRST INTERP-DEF) 'NAMED-LAMBDA) T)((EQ (FIRST INTERP-DEF) 'GLOBAL:NAMED-LAMBDA) NIL)(T COMPILING-COMMON-LISP)) ))    (TAGBODY CHECK-REASON     (COND ((NULL ABORT-REASON))   ((AND (EQ ABORT-REASON 'TAIL-RECURSION-ELIMINATION) (NULL AGAIN-TAG))    (SETQ AGAIN-TAG TAG) )   ((AND (EQ ABORT-REASON 'SIZE) (OR (AND (EQ IN-DECL 'INLINE)  (SYMBOLP FNAME)  (NEQ (GET FNAME 'INLINE) 'INLINE))      (AND (NOT (NULL ARGS))   (SOME #'QUOTEP ARGS)))))   (T (RETURN-FROM PROCEDURE-INTEGRATION NIL)) )     (SETQ ABORT-REASON      (CATCH TAG(LET (( WARN-CATCHER TAG )); cause WARN to THROW back to here  ;; Create a LET-FOR-LAMBDA form which binds the function arguments.  (SETQ FORM (EXPAND-LAMBDA INTERP-DEF ARGS AGAIN-TAG t))  (UNLESS (EQ (FIRST FORM) 'LET-FOR-LAMBDA)    (RETURN-FROM PROCEDURE-INTEGRATION NIL) )  (LET ( NEW-FORM )    (SETQ NEW-FORM   (LET* (( X (LIST FNAME   TAG   (FIRST (SI:LAMBDA-EXP-ARGS-AND-BODY INTERP-DEF))   (SI:GET-DEBUG-INFO-FIELD DBUG-INFO :MACROS-EXPANDED) ; for CHECK-NUMBER-OF-ARGS   )) ( INLINE-EXPANSIONS (CONS X INLINE-EXPANSIONS) ) ( TRE-OK (CONS X TRE-OK) ) ( P1VALUE (IF (ATOM P1VALUE)       (LIST X)     (CONS X P1VALUE) ) ) ( EXPRESSION-SIZE-LIMIT  (+ EXPRESSION-SIZE      (COND ((EQ IN-DECL 'INLINE) 100.)   ((AND INTERNAL-COMPILAND (GETF (COMPILAND-PLIST INTERNAL-COMPILAND)       'USED-ONLY-ONCE))    50.)   ((AND (EQ (CAR-SAFE (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))     ':METHOD) (CONSP FNAME) (EQ (FIRST FNAME) ':METHOD) )    40. )   (T    ;; if the function was not explicitely declared INLINE,    ;; then abort the expansion if it turns out to be    ;; significantly longer than a call would have been.    (+ (LENGTH ARGS) 1       (OPT-SPEED OPTIMIZE-SWITCH)       ) ) ) ) ) ( *P-I-COMPILAND* INTERNAL-COMPILAND ))    (DECLARE (SPECIAL *P-I-COMPILAND*))    (P1-WITH-ANNOTATION      FORM #'P1-LET-FOR-P-I      (IF (> (OPT-SAFETY OPTIMIZE-SWITCH)     (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH))  'UNKNOWN(IF INTERNAL-COMPILAND    (LET ((TYPE (GETF (COMPILAND-PLIST INTERNAL-COMPILAND) 'TYPE)))      (IF (EQ (CAR-SAFE TYPE) 'FUNCTION)  (THIRD TYPE)'UNKNOWN))  (GETDECL FNAME 'FUNCTION-RESULT-TYPE 'UNKNOWN)))    ) ) )    ;; expansion has been successfully completed.    (if-debug      (when compiler-verbose(LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))   ;Stream may cons  (format t "~%Function ~S expanded inline in ~S"  FNAME  (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*) ) ) ) )    (UNLESS (OR (EQ FNAME (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*))(EQ (CAR-SAFE FNAME) ':INTERNAL))      (PUSHNEW FNAME MACROS-EXPANDED :TEST 'EQUAL) )    (RETURN-FROM PROCEDURE-INTEGRATION NEW-FORM) )    ));; end of CATCH; here if the expansion was aborted  ) ; end of SETQ ABORT-REASON;; finish un-doing the side-effects of the failed expansion(SETF ALLVARS OLD-ALLVARS      FREEVARS OLD-FREEVARS      MACROS-EXPANDED OLD-MACROS-EXPANDED      SELF-REFERENCES-PRESENT OLD-SELF-REFERENCES-PRESENT      EXPRESSION-SIZE OLD-EXPRESSION-SIZE      PROPAGATE-VAR-SET OLD-PROPAGATE      USED-VAR-SET OLD-USED      ALTERED-VAR-SET OLD-ALTERED      SUBST-VAR-SET OLD-SUBST      (COMPILAND-PLIST *CURRENT-COMPILAND*) OLD-PLIST ; SPECIALFLAG     )        (WHEN OLD-VAR-LEVEL-COUNTS  (SETQ *VAR-LEVEL-COUNTS* OLD-VAR-LEVEL-COUNTS))(if-debug  (when (and compiler-verbose     (string-equal user-id "GRAY"))   ; no one else is interested    (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))   ;Stream may cons      (format t "~%Expansion of ~S in ~S failed, reason = ~S"      FNAME (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*) ABORT-REASON) ) ) )(WHEN (OR (NEQ ABORT-REASON 'SIZE)  (NOT (IF (LISTP DBUG-INFO)   (ASSOC 'NOTINLINE DBUG-INFO :TEST #'EQ) (SI:GET-DEBUG-INFO-FIELD DBUG-INFO 'NOTINLINE) )) );;  don't try to expand this one again.;; (If expansion failed because it was too big, that does not;;  necessarily rule out trying again with different arguments.)   (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) (SYS:%INHIBIT-READ-ONLY T))     (COND ((CONSP DBUG-INFO)    (SETF (CDR DBUG-INFO)  (CONS `(NOTINLINE . ,ABORT-REASON) (CDR DBUG-INFO))) )   ((ARRAYP DBUG-INFO)    (SI:PUT-DEBUG-INFO-FIELD DBUG-INFO 'NOTINLINE ABORT-REASON))   (T (PUSH (CONS FNAME 'NOTINLINE) INLINE-DECLARATIONS) ) ) ) )(UNLESS (EQ ABORT-REASON 'SIZE)  (GO CHECK-REASON) )) )     NIL  )(DEFUN P1-LET-FOR-P-I ( FORM )  ;; The code that follows has been adapted from the handler  ;;  for LET-FOR-LAMBDA; it differs from an internal lambda in that  ;;  the lexical environment is not inherited within the body.  ;; 1/26/85 - Separated from PROCEDURE-INTEGRATION to facilitate use of P1-WITH-ANNOTATION.  ;; 6/21/86 - Bind *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.  ;; 7/07/86 - Include old VARS in result form instead of declarations.  ;; 7/10/86 - To allow integrating local functions, move the binding of  ;;LOCAL-DECLARATIONS to PROCEDURE-INTEGRATION and use *P-I-VARS* to  ;;initialize VARS.  ;; 9/16/86 - Add call to VARIABLE-WRAPUP.  ;; 9/20/86 - Move the binding of INHIBIT-STYLE-WARNINGS-SWITCH to include the call to VARIABLE-WRAPUP.  ;; 12/15/86 DNG - Add use of DYNAMIC-BINDING-HACK.  (LET ((VARS VARS) (OLD-VARS VARS) NEW-VARS(BINDP) (BODY) (VLIST)(INLINE-DECLARATIONS INLINE-DECLARATIONS)(LOCAL-DECLARATIONS NIL); NIL to prevent inheritance in FIND-TYPE(THIS-FRAME-DECLARATIONS NIL)(ENTRY-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)(INHIBIT-STYLE-WARNINGS-SWITCH T))    ;; Take all DECLAREs off the body.    (SETF (VALUES BODY THIS-FRAME-DECLARATIONS)  (EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR FORM) NIL))        ;; Bind the arguments        (SETQ VLIST (P1SBIND (CADR FORM) 'FEF-ARG-INTERNAL-AUX 'DONT-P1 NIL THIS-FRAME-DECLARATIONS))    (SETQ NEW-VARS VARS)        ;; Now P1 process the body, in a context that    ;;  does not allow any lexical inheritance from the calling function.    (LET* (( HIDDEN-ACTIVE-VARS (CONS OLD-VARS HIDDEN-ACTIVE-VARS) )   ( VARS (LOOP FOR V ON VARSUNTIL (EQ V OLD-VARS); keep just the local argsCOLLECT (FIRST V) ) )   ( OUTER-GOTAGS GOTAGS )   ( GOTAGS NIL )   ( PROGDESCS NIL )   ( RETPROGDESC NIL )   ( LOCAL-FUNCTIONS NIL )   ( *LOCAL-ENVIRONMENT* NIL )   )      (DECLARE (SPECIAL *P-I-COMPILAND*))      (UNLESS (NULL *P-I-COMPILAND*)(SETQ VARS (NCONC VARS (COMPILAND-INHERITED-VARS *P-I-COMPILAND*)))(SETQ GOTAGS(COMPILAND-INHERITED-GOTAGS *P-I-COMPILAND*)      PROGDESCS (COMPILAND-INHERITED-PROGDESCS *P-I-COMPILAND*)      RETPROGDESC (COMPILAND-INHERITED-RETPROGDESC *P-I-COMPILAND*)      LOCAL-DECLARATIONS (COMPILAND-DECLARATIONS *P-I-COMPILAND*)      LOCAL-FUNCTIONS (COMPILAND-INHERITED-LOCAL-FUNCTIONS *P-I-COMPILAND*)      *LOCAL-ENVIRONMENT* (COMPILAND-INHERITED-LOCAL-MACROS *P-I-COMPILAND*)) )      (UNLESS (NULL SELF-FLAVOR-DECLARATION)(LET (( TEM (LOOKUP-VAR 'SI:.DAEMON-MAPPING-TABLE. OLD-VARS) ))  (UNLESS (NULL TEM)    ;; In a combined flavor method, this magic variable which    ;;  holds the current mapping table needs to be kept visible.    (PUSH TEM VARS) ) ) )      (DOLIST ( P (REST P1VALUE) );; keep tags that may be needed for tail recursion elimination(PUSH (ASSOC (SECOND P) OUTER-GOTAGS :TEST #'EQ)      GOTAGS) )      (SETQ LOCAL-DECLARATIONS    (PROCESS-PERVASIVE-DECLARATIONS THIS-FRAME-DECLARATIONS))      (SETQ BODY (P1PROGN-1 BODY)); process the body      ); end of LET*    (VARIABLE-WRAPUP NEW-VARS OLD-VARS)    ;; expansion has been successfully completed.    (DYNAMIC-BINDING-HACK BINDP VLIST)    (LIST* (FIRST FORM) VLIST OLD-VARS NEW-VARS BINDP   ENTRY-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT   BODY )    ) )(DEFUN MATCH-ARGS-WITH-VALUES ( LAMBDA-LIST ACTUAL-ARGS ARGS-PROCESSED)  (DECLARE (VALUES PVARS PVALS DEFAULTVARS DEFAULTVALS ERROR SPECIAL-VARS))  ;; Matches formal arguments with actual argument values.  ;; The arguments to this function are:  ;;    LAMBDA-LIST = The formal argument list.  ;;    ACTUAL-ARGS = A list of actual argument values from a function call.  ;; Returns the following six values.  Each list returned is in  ;; reverse order.  Any &AUX variables are not returned.  ;;   ;;   1. PVARS = List of argument variables to be assigned values  ;;in parallel.  ;;   2. PVALS = List of actual value expressions corresponding to PVARS.  ;;   3. DEFAULTVARS = List of argument variables which are to be  ;;       assigned values serially after the parallel assignments  ;;       have been done.  These are unsupplied optional arguments  ;;       which are being assigned their default value, which might  ;;       reference previous arguments.  ;;   4. DEFAULTVALS = List of value expressions corresponding to DEFAULTVARS.  ;;   5. ERROR = NIL if successful, non-NIL if anything is wrong.  ;;       Note that since this routine is only used for performing  ;;       optimizations, it does not issue any error messages, nor does it  ;;       need to be able to handle all legal situations -- it just has  ;;       to indicate when the optimization cannot be done.  ;;   6. SPECIAL-VARS = List of argument variables that are declared special by  ;;       the use of a &SPECIAL in the lambda list.  ;;   ;; For example, given LAMBDA-LIST = (A &OPTIONAL B (C A) D &AUX E)  ;; and ACTUAL-ARGS = (X Y) then the values returned are:  ;; PVARS = (B A), PVALS = (Y X), DEFAULTVARS = (D C), DEFAULTVALS = (NIL A),  ;; ERROR = NIL, and SPECIAL-VARS = NIL.  ;;         ;;  1/17/85 - Allow &EXTENSION.  ;;  3/31/86 - Eliminate obsolete distinction between optional and required &KEY args.  ;;  8/28/86 - Add argument ARGS-PROCESSED to indicate that args have already been  ;;            processed, in particular, quoted args have already been quoted.  (LET ( ARGS1 VAR VAL(PVARS NIL)(PVALS NIL)(DEFAULTVARS NIL)(DEFAULTVALS NIL)(SUPPLIED-KEYS NIL) (IGNORED-VALUES NIL)(ERROR NIL)(SPECIAL-VARS NIL)(SPECIAL-FLAG NIL) (OPTIONAL NIL) (QUOTEFLAG NIL))    (SETQ ARGS1 ACTUAL-ARGS)    (DO ((ARGLIST1 LAMBDA-LIST (REST ARGLIST1))); scan formal arguments((NULL ARGLIST1) (UNLESS (NULL ARGS1) (SETQ ERROR 'MAX)) ); too many actual arguments      (SETQ VAR (FIRST ARGLIST1))      (COND ((MEMBER VAR LAMBDA-LIST-KEYWORDS :TEST #'EQ)     (COND       ((EQ VAR '&KEY)(MULTIPLE-VALUE-BIND (NIL NIL NIL NIL NIL      KEYKEYS KEYNAMES KEYOPTFS KEYINITS KEYFLAGS      ALLOW-OTHER-KEYS)    (DECODE-KEYWORD-ARGLIST LAMBDA-LIST)  (DECLARE (IGNORE KEYOPTFS)) ; not used anymore  ;; first scan the actual arguments so that the actual  ;; argument expressions will be evaluated in the correct  ;; left-to-right order.  (DO ((AAS ARGS1 (CDDR AAS)))      ((NULL AAS) NIL )    (WHEN (NULL (REST AAS)) (SETQ ERROR 'ODD))    (LET ((AA (FIRST AAS)))      (WHEN (QUOTEP AA) (SETQ AA (SECOND AA)))      (WHEN (AND (EQ AA ':ALLOW-OTHER-KEYS) (NOT (NULL (SECOND AAS))))(SETQ ALLOW-OTHER-KEYS T))      (IF (MEMBER AA SUPPLIED-KEYS :TEST #'EQ); duplicate key  (PUSH (SECOND AAS) IGNORED-VALUES)(DO ((KNS KEYNAMES (CDR KNS)); keyword arg variable names     (KKS KEYKEYS  (CDR KKS))); key symbols (in keyword package)    ((NULL KKS); actual key not in lambda list     (UNLESS ALLOW-OTHER-KEYS       (SETQ ERROR 'ALLOW-OTHER-KEYS) )     (UNLESS (KEYWORDP AA)       (SETQ ERROR 'KEYWORDP) )     (PUSH (SECOND AAS) IGNORED-VALUES) )  (WHEN (EQ AA (FIRST KKS))    (LET (( VAL (SECOND AAS) ))      (WHEN IGNORED-VALUES(SETQ VAL (LIST VAL))(LOOP WHILE IGNORED-VALUES      DO (PUSH (POP IGNORED-VALUES) VAL) )(PUSH 'PROGN VAL) )      (PUSH (FIRST KNS) PVARS); variable      (PUSH VAL PVALS); value      (PUSH AA SUPPLIED-KEYS)      (RETURN) ) ) ) ) ) )  (WHEN ERROR (RETURN))  (WHEN IGNORED-VALUES    (IF (NULL PVALS)(RETURN (SETQ ERROR 'IGNORE))      (SETF (FIRST PVALS)    (LIST* 'PROG1 (FIRST PVALS) (NREVERSE IGNORED-VALUES)) )))  ;; now scan the formal arguments to take care of any  ;; which did not have actual values supplied.  (DO ((KIS KEYINITS (CDR KIS)); default initial values       (KNS KEYNAMES (CDR KNS)); keyword arg variable names       (KKS KEYKEYS  (CDR KKS)); key symbols (in keyword package)       (KFS KEYFLAGS (CDR KFS))); supplied-flag name, or NIL if none      ((NULL KNS))    (LET* ((KEYFLAG (CAR KFS))   (KEYKEY  (CAR KKS))   (SUPPLIED (IF (MEMBER KEYKEY SUPPLIED-KEYS :TEST #'EQ) T NIL) ) )      (UNLESS SUPPLIED (PUSH (CAR KNS) DEFAULTVARS)   ; variable name(PUSH (CAR KIS) DEFAULTVALS)   ; default value)      (WHEN KEYFLAG; "supplied-p" variable(PUSH KEYFLAG  PVARS)(PUSH (LIST 'QUOTE SUPPLIED) PVALS) )      ))  (RETURN (SETQ ARGS1 NIL)) ))       ((EQ VAR '&REST)(POP ARGLIST1)(IF (AND (REST ARGLIST1) (NEQ (SECOND ARGLIST1) '&AUX))    (SETQ ERROR '&REST)) ; can't handle both &REST and &KEY(PUSH (FIRST ARGLIST1) PVARS)(PUSH (COND ( (AND QUOTEFLAG   ARGS-PROCESSED)      ARGS1)    ( QUOTEFLAG (LIST 'QUOTE ARGS1) )    ((NULL ARGS1) ''NIL)    ( T `(LIST . ,ARGS1) ) )      PVALS )(RETURN (SETQ ARGS1 NIL)))       ((EQ VAR '&OPTIONAL)(SETQ OPTIONAL T))       ((EQ VAR '&QUOTE)(SETQ QUOTEFLAG T))       ((EQ VAR '&EVAL)(SETQ QUOTEFLAG NIL))       ((EQ VAR '&SPECIAL)(SETQ SPECIAL-FLAG T))       ((EQ VAR '&LOCAL)(SETQ SPECIAL-FLAG NIL))       ((EQ VAR '&FUNCTIONAL)(IF (QUOTEP (FIRST ARGS1))    (SETQ ARGS1 (CONS (CONS 'FUNCTION (REST (FIRST ARGS1)))      (REST ARGS1) )) ) )       ((EQ VAR '&AUX) (SETQ ARGLIST1 NIL))       ((EQ VAR '&EXTENSION))       ( T (SETQ ERROR 'LAMBDA-LIST-KEYWORDS))  ;; some other keyword we don't know how to handle here.       ) ); end of COND on &... lambda keywords    (T (IF (NULL ARGS1)   (SETQ VAL ''NIL) (PROGN (SETQ VAL (FIRST ARGS1))(WHEN QUOTEFLAG (SETQ VAL      (if args-processed val  (LIST 'QUOTE val))) )))       (COND ((SYMBOLP VAR)      (WHEN SPECIAL-FLAG (PUSH VAR SPECIAL-VARS) )      (WHEN (AND (NULL ARGS1) (NOT OPTIONAL)); too few actual arguments(SETQ ERROR 'MIN)(RETURN) )      (PUSH VAR PVARS)      (PUSH VAL PVALS) )     ((ATOM VAR) (SETQ ERROR 'SYMBOLP))     (T      (WHEN (NOT OPTIONAL) (SETQ ERROR 'LIST))      (WHEN SPECIAL-FLAG (PUSH (FIRST VAR) SPECIAL-VARS) )      (COND ( ARGS1; actual argument supplied     (PUSH (FIRST VAR) PVARS)     (PUSH VAL PVALS ) )    ( T; use default value     (PUSH (FIRST VAR) DEFAULTVARS)     (PUSH (SECOND VAR) DEFAULTVALS)     ))      (WHEN (CDDR VAR); "supplied-p" variable(PUSH (THIRD VAR) PVARS)(PUSH (LIST 'QUOTE (IF ARGS1 T NIL)) PVALS))      ))       (POP ARGS1))))    (VALUES PVARS PVALS DEFAULTVARS DEFAULTVALS ERROR SPECIAL-VARS)  ))(DEFUN P1-WITH-ANNOTATION ( FORM &OPTIONAL HANDLER (TYPE 'UNKNOWN) DONT-OPTIMIZE)  ;; Do the P1 transformation on a form and attach some information to it  ;;  for use by optimizers.  This must be used to surround forms such as  ;;  LET which create new variables and may optionaly be used around any  ;;  form for which we may want to know which variables were referenced.  ;; The resulting form returned is:  ;; (THE-EXPR <form> <used> <altered> <optimize> <type>)  ;;  where: <form> is the result of applying P1 to the input form.  ;;     <used> is the set of local variables whose values are referenced  ;;     within <form>.  ;;     <altered> is the set of local variables whose values are altered  ;;     within <form>.  This does not include initial bindings of  ;;     variables whose scope is entirely within <form>, but does  ;;     reflect SETQ and such.  ;;     <optimize> holds the value of the optimization switches.  If the  ;;     <form> contains a (DECLARE (OPTIMIZE ...)) at the top  ;;     level, then this reflects the effect of that local  ;;     declaration.  ;;     <type> if supplied and not UNKNOWN, specifies the data type of  ;;     the value of <form>.   It is a type specifier such as  ;;     FIXNUM or ARRAY that indicates whatever is known about  ;;     the type.  This used by EXPR-TYPE-P.  ;; Note that if the form is a LET, the <used> and <altered> sets include  ;;  variables local to the LET as well as those outside.  (DECLARE (ARGLIST FORM &OPTIONAL (HANDLER #'P1) (TYPE 'UNKNOWN) DONT-OPTIMIZE))  ;;  ;; 1/24/85 DNG - Original version.  ;; 1/28/85 DNG - Don't bind ALTERED-VAR-SET for a LET-FOR-LAMBDA.  ;; 3/10/86 DNG - Add TYPE argument.  ;; 9/19/86 DNG - Call POST-OPTIMIZE here instead of in THE-EXPR-OPT.  ;;10/15/86 DNG - Added DONT-OPTIMIZE argument.  (LET ( UV AV BIT NEW-FORM RESULT-FORM )    (LET-IF (NEQ (CAR-SAFE FORM) 'LET-FOR-LAMBDA)    ;; Don't bind these on a LET-FOR-LAMBDA because the binding    ;; values have already been processed by P1.    ((USED-VAR-SET 0)     (ALTERED-VAR-SET 0))      (LET ((VAR-BIT VAR-BIT)    (OPTIMIZE-SWITCH OPTIMIZE-SWITCH) )(IF HANDLER    (PROGN (SETQ NEW-FORM (FUNCALL HANDLER FORM))   (UNLESS DONT-OPTIMIZE     (SETQ NEW-FORM (POST-OPTIMIZE NEW-FORM))))  (SETQ NEW-FORM(P1 FORM DONT-OPTIMIZE)))(SETQ UV USED-VAR-SET)(SETQ AV ALTERED-VAR-SET)(SETQ BIT VAR-BIT)(SETQ RESULT-FORM      (MAKE-EXPR :EXPR-FORM NEW-FORM :EXPR-USED UV :EXPR-ALTERED AV :EXPR-OPTIMIZE OPTIMIZE-SWITCH :EXPR-TYPE TYPE) )) )    (UNLESS (= BIT VAR-BIT)      ;; Now that VAR-BIT has been restored to its original value, mask the      ;; variable sets to remove the local variables whose scope has ended.      (LET (( MASK (- VAR-BIT 1)))(SETQ AV (LOGAND AV MASK))(SETQ UV (LOGAND UV MASK))(SETQ PROPAGATE-VAR-SET (LOGAND PROPAGATE-VAR-SET MASK))(SETQ SUBST-VAR-SET   (LOGAND SUBST-VAR-SET   MASK)) ) )    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET UV))    (SETQ ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET AV))    RESULT-FORM ) );;When a var is handled by P1BINDVAR which is an optional arg with a specified-flag,;;we push the flag name onto SPECIFIED-FLAGS so that a home will be made for the flag.(DEFVAR SPECIFIED-FLAGS);Process a Lambda-list (X), making the variables by default of kind KIND;(FEF-ARG-REQ for the top-level lambda,; FEF-ARG-AUX or FEF-ARG-INTERNAL-AUX for progs).;Return a prog variable list for the same variables with their initializations if any,;with P1 done on each initialization.;This function gobbles down the variables and processes keywords.;Each variable, with its appropeiate keyword info, is passed to P1LMB.;We can do either sequential or parallel binding.;Processing of variables is done in two steps:;First, create the homes;Second, if these are not FEF-ARG-INTERNAL-AUX vars,; put the homes on VARS and ALLVARS.;Third, process all the variables' initializations.;Finally, put the homes on VARS and ALLVARS if not already there.;For variables whose scope is the whole function (not FEF-ARG-INTERNAL-AUX),;the order is designed so that variables bound inside their initializations;all come after all the variables of the original (higher) level.;This is needed to make sure that (DEFUN FOO (&OPTIONAL (A (LET ((C ...)) ...)) B) ...);does not put C into VARS before B.;For FEF-ARG-INTERNAL-AUX variables, we want the variables bound;inside the initializations to come first, since they are used first.;That way, our own variables overlap with them rather than vice versa.;As a result, the variable with the original home is always the first one used.;This is important for deciding which variables need explicit initialization.;The IGNORE-NIL-P argument is used by MULTIPLE-VALUE-BIND to say; that if NIL appears as a variable, its initial value should be evaluated; and discarded.(DEFUN P1SBIND (X KIND PARALLEL IGNORE-NIL-P THIS-FRAME-DECLARATIONS)  ;;  7/18/85 - Add check for binding of a DEFCONSTANT; previously done in VAR-MAKE-HOME. [SPR 194]  ;;  9/14/85 - Use EQ instead of STRING-EQUAL to test for IGNORE.  ;;  1/09/86 - Allow "variable appears twice" message to be suppressed by INHIBIT-STYLE-WARNINGS-SWITCH.  ;;  3/07/86 - Don't set LOCAL-DECLARATIONS from redundant &SPECIAL flag.  (LET (TM EVALCODE VARN MYVARS MISC-TYPESSPECIFIED-FLAGS (SPECIALNESS NIL) ALREADY-REST-ARG)    ;; First look at the var specs and make homes, pushing them on MYVARS (reversed).    (PROG ()  (SETQ EVALCODE 'FEF-QT-DONTCARE)       A  (COND ((NULL X) (RETURN))((SETQ TM (ASSOC (CAR X)'((&OPTIONAL . FEF-ARG-OPT)  (&REST . FEF-ARG-REST) (&AUX . FEF-ARG-AUX)):TEST #'EQ)) (COND ((OR (EQ KIND 'FEF-ARG-AUX)    (EQ KIND 'FEF-ARG-INTERNAL-AUX))(WARN 'BAD-BINDING-LIST ':IMPOSSIBLE      "A lambda-list keyword (~S) appears in an internal binding list."      (CAR X)))       (T (SETQ KIND (CDR TM)))) (GO B))((SETQ TM (ASSOC (CAR X) '((&EVAL . FEF-QT-EVAL)   (&QUOTE . FEF-QT-QT)   (&QUOTE-DONTCARE . FEF-QT-DONTCARE)) :TEST #'EQ)) (SETQ EVALCODE (CDR TM)) (GO B))((SETQ TM (ASSOC (CAR X) '((&FUNCTIONAL . FEF-FUNCTIONAL-ARG)) :TEST #'EQ)) (PUSH (CDR TM) MISC-TYPES) (GO B))((EQ (CAR X) '&SPECIAL) (SETQ SPECIALNESS T) (GO B))((EQ (CAR X) '&LOCAL) (SETQ SPECIALNESS NIL) (GO B))((MEMBER (CAR X) LAMBDA-LIST-KEYWORDS :TEST #'EQ) (GO B)))  ;; LAMBDA-list keywords have jumped to B.  ;; Now (CAR X) should be a variable or (var init).  (SETQ VARN (COND ((ATOM (CAR X)) (CAR X)) (T (CAAR X))))  (UNLESS (SYMBOLP VARN)    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE  "~S appears in a list of variables to be bound." VARN)    (GO B))  (WHEN (KEYWORDP VARN) ; this check added 8/13/84 by D.N.G.    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE  "The keyword ~S appears in a list of variables to be bound.Keywords are constants and so cannot be used as names of variables." VARN)    (GO B))  (WHEN (AND (OR (GET-FOR-TARGET VARN 'SYSTEM-CONSTANT) (ASSOC VARN FILE-CONSTANTS-LIST :TEST #'EQ))     (NOT (EQ VARN 'NIL)) ; permitted in MULTIPLE-VALUE-BIND     (EQ (FIND-TYPE VARN THIS-FRAME-DECLARATIONS) 'FEF-SPECIAL) )    (WARN 'SYSTEM-CONSTANT-BOUND ':IMPLAUSIBLE  "Attempt to bind the constant ~S; the new binding will be local.If that is what you want, this message can be suppressed by (DECLARE (UNSPECIAL ~S))."  VARN VARN)    (PUSH `(UNSPECIAL ,VARN) THIS-FRAME-DECLARATIONS) )  (WHEN (AND (NOT (OR (EQ VARN 'LISP:IGNORE)      (STRING-EQUAL VARN "IGNORED")      (NULL VARN)))     ;; Does this variable appear again later?     ;; An exception is made in that a function argument can be repeated     ;; after an &AUX.     (DOLIST (X1 (CDR X))       (COND ((EQ X1 '&AUX) (RETURN NIL))     ((OR (EQ X1 VARN)  (AND (NOT (ATOM X1)) (EQ (CAR X1) VARN)))      (RETURN T))))     (OR PARALLEL (NOT INHIBIT-STYLE-WARNINGS-SWITCH)) )    (WARN 'BAD-BINDING-LIST ':IMPLAUSIBLE  "The variable ~S appears twice in one binding list."  VARN) )  (WHEN (CHAR= (CHAR (SYMBOL-NAME VARN) 0) #\&)    (WARN 'MISSPELLED-KEYWORD ':IMPLAUSIBLE  "~S is probably a misspelled keyword." VARN))  (WHEN ALREADY-REST-ARG    (WARN 'BAD-LAMBDA-LIST ':IMPOSSIBLE  "Argument ~S comes after the &REST argument." VARN))  (WHEN (EQ KIND 'FEF-ARG-REST)    (SETQ ALREADY-REST-ARG T))  (COND ((AND IGNORE-NIL-P (NULL VARN)) (LET ((P1VALUE NIL))   (P1 (CADAR X))))    ;Out of order, but works in these simple cases((OR (NULL VARN) (EQ VARN T)) (WARN 'NIL-OR-T-SET ':IMPOSSIBLE "There is an attempt to bind ~S." VARN))(T ;; Make the variable's home. (IF SPECIALNESS     (LET ((DECL (LIST 'SPECIAL       (COND ((SYMBOLP (CAR X)) (CAR X))     ((SYMBOLP (CAAR X)) (CAAR X))     (T (CADAAR X))))))       (UNLESS (SPECIALP (SECOND DECL)) ;; If already special anyway, don't put it on LOCAL-DECLARATIONS ;; to avoid warning from 