LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030373. :SYSTEM-TYPE :LOGICAL :VERSION 12. :TYPE "LISP" :NAME "P1HAND" :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 2758302756. :AUTHOR "REL3" :LENGTH-IN-BYTES 95414. :LENGTH-IN-BLOCKS 94. :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 handler functions for pass 1.   |;;;;   |  It defines how each special form is to be processed.   |;;;;   *-----------------------------------------------------------*;;; Feb. 1984 - Version 98 from MIT via LMI.;;; July 1984 through May 1985 - TI modifications for Explorer release 1.0.;;;  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/10/85 DNG - Fix handling of MULTIPLE-VALUE-LIST to avoid incorrect ;;;   compilation of the interpreter's definition of it.;;; 12/03/85 DNG - Added handler for SI:MATCHCARCDR.;;; 12/10/85 DNG - Fix P1TAGBODY for non-local GOs.;;;  4/06/86 DNG - Converted from Zetalisp to Common Lisp.;;;  5/09/86 DNG - Converted uses of MEMQ, ASSQ, and PUTPROP, and changed base to 10.;;;  6/18/86 DNG - Changed handling of LOCAL-DECLARATIONS.;;;  8/15/86 DNG - New handlers replace optimizers for DO, MAP, LET-IF, etc.;;;  9/16/86 DNG - Record side-effects in ALTERED-VAR-SET.;;; 11/17/86 DNG - Remove use of REST1 .. REST4.;;; 12/15/86 DNG - New handling for %BIND in LET with unknown number of result values.;;; 12/24/86 DNG - Fix MACROLET handler to not call SI:EXPAND-DEFMACRO which no longer exists.;;;  1/16/87 DNG - Remove suppression of CALL-N PDL-POP from FIX-FUNCALL-EVALUATION-ORDER .;;;  2/13/87 DNG - Update COMPILAND-INITIAL-ENVIRONMENT-VARS in LABELS handler.;;;  2/26/87 DNG - Don't save canonicalized type of T in P1THE .;;;  3/23/87 DNG - Fix to not use D-TAIL-REC call from frame having a locative to a local var.;;;  3/25/87 DNG - Fix to not use D-TAIL-REC call from function used in a dynamic closure.;; (MULTIPLE-VALUE-BIND variable-list m-v-returning-form . body);; turns into (MULTIPLE-VALUE-BIND variable-list vars-segment m-v-returning-form . body);; where vars-segment is a sublist of VARS that should be pushed onto VARS;; while this form is being processed on pass 2.(DEFUN (:PROPERTY MULTIPLE-VALUE-BIND P1) (FORM)  ;; 07/31/84 DNG - call P1V instead of P1.  ;; 01/24/85 DNG - use P1-WITH-ANNOTATION.  ;;  6/18/86 DNG - update handling of LOCAL-DECLARATIONS.  ;;  9/16/86 DNG - Add call to VARIABLE-WRAPUP. (P1-WITH-ANNOTATION FORM #'(LAMBDA (FORM)   (LET ((VARIABLES (CADR FORM))(VARS VARS) OUTER-VARS(LOCAL-DECLARATIONS LOCAL-DECLARATIONS)(INLINE-DECLARATIONS INLINE-DECLARATIONS)(THIS-FRAME-DECLARATIONS NIL)(M-V-FORM (CADDR FORM))(BODY (CDDDR FORM))NEW-LOCAL-DECLARATIONS)    (SETF (VALUES BODY THIS-FRAME-DECLARATIONS)  (EXTRACT-DECLARATIONS-RECORD-MACROS BODY NIL))    (SETQ NEW-LOCAL-DECLARATIONS  (PROCESS-PERVASIVE-DECLARATIONS THIS-FRAME-DECLARATIONS LOCAL-DECLARATIONS))    (SETQ OUTER-VARS VARS)    (SETQ TLEVEL NIL)    ;; P1 the m-v-returning-form outside the bindings we make.    (SETQ M-V-FORM (P1V M-V-FORM))    ;; The code should initialize each variable by popping off the stack.    ;; The values will be in forward order so we must pop in reverse order.    (SETQ VARIABLES (MAPCAR #'(LAMBDA (V) `(,V (%POP))) VARIABLES))    (P1SBIND VARIABLES 'FEF-ARG-INTERNAL-AUX T T THIS-FRAME-DECLARATIONS)    (SETQ LOCAL-DECLARATIONS NEW-LOCAL-DECLARATIONS)    (SETQ BODY (P1PROGN-1 BODY))    (VARIABLE-WRAPUP VARS OUTER-VARS)    `(,(CAR FORM) ,VARIABLES ,OUTER-VARS ,VARS ,M-V-FORM . ,BODY)))))(DEFPROP WITH-STACK-LIST  P1-WITH-STACK-LIST P1)(DEFPROP WITH-STACK-LIST* P1-WITH-STACK-LIST P1)(DEFUN P1-WITH-STACK-LIST (FORM &AUX MAKER)  ;;  2/14/86 DNG - Add 1 to the length for CHANGE-PDLLVL because P2 will  ;;    decrement PDLLVL for the %POP.  ;;  2/18/86 DNG - Use another CHANGE-PDLLVL to decrement PDLLVL by 1 after  ;;the LET to keep P2F from restoring the count before the %POP.  (SETQ MAKER (IF (EQ (CAR FORM) 'WITH-STACK-LIST*)  '%MAKE-EXPLICIT-STACK-LIST*'%MAKE-EXPLICIT-STACK-LIST))  (LET ((TRE-OK NIL) (%PUSH-DONE NIL))   (P1 `(BLOCK-FOR-WITH-STACK-LIST P1-WITH-STACK-LIST (CHANGE-PDLLVL ,(1+ (LENGTH (CDADR FORM)))(%PUSH (,MAKER . ,(CDADR FORM)))) (CHANGE-PDLLVL -1(LET ((,(CAADR FORM) (%POP)))  . ,(CDDR FORM))))))  )(DEFUN (:PROPERTY CHANGE-PDLLVL P1) (FORM)  (LIST* (CAR FORM) (CADR FORM) (MAPCAR #'P1 (CDDR FORM))))(DEFPROP %MAKE-EXPLICIT-STACK-LIST  P1EVARGS P1)(DEFPROP %MAKE-EXPLICIT-STACK-LIST* P1EVARGS P1)(DEFPROP LISTP1ASSOC P1)(DEFPROP NCONCP1ASSOC P1)(DEFPROP APPENDP1ASSOC P1)(DEFPROP LIST*P1ASSOC P1);; Convert single calls with too many args to multiple calls.(DEFUN P1ASSOC (FORM)  ;;  9/16/86 DNG - Record side-effect for NCONC.  (WHEN (EQ (FIRST FORM) 'NCONC)    (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET DATA-ALTERATION-BIT)))  (IF (< (LENGTH FORM) 64.)      (P1EVARGS FORM)    (P1 `(,(IF (EQ (CAR FORM) 'LIST)       'LIST*     (CAR FORM))   ,@(FIRSTN 61. (CDR FORM))   (,(CAR FORM)    . ,(NTHCDR 61. (CDR FORM)))))));;  (MATCHCARCDR arg car cdr)(DEFUN (:PROPERTY SI:MATCHCARCDR P1) (FORM)  ;;  3/23/85 - Fixed to bind P1VALUE and call ALTERING-VAR.  ;; 12/03/85 - Moved from file "SYS2;SELEV" to here.  ;; 12/04/85 - Alternate handling for target machines that don't  ;;have the PUSH-CDR-STORE-CAR-IF-CONS instruction.  ;;  9/03/86 - Include MATCHCARCDR-CONVERT-LAMBDA here as a local function.  (IF (NOT (COMPILING-FOR-V2))      (FLET ((SI:MATCHCARCDR-CONVERT-LAMBDA (LAMBDA-EXP)               (LET ((ARGNAME (CAR (CADR LAMBDA-EXP)))) (IF (AND (CONSP (THIRD LAMBDA-EXP))  (EQ (SECOND (THIRD LAMBDA-EXP))      ARGNAME))     (LIST* (FIRST (THIRD LAMBDA-EXP)) '(%POP) (CDDR (THIRD LAMBDA-EXP)))   (IF (AND (CONSP (THIRD LAMBDA-EXP))    (EQ (FIRST (THIRD LAMBDA-EXP)) 'PROGN)    (EQ (FIRST (SECOND (THIRD LAMBDA-EXP))) 'SETQ))       `(PROGN (SETQ ,(SECOND (SECOND (THIRD LAMBDA-EXP))) (%POP)) T)     `(PROGN (%POP) ,(THIRD LAMBDA-EXP)))))       ))(LET (( CAREXP (SI:MATCHCARCDR-CONVERT-LAMBDA (THIRD FORM)) )      ( P1VALUE T ))  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET DATA-ALTERATION-BIT))  (COND ((EQ (FIRST CAREXP) 'EQUAL) `(AND (PUSH-CDR-IF-CAR-EQUAL ,(P1 (SECOND FORM))      ,(P1 (THIRD CAREXP)))       ,(P1 (SI:MATCHCARCDR-CONVERT-LAMBDA (FOURTH FORM)))))((AND (EQ (FIRST CAREXP) 'PROGN)      (EQ (FIRST (SECOND CAREXP)) 'SETQ)) (P1SETVAR (SECOND (SECOND CAREXP))) `(AND (PUSH-CDR-STORE-CAR-IF-CONS ,(P1 (SECOND FORM)) ,(ALTERING-VAR (P1 (SECOND (SECOND CAREXP)))))       ,(P1 (SI:MATCHCARCDR-CONVERT-LAMBDA (FOURTH FORM)))))(T `(AND (CONSP-OR-POP ,(P1 (SECOND FORM)))       (PROGN (%PUSH (CARCDR (%POP)))      (COND (,(P1 CAREXP)     ,(P1 (SI:MATCHCARCDR-CONVERT-LAMBDA (FOURTH FORM))))    ('T (%POP) 'NIL))))))))    ;; Else, make-do without PUSH-CDR-IF-CAR-EQUAL instruction.    (P1 `(LET (( .MATCH-ARG. ,(SECOND FORM) ))   (AND (CONSP .MATCH-ARG.)(,(THIRD FORM) (CAR .MATCH-ARG.))(,(FOURTH FORM) (CDR .MATCH-ARG.)) ) ) )    ) );Analyze a LET's variable bindings and tags,;and convert it to an internal form which looks like;(LET* <variable list, with keywords processed and removed>;      <value of VARS outside of this prog>;      <value of VARS for body of this prog>;      <T if BIND used within this prog>;      <LEXICAL-CLOSURE-COUNT at start of LET>;      <LEXICAL-CLOSURE-COUNT at end of LET>;      . <body, P1'ified>);LET* does sequential binding, and LET does parallel binding.;P1LAMBDA and P1AUX generate LET or LET* as appropriate.(DEFUN P1LET (FORM)  ;; 12/16/85 DNG - Don't use FEF-ARG-AUX or FEF-INI-PNTR for release 3.  ;;  6/18/86 DNG - update handling of LOCAL-DECLARATIONS.  ;;  7/15/86 DNG - Bind LEXICAL-CLOSURE-COUNT to itself.  ;;  9/10/86 DNG - Add call to VARIABLE-WRAPUP.  ;;  9/12/86 DNG - Prevent issuing duplicate warnings on the first body form.  ;;  9/19/86 DNG - Fix SETQ optimization to produce the correct result value  ;;when the SETQ is the last form in the body.  [SPR 2702]  ;; 12/15/86 DNG - Create a local variable to hold the special-pdl-index when needed.  (LET ((VARS VARS) OUTER-VARS(FN (CAR FORM))(VLIST (CADR FORM))(BODY (CDDR FORM))(TRE-OK TRE-OK)(LOCAL-DECLARATIONS LOCAL-DECLARATIONS)(INLINE-DECLARATIONS INLINE-DECLARATIONS)(THIS-FRAME-DECLARATIONS NIL)(LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)(ENTRY-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT))    ;; Take all DECLAREs off the body.    (SETF (VALUES BODY THIS-FRAME-DECLARATIONS)  (EXTRACT-DECLARATIONS-RECORD-MACROS BODY NIL))    ;; All the local declarations should be in effect for the init forms.    (SETF LOCAL-DECLARATIONS  (PROCESS-PERVASIVE-DECLARATIONS THIS-FRAME-DECLARATIONS LOCAL-DECLARATIONS))    (SETQ OUTER-VARS VARS)    ;; Treat parallel binding as serial if it doesn't matter.    (UNLESS (CDR VLIST) (SETQ FN 'LET*))    (WHEN (EQ FN 'LET) (DO ((XX VLIST (CDR XX)))     ((NULL XX) (SETQ FN 'LET*))   ;; Namely, if binding each symbol to NIL, a constant, or itself.   (OR (ATOM (CAR XX))       (CONSTANTP (CADAR XX))       (EQ (CAAR XX) (CADAR XX))       (RETURN NIL))))    (comment ; - deleted 12/7/85 by D.N.G. because:     ;   1. TLEVEL is always NIL now unless TRE-ENABLE is false.     ;   2. Value propagation now does an equivalent optimization.     ;   3. This code does not correctly handle &SPECIAL keywords.    ;; Flush rebinding a var to itself if it isn't special    ;; and range of rebinding is rest of function.    (AND TLEVEL (SETQ VLIST       (SUBSET-NOT #'(LAMBDA (VAR)       (AND (NOT (ATOM VAR))    (EQ (CAR VAR) (CADR VAR))    (EQ (FIND-TYPE (CAR VAR) THIS-FRAME-DECLARATIONS)'FEF-LOCAL)    (EQ (VAR-TYPE (LOOKUP-VAR (CAR VAR) VARS)) 'FEF-LOCAL)))   VLIST)))    ) ; end comment    ;; &AUX vars should be allowed to inherit special declarations    ;; since that is what it looks like when you put a DECLARE inside the body.    (SETQ VLIST (P1SBIND VLIST (IF (AND TLEVEL  (NOT (COMPILING-FOR-V2)))     'FEF-ARG-AUX   'FEF-ARG-INTERNAL-AUX) (EQ FN 'LET) NIL THIS-FRAME-DECLARATIONS))    ;; Now convert initial SETQs to variable initializations.    ;; We win only for SETQs of variables bound but with no initialization spec'd,    ;; which set them to constant values, and only if later vars' inits didn't use them.    ;; When we come to anything other than a SETQ we can win for, we stop.    ;; For PROG*, we can't win for a special variable if anyone has called a function    ;; to do initting, since that function might have referred to the special.    ;; Even if we don't use tha ADL to init them,    ;; we avoid redundant settings to NIL.    (DO ((TEM) (HOME)) (NIL)      (COND ((EQUAL (CAR BODY) '(SETQ))     (SETQ BODY (CDR BODY)))    ((OR (ATOM (CAR BODY)) (ATOM (SETQ TEM (LET (( WARN-CATCHER 'P1LET ))   (CATCH WARN-CATCHER ; suppress warnings from optimizers     (PRE-OPTIMIZE (CAR BODY) NIL))))) (NOT (EQ (CAR TEM) 'SETQ)) (NOT (MEMBER (CADR TEM) VLIST :TEST #'EQ)) (NOT (CONSTANTP (CADDR TEM))) (AND (SPECIALP (CADR TEM))      (OR TLFUNINIT (NOT TLEVEL))      (EQ FN 'LET*)) (NOT (NULL (VAR-USE-COUNT (SETQ HOME (LOOKUP-VAR (CADR TEM) VARS))))))     (RETURN NIL))    (T (SETQ BODY     (IF (AND (NULL (CDR BODY)) (NULL (CDDDR TEM))) (LIST (CADR TEM))       (CONS (CONS 'SETQ (CDDDR TEM)) (CDR BODY))))       (RPLACA (MEMBER (CADR TEM) VLIST :TEST #'EQ)        `(,(CADR TEM) ,(P1V (CADDR TEM))))       (P1SETVAR (CADR TEM)) ; to prevent propagation of original NIL value.       ;; For a variable bound at function entry, really set up its init.       ;; Other vars (FEF-ARG-INTERNAL-AUX) will be initted by code,       ;; despite our optimization, but it will be better code.       (WHEN (AND TLEVEL  (EQ (VAR-KIND HOME) 'FEF-ARG-AUX)  (NOT (COMPILING-FOR-V2)) ) (SETF (VAR-INIT HOME) `(FEF-INI-PNTR ,(P1V (CADDR TEM))))))))    ;; Now P1 process what is left of the body.    (LET ((BINDP NIL))      (WHEN (CDR BODY) (SETQ TLEVEL NIL))      (SETQ BODY (P1PROGN-1 BODY))      (VARIABLE-WRAPUP VARS OUTER-VARS)      (DYNAMIC-BINDING-HACK BINDP VLIST)      `(,FN ,VLIST ,OUTER-VARS ,VARS ,BINDP,ENTRY-LEXICAL-CLOSURE-COUNT ,LEXICAL-CLOSURE-COUNT. ,BODY)) ));; This is supposed to differ from regular LET;; by preventing declarations in the body from applying to the variable init forms.;; It also must not turn SETQs into init forms, because the declarations;; do apply to the SETQs within the body.(DEFUN (:PROPERTY LET-FOR-LAMBDA P1) (FORM)  ;;  6/18/86 DNG - update handling of LOCAL-DECLARATIONS.  ;;  7/07/86 DNG - Include old VARS in result form instead of declarations.  ;;  7/15/86 DNG - Bind LEXICAL-CLOSURE-COUNT to itself.  ;;  9/16/86 DNG - Add call to VARIABLE-WRAPUP.  ;; 12/15/86 DNG - Add use of DYNAMIC-BINDING-HACK. (P1-WITH-ANNOTATION FORM #'(LAMBDA (FORM)  (LET ((VARS VARS) OUTER-VARS INNER-VARSBODY VLIST (TRE-OK TRE-OK)(LOCAL-DECLARATIONS LOCAL-DECLARATIONS)(INLINE-DECLARATIONS INLINE-DECLARATIONS)(THIS-FRAME-DECLARATIONS NIL)(LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)(ENTRY-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT))    ;; Take all DECLAREs off the body.    (SETF (VALUES BODY THIS-FRAME-DECLARATIONS)  (EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR FORM) NIL))    (SETQ OUTER-VARS VARS)    (SETQ VLIST (P1SBIND (CADR FORM) 'FEF-ARG-INTERNAL-AUX T NIL THIS-FRAME-DECLARATIONS))    (SETQ INNER-VARS VARS) ; don't include free vars created by declarations    ;; Do this here so that the local declarations    ;; do not affect the init forms.    (SETQ LOCAL-DECLARATIONS  (PROCESS-PERVASIVE-DECLARATIONS THIS-FRAME-DECLARATIONS LOCAL-DECLARATIONS))    ;; Now P1 process what is left of the body.    (LET ((BINDP NIL))      (SETQ BODY (P1PROGN-1 BODY))      (VARIABLE-WRAPUP INNER-VARS OUTER-VARS)      (DYNAMIC-BINDING-HACK BINDP VLIST)      `(LET-FOR-LAMBDA ,VLIST ,OUTER-VARS ,INNER-VARS ,BINDP       ,ENTRY-LEXICAL-CLOSURE-COUNT ,LEXICAL-CLOSURE-COUNT       . ,BODY))))))(DEFUN (:PROPERTY PROGV P1) (FORM)  ;;  4/25/86 CLM - When compiling for common-lisp, a PROGV should expand   ;;into an implicit PROGN, not a BLOCK.  [SPR 2058]  ;;  5/28/86 DNG - Use MAYBE-BREAKOFF-BIND to fix SPR 2271.  ;;  8/15/86 DNG - Changed from an optimizer to a P1 handler and renamed from PROGV-EXPAND.  (LET ((VARNAMES (CADR FORM))(VALS (CADDR FORM))(BODY (CDDDR FORM))(VARS-VAR (GENSYM))(VALS-VAR (GENSYM))        BINDING-CODE)        (SETQ BINDING-CODE  `(COND     (,VARS-VAR      (INHIBIT-STYLE-WARNINGS(BIND (INHIBIT-STYLE-WARNINGS (VALUE-CELL-LOCATION (CAR ,VARS-VAR)))      (CAR ,VALS-VAR)))      (UNLESS ,VALS-VAR(MAKUNBOUND (CAR ,VARS-VAR)))      (SETQ ,VARS-VAR (CDR ,VARS-VAR))      (SETQ ,VALS-VAR (CDR ,VALS-VAR))      (GO LOOP))))    (MAYBE-BREAKOFF-BIND 'MULTIPLE-VALUE-PROGV  (IF COMPILING-COMMON-LISP      `(LET ((,VARS-VAR ,VARNAMES)     (,VALS-VAR ,VALS)) (TAGBODY  LOOP     ,BINDING-CODE) . ,BODY)    `(PROG ((,VARS-VAR ,VARNAMES)    (,VALS-VAR ,VALS))LOOP   ,BINDING-CODE   (RETURN (PROGN . ,BODY)))))))(DEFUN (:PROPERTY PROGW P1) (FORM)  ;; 12/27/84 DNG - Use SI:EVAL1 instead of EVAL to allow access to  ;;                local variables in Common Lisp evaluator.  ;;  5/28/86 DNG - Use MAYBE-BREAKOFF-BIND to fix SPR 2271.  ;;  8/15/86 DNG - Changed from an optimizer to a P1 handler and renamed from PROGW-EXPAND.  (DESTRUCTURING-BIND (IGNORE VARS-AND-VALS &BODY BODY) FORM    (LET ((VARS-AND-VALS-VAR (GENSYM)))      (MAYBE-BREAKOFF-BIND 'MULTIPLE-VALUE-PROGW`(PROG ((,VARS-AND-VALS-VAR ,VARS-AND-VALS))    LOOP       (COND (,VARS-AND-VALS-VAR  (BIND (VALUE-CELL-LOCATION (CAAR ,VARS-AND-VALS-VAR))(SI:EVAL1 (CADAR ,VARS-AND-VALS-VAR)))  (SETQ ,VARS-AND-VALS-VAR (CDR ,VARS-AND-VALS-VAR))  (GO LOOP)))       (RETURN (PROGN . ,BODY)))))))(DEFUN (:PROPERTY LET-IF P1) (FORM)  ;;  5/28/86 DNG - Use MAYBE-BREAKOFF-BIND to fix SPR 2271;  ;;make PBIND a local function.  ;;  8/15/86 DNG - Changed optimizer LET-IF-EXPAND to a P1 handler, and  ;;improved by checking the condition after optimizing it.  ;;  9/18/86 DNG - Call P1 instead of calling P1LET directly so that  ;;P1-WITH-ANNOTATION is used.  ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE.  (DESTRUCTURING-BIND (IGNORE COND VARS-AND-VALS &BODY BODY) FORM    (LET ((CONDITION (LET ((P1VALUE 'D-INDS))       (P1 COND))))      (COND((EQUAL CONDITION '(QUOTE NIL))   ; Macros generate this (DISCARD CONDITION) (P1 `(LET () ,@BODY)))((ALWAYS-TRUE CONDITION)   ; and this (DISCARD CONDITION) (P1 `(LET ,VARS-AND-VALS ,@BODY)))(T (LABELS (( PBIND (VARS-AND-VALS)     (WHEN VARS-AND-VALS       `(BIND (VARIABLE-LOCATION ,(CAAR VARS-AND-VALS))      (PROG1 ,(CADAR VARS-AND-VALS)     ,(PBIND (CDR VARS-AND-VALS))))) ))     (MAYBE-BREAKOFF-BIND 'MULTIPLE-VALUE-LET-IF       `(LET ()  (COND (,(IF (EQ P1VALUE 'UNKNOWN-NUMBER-OF-VALUES)      ;; regretably have to re-compile this to get non-local references right.      `(INHIBIT-STYLE-WARNINGS ,COND)    (MARK-P1-DONE CONDITION)) ,(PBIND VARS-AND-VALS)))  ,@BODY))))))))(DEFUN MAYBE-BREAKOFF-BIND ( NAME FORM )  ;;  5/28/86 DNG - Original version to fix SPR 2271.  ;;  6/12/86 DNG - Include binding of .DAEMON-MAPPING-TABLE. when needed.  ;;  8/15/86 DNG - Include call to P1 here.  ;;  9/26/86 DNG - Use DONT-OPTIMIZE to ensure we don't try to expand the function inline.  ;; 12/15/86 DNG - This now becomes a dummy function since the problem it was  ;;created to solve is now handled in P1LET and P2LET-INTERNAL.  #| ; old way  (IF (EQ P1VALUE 'UNKNOWN-NUMBER-OF-VALUES)      ;; When a LET contains dynamic binding (i.e. BIND) and the context      ;; requires the result to be an arbitrary number of multiple values      ;; with the number of values on the stack, then P2LET-INTERNAL can't      ;; generate an UNBIND-TO-INDEX because the special binding index is      ;; at an unknown depth on the stack.  Since this combination of      ;; circumstances should be rare, rather than add significantly more complexity      ;; to pass 2, we simplify things here by breaking off the LET as an      ;; :INTERNAL function.  This allows all of the unbinding to be done by      ;; the function return, so we don't have to worry about where the special      ;; binding index is.      (P1 `(DONT-OPTIMIZE     (FUNCALL       (FUNCTION (,(IF COMPILING-COMMON-LISP       'NAMED-LAMBDA     'GLOBAL:NAMED-LAMBDA)  ,NAME  ()  ,(IF (AND SELF-FLAVOR-DECLARATION    (LOOKUP-VAR 'SI:.DAEMON-MAPPING-TABLE. VARS))       ;; a combined flavor method -- may need this variable       ;; for METHOD-MAPPING-TABLE references.  Note that it       ;; has to be a local variable because of the way it is       ;; referenced directly by the microcode.       `(LET (( SI:.DAEMON-MAPPING-TABLE. SELF-MAPPING-TABLE ))  ,FORM)     FORM ))))))    ;; else ok as is.    (P1 FORM))) |#  (DECLARE (IGNORE NAME))  (P1 FORM))(DEFUN MARK-P1-DONE (FORM)  ;; Given a form that has already been processed by P1, put a wrapper around it  ;; so that it can be included in source to be submitted to P1.  ;; Record whatever variable usage and side-effect information is available.  ;;  9/19/86 DNG - Original.  ;;  9/24/86 DNG - Record ALLVARS.  (LET (UV (AV 0) (VS NIL))    (COND ((ATOM FORM)   (SETQ UV SPECIAL-VAR-BIT))  ((INVULNERABLE-EXPRESSION-P FORM)   (SETQ UV 0))  ((EQ (FIRST FORM) 'LOCAL-REF)   (SETQ UV (CDDR FORM)))  ((EQ (FIRST FORM) 'THE-EXPR)   (SETQ UV (LOGAND (EXPR-USED FORM) USED-VAR-SET))   (SETQ AV (LOGAND (EXPR-ALTERED FORM) ALTERED-VAR-SET))   (SETQ VS (LIST ALLVARS)))  ;; Else make a safe worst case guess.  (T (SETQ UV USED-VAR-SET)     (SETQ AV ALTERED-VAR-SET)     (SETQ VS (LIST ALLVARS))))    `(P1-HAS-BEEN-DONE ,UV ,AV ,FORM . ,VS)))(DEF P1-HAS-BEEN-DONE)(DEFUN (:PROPERTY P1-HAS-BEEN-DONE P1) (FORM)  ;; 10/02/86 DNG - Replaced warning message with loop to clear VAR-OVERLAP-VAR of new variables.  (LET ((OLD-ALLVARS (FIFTH FORM)))    (UNLESS (OR (NULL OLD-ALLVARS) ; trivial form(EQ OLD-ALLVARS ALLVARS) ; no new variables created(LISTP *OVERLAP-CANDIDATES*)) ; have recorded which are safe to overlap      (DO ((AVS ALLVARS (CDR AVS)))  ((EQ AVS OLD-ALLVARS));; Make sure that any local variables bound by a LET surrounding this form;; don't overlap variables that are local this form.  If the creater of the;; LET did not bind *OVERLAP-CANDIDATES* to prevent inapropriate overlapping,;; then use a brute-force clean-up here.(SETF (VAR-OVERLAP-VAR (CAR AVS)) NIL))))  (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (SECOND FORM)))  (SETQ ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET (THIRD FORM)))  (FOURTH FORM));; BLOCK and RETURN-FROM.;; These know how to turn into catches and throws;; when necessary for general lexical scoping.(DEFPROP BLOCK P1BLOCK P1)(DEFPROP BLOCK-FOR-WITH-STACK-LIST P1BLOCK P1);; Defines a block with two names, the specified name and NIL.(DEFUN (:PROPERTY BLOCK-FOR-PROG P1) (FORM)  (P1BLOCK FORM T))(DEFUN P1BLOCK (FORM &OPTIONAL BIND-RETPROGDESC)  ;;  7/10/86 DNG - Eliminated ENTRY-LEXICAL-CLOSURE-COUNT and PROGDESC-EXIT-LEXICAL-CLOSURE-COUNT  ;;fields from progdesc; include VARS and USED-BIT.  ;;  9/10/86 DNG - Changed handling of non-local returns to fix SPR 505.  ;; 10/11/86 DNG - Error message for block name not a symbol.  ;; 10/18/86 DNG - PROGDESC-RETTAG now a structure instead of a symbol.  (LET* ((PROGNAME (CADR FORM)) (BODY (CDDR FORM)) (RETTAG (GENSYM)) (TAG (MAKE-GOTAG RETTAG RETTAG)) (CATCH-TAG (AND (NOT INLINE-EXPANSIONS) ; breakoffs not allowed within procedure integration (SYMBOLP PROGNAME) (IF (NULL PROGNAME)     '|Exit block NIL|   (MAKE-SYMBOL (STRING-APPEND "Exit block " (STRING PROGNAME)) NIL)))) LOCAL-GOTAGS (GOTAGS GOTAGS) (TRE-OK TRE-OK) (PROGDESC (MAKE-PROGDESC     NAME PROGNAME  RETTAG TAG     IDEST P1VALUE     VARS VARS     USED-BIT (PROG1 VAR-BIT     (SETQ VAR-BIT (ASH VAR-BIT 1)))     CATCH-TAG CATCH-TAG)) (PROGDESCS (CONS PROGDESC PROGDESCS)) (RETPROGDESC   (IF (OR (AND BIND-RETPROGDESC (NEQ PROGNAME T)) (NULL PROGNAME))       PROGDESC     RETPROGDESC)))    (SETF (GOTAG-PROGDESC TAG) PROGDESC)    (UNLESS (OR (SYMBOLP PROGNAME)(AND (FIXNUMP PROGNAME) (NOT COMPILING-COMMON-LISP)))      (WARN 'PROGNAME :IMPOSSIBLE "The BLOCK name ~S is not a symbol." PROGNAME))    (WHEN (CDR BODY) (SETQ TLEVEL NIL))    ;; Push on GOTAGS a description of this prog's "return tag",    ;; a tag we generate and stick at the end of the prog.    (PUSH TAG LOCAL-GOTAGS)    (PUSH TAG GOTAGS)    (IF (NULL CATCH-TAG) ; no possibility of a non-local return`(,(CAR FORM) ,LOCAL-GOTAGS ,PROGDESC . ,(P1PROGN-1 BODY))      (P1 `(LET* ((,CATCH-TAG (UNDEFINED-VALUE)))     (%BLOCK-BODY ,(CAR FORM) ,LOCAL-GOTAGS ,PROGDESC . ,BODY))))    ))(DEFUN (:PROPERTY %BLOCK-BODY P1) (FORM)  ;;  9/10/86 - Original.  (LET* ((PROGDESC (FOURTH FORM)) (BLOCK-FORM   (LIST* (SECOND FORM) ; BLOCK or BLOCK-FOR-PROG or BLOCK-FOR-WITH-STACK-LIST   (THIRD FORM)  ; LOCAL-GOTAGS   PROGDESC  (P1PROGN-1 (NTHCDR 4 FORM)))) ; body forms (CATCH-TAG (PROGDESC-CATCH-TAG PROGDESC)))    (IF (DOLIST (C (PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC) NIL)  (UNLESS (ZEROP (COMPILAND-USE-COUNT C)) (RETURN T)));; There were non-local returns from this block from inner functions;;; need to set up a CATCH to receive them.  The catch tag must be a;; variable instead of a constant in order to prevent dynamic shadowing;; [Ref Steele 1984 p. 40].  VARIABLE-LOCATION is simply a cheap way of;; giving the variable a unique value.  Avoid calling ALTERING-VAR because;; this initialization will immediately follow the binding and we want to;; be able to mark the variable as unaltered in the lexical environment;; descriptor list.(LET ((ADDRESS (P1V CATCH-TAG)))  `(*CATCH (SETQ ,ADDRESS (VARIABLE-LOCATION ,ADDRESS))     ,BLOCK-FORM))      (PROGN;; Don't need the catch tag; reset its use count in case there were;; references that have been obsoleted by inline expansion.(SETF (VAR-USE-COUNT (LOOKUP-VAR CATCH-TAG)) 0)BLOCK-FORM ))));;;  All the various forms of RETURN are transformed to:;;;    (RETURN-FROM <progdesc> <value-expression>)(DEFPROP RETURN-FROM P1RETURN-FROM P1)(DEFUN P1RETURN-FROM (FORM)  (P1-RETURN-HANDLER (FIRST FORM) (SECOND FORM) (CDDR FORM)) )(DEFPROP RETURN P1RETURN P1)(DEFUN P1RETURN (FORM)  (P1-RETURN-HANDLER (FIRST FORM) NIL (REST FORM)) )#-Elroy ; Defined as a macro for release 3(DEFUN (:PROPERTY RETURN-LIST P1) ( FORM )  (P1-RETURN-HANDLER (FIRST FORM) NIL `((VALUES-LIST ,(SECOND FORM)))) )(DEFUN (:PROPERTY RETURN-FROM-T P1) ( FORM )  (P1-RETURN-HANDLER (FIRST FORM) T (REST FORM)) )(DEFUN P1-RETURN-HANDLER ( FUNCT BLOCK-NAME VALUE-LIST )  ;;  7/08/86 DNG - Changed handling of non-local returns.  ;;  9/09/86 DNG - Changed handling of non-local returns again to fix SPR 505.  ;;  9/24/86 DNG - Updated error message for SPR 1559.  ;; 10/18/86 DNG - Use GOTAGS-SEARCH .  (LET ( PROGDESC ARG )    (SETQ PROGDESC (COND ((AND (NULL BLOCK-NAME) RETPROGDESC)) ((ASSOC BLOCK-NAME PROGDESCS :TEST #'EQ)) ((EQ FUNCT 'RETURN)  (WARN 'BAD-PROG ':IMPOSSIBLE   "~S is not within a BLOCK named NIL or a PROG, DO, or LOOP."   (CONS FUNCT VALUE-LIST) )   NIL) (T (WARN 'BAD-PROG ':IMPOSSIBLE   "There is a RETURN-FROM ~S not inside a BLOCK or PROG of that name."BLOCK-NAME )   NIL) ) )    (SETQ ARG (COND ( (= (LENGTH VALUE-LIST) 1)     (LET (( P1VALUE (IF PROGDESC   ;; Use P1VALUE saved by P1BLOCK in order to   ;;  enable Tail Recursion Elimination. (PROGDESC-IDEST PROGDESC)       T )))(P1 (FIRST VALUE-LIST)) ) )   ;; Common Lisp: (RETURN) ==> (RETURN NIL)   ;; Zetalisp:    (RETURN) ==> (RETURN (VALUES))   ( (AND (NULL VALUE-LIST) COMPILING-COMMON-LISP)     '(QUOTE NIL) )   ( T (P1EVARGS (CONS 'VALUES VALUE-LIST)) )) )    (COND ((AND (CONSP ARG)(MEMBER (FIRST ARG) '( RETURN-FROM GO *THROW THROW) :TEST #'EQ))   ARG); (RETURN-FROM a (RETURN-FROM b x)) ==> (RETURN-FROM b x)  ((OR (NULL PROGDESC) ; undefined block       (ZEROP 1-IF-LIVE-CODE)) ; dead code   ;; skip bookkeeping   `(RETURN-FROM ,PROGDESC ,ARG))  (T (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET (PROGDESC-USED-BIT PROGDESC)))     (COND ((NEQ (PROGDESC-COMPILAND PROGDESC) *CURRENT-COMPILAND*)    (PUSHNEW *CURRENT-COMPILAND*     (PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC)     :TEST #'EQ)    `(*THROW ,(P1V (PROGDESC-CATCH-TAG PROGDESC))     ,ARG ))   (T (LET (( TAG (GOTAGS-SEARCH (PROGDESC-RETTAG PROGDESC) T GOTAGS)) );; Increment use count for return tag so that BLOCK;;  optimization will know how many RETURNs there were.(INCF (GOTAG-USE-COUNT TAG)))      `(RETURN-FROM ,PROGDESC ,ARG) ))))))(DEFPROP TAGBODY P1TAGBODY P1)(DEFUN P1TAGBODY (FORM)  ;; 12/10/85 DNG - Fix (and simplify) handling of non-local GOs.  ;;  7/09/86 DNG - New field USED-BIT for MAKE-PROGDESC.  ;;  7/24/86 DNG - Update new variable *LOOP-LEVEL*.  ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE.  ;; 10/01/86 DNG - Add binding of *OVERLAP-CANDIDATES* .  ;; 10/15/86 DNG - Delete dead code following a GO or RETURN.  (LET ( RETURN-FORM )     (LET-IF INLINE-EXPANSIONS ;; Temporarily increase the size limit in case there is ;; some part of the conditional expression that is removed ;; by optimization after being counted by P1. (( EXPRESSION-SIZE-LIMIT (+ EXPRESSION-SIZE-LIMIT 15.) ))        (LET ((LOCAL-GOTAGS) (P1VALUE NIL) (BODY (CDR FORM))(GOTAGS GOTAGS)(MYPROGDESC  (MAKE-PROGDESC NAME '(TAGBODY) NBINDS 0 VARS VARS USED-BIT (PROG1 VAR-BIT (SETQ VAR-BIT (ASH VAR-BIT 1)))))( SUBST-VAR-SET SUBST-VAR-SET )( PROPAGATE-VAR-SET PROPAGATE-VAR-SET )( NEW-LOOP-LEVEL (+ *LOOP-LEVEL* 1) )( *LOOP-LEVEL* *LOOP-LEVEL* )( SAVE-ALLVARS ALLVARS ))    (AND (CDR BODY) (SETQ TLEVEL NIL))    (DOLIST (ELT BODY)      (WHEN (ATOM ELT)(P1TAGAD ELT MYPROGDESC)))    (LET ((LIVE T))      (SETQ BODY    (LOOP FOR STMT IN BODY      WHEN (ATOM STMT)        COLLECT (PROGN (SETQ PROPAGATE-VAR-SET 0)       (SETQ SUBST-VAR-SET 0)       (SETQ *LOOP-LEVEL* NEW-LOOP-LEVEL)       (SETQ LIVE T)       STMT)      ELSE WHEN LIVECOLLECT (LET ((X (P1 STMT)))  (IF (ATOM X)      `(PROGN ,X)  ; so it doesn't look like a tag    (PROGN (WHEN (MEMBER (FIRST X) '(GO RETURN-FROM THROW))     (SETQ LIVE NIL))   X)))      ELSE DO (P1-DEAD-FORMS (LIST STMT))    )))    (SETQ RETURN-FORM `(TAGBODY ,LOCAL-GOTAGS . ,BODY))    (WHEN (PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG MYPROGDESC)      (SETQ RETURN-FORM    (LET (( *OVERLAP-CANDIDATES* SAVE-ALLVARS ))     (P1 `(BLOCK P1TAGBODY   (LET (P1TAGBODY)     (TAGBODY      P1TAGBODY (SETQ P1TAGBODY       (CATCH ',(PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG MYPROGDESC) (PROGN   (CASE P1TAGBODY     ((NIL) NIL)     . ,(LOOP FOR G IN LOCAL-GOTAGS      WHEN (GOTAG-USED-IN-LEXICAL-CLOSURES-FLAG G)      COLLECT `(,(GOTAG-PROG-TAG G)(GO-HACK ,G))))   (RETURN-FROM P1TAGBODY     ,(MARK-P1-DONE RETURN-FORM)) ))) (GO P1TAGBODY)))))) ) )      ) ; end of LET binding SUBST-VAR-SET and PROPAGATE-VAR-SET to themselves  ;; Stop propagation of initial values for any variables which were  ;;  modified within a TAGBODY or loop.  (UPDATE-PROPAGATE-VAR-SET)  RETURN-FORM ) ) )(DEFUN P1TAGAD (X &OPTIONAL PROGDESC)  ;; 10/18/86 DNG - Give warning on invalid tag type.  (COND ((ASSOC X LOCAL-GOTAGS :TEST #'EQ)  (AND X (WARN 'DUPLICATE-PROG-TAG ':IMPLAUSIBLE      "The tag ~S appears twice in one TAGBODY." X)) ;; Replace duplicate progtags with something that ;; will be ignored by pass 2, to avoid making LAP get unhappy. '(QUOTE NIL))(T (WHEN (AND (NOT (SYMBOLP X))      (NOT (INTEGERP X))      COMPILING-COMMON-LISP      (NOT INHIBIT-STYLE-WARNINGS-SWITCH))     (WARN 'P1TAGAD ':IMPLAUSIBLE   "A TAGBODY contains ~S which is not a list, symbol, or integer." X))   (PUSH X ALLGOTAGS)   (PUSH (MAKE-GOTAG X (IF (MEMBER X ALLGOTAGS :TEST #'EQUAL) (GENSYM) X)     NIL PROGDESC) LOCAL-GOTAGS)   (PUSH (FIRST LOCAL-GOTAGS) GOTAGS)   X)))(DEFPROP GO P1GO P1)(DEFUN P1GO (FORM)  ;;  8/27/85 DNG - Avoid trapping on undefined tag (pass 2 will give warning). [SPR 501]  ;;  7/08/86 DNG - Change handling of non-local GO.  ;; 10/18/86 DNG - Put the gotag structure in the form for pass 2 instead of  ;;the original tag; give error message here instead of in pass 2.  (LET ((GOTAG (ASSOC (SECOND FORM) GOTAGS :TEST #'EQUAL)))    (COND      ((NULL GOTAG)   ; undefined tag       (WARN 'BAD-GO-TAG :IMPOSSIBLE     "There is a GO to tag ~S but no such tag exists." (SECOND FORM))       `(FUNCALL #'GO ',(SECOND FORM)))   ; arrange for run-time error      ((ZEROP 1-IF-LIVE-CODE)   ; dead code; skip bookkeeping       FORM)      (T (LET* (( PROGDESC (GOTAG-PROGDESC GOTAG) )( PARENT (PROGDESC-COMPILAND PROGDESC) ))   (INCF (GOTAG-USE-COUNT GOTAG))   (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET (PROGDESC-USED-BIT PROGDESC)))   (IF (EQ PARENT *CURRENT-COMPILAND*)       `(GO ,GOTAG) ; local GO     ;; Else GO to TAGBODY in a higher-level function     (PROGN       (SETF (GOTAG-USED-IN-LEXICAL-CLOSURES-FLAG GOTAG) T)       (UNLESS (PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC) (SETF (PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC)       (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) ;; If consed in temp area, each function would copy it separately ;; and then it would not be shared by the two functions. (LIST 'TAGBODY       (SETF (COMPILAND-FUNCTION-NAME PARENT)     (SI:COPY-OBJECT-TREE (COMPILAND-FUNCTION-NAME PARENT) T))       (CADR FORM)))))       `(*THROW ',(PROGDESC-USED-IN-LEXICAL-CLOSURES-FLAG PROGDESC)',(CADR FORM))       )))))))(DEFPROP GO-HACK IDENTITY P1);; PROG is now expanded into the standard primitives.#-Elroy ; handled as a macro in release 3(DEFUN P1PROG (FORM)  (LET ((FN (CAR FORM))PROGNAME VLIST DECLS BODY)    (SETQ FORM (CDR FORM))    ;; Extract the prog name if there is one.    (COND ((AND (CAR FORM)(SYMBOLP (CAR FORM)))   (SETQ PROGNAME (CAR FORM))   (SETQ FORM (CDR FORM))))    (SETQ VLIST (CAR FORM))    (SETF (VALUES BODY DECLS)  (EXTRACT-DECLARATIONS-RECORD-MACROS (CDR FORM)))    (P1 `(BLOCK-FOR-PROG ,PROGNAME (,(IF (EQ FN 'PROG) 'LET 'LET*)  ,VLIST  ,@(IF DECLS `((DECLARE . ,DECLS)))  (TAGBODY . ,BODY))))))(DEFUN (:PROPERTY %DOLIST P1) ( FORM )  ;; FORM looks like: (%DOLIST var list body)  ;; %DOLIST forms are only generated by the DOLIST optimizer.  ;; 1/26/85 - Fix for %PUSH in loop body.  ;; 3/07/85 - Bind SUBST-VAR-SET along with PROPAGATE-VAR-SET.  ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE.  ;;  9/24/86 DNG - Bind *OVERLAP-CANDIDATES*.  (LET (( LISTVAL (LET (( P1VALUE 'VALUE-ONLY ))    (P1 (THIRD FORM)) ))( P1VALUE NIL ))    (COND ((EQUAL LISTVAL '(QUOTE NIL))   ;; (DOLIST (i NIL) body)  ==>  NIL   (PROGN (P1-DEAD-FORMS (CONS (SECOND FORM) (NTHCDR 3 FORM)))  NIL) )  ((AND (QUOTEP LISTVAL)(CONSP (SECOND LISTVAL))(NULL (REST (SECOND LISTVAL)))(EQ (CAR-SAFE (P1 (SECOND FORM) T))    'LOCAL-REF) )   ;; (DOLIST (i '(x)) body) ==> (LET ((i 'x)) body)   (P1 `(LET (( ,(SECOND FORM) (QUOTE ,(FIRST (SECOND LISTVAL))) ))  ,(FOURTH FORM) )) )  (T   (LET* (( %PUSH-DONE NIL )  ( SAVE-ALLVARS ALLVARS )  ( BODY (LET ((PROPAGATE-VAR-SET 0)       (SUBST-VAR-SET 0))   (P1 (FOURTH FORM))) ))     (UPDATE-PROPAGATE-VAR-SET)     (IF %PUSH-DONE ;; When the user is playing with the stack, we can't keep ;; the list on the stack, so create a temporary variable ;; for it. (LET (( DUMMY (GENSYM) )       ( *OVERLAP-CANDIDATES* SAVE-ALLVARS ))   (P1 `(LET ((,DUMMY ,(MARK-P1-DONE LISTVAL)))  (TAGBODY    .TOP. (WHEN (NULL ,DUMMY) (GO .END.))  (SETQ ,(SECOND FORM) (CAR ,DUMMY))  ,(MARK-P1-DONE BODY)  (SETQ ,DUMMY (CDR ,DUMMY))  (GO .TOP.)    .END. ) ) ) )       ;; Else normal case -- use PUSH-CDR-STORE-CAR-IF-CONS instruction       (LIST (FIRST FORM)   ; %DOLIST     (P1SETVAR (SECOND FORM))   ; iteration variable     LISTVAL   ; list     BODY )   ; body    ) ) ) ) ) )(DEFUN (:PROPERTY %PUSH P1) ( FORM )  ;; This has a special handler just so we can set a flag to inhibit  ;; optimization of DOLIST when the loop body contains %PUSH.  (DECLARE (NOTINLINE P1V))  (UNLESS (ZEROP 1-IF-LIVE-CODE)    (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET DATA-ALTERATION-BIT))    (SETQ %PUSH-DONE T)) ; checked by function (:PROPERTY %DOLIST P1)  (LIST (FIRST FORM)(P1V (SECOND FORM)) ) )(DEFUN UPDATE-PROPAGATE-VAR-SET ()  ;; Stop propagation of initial values for any variables which were  ;;  modified within a TAGBODY or loop.  ;; 1/24/85 - Original version.  (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET ALTERED-VAR-SET))  (LET (( STOP-SUBST-SET (LOGAND SUBST-VAR-SET ALTERED-VAR-SET) )INIT LAPAD )    (UNLESS (ZEROP STOP-SUBST-SET)      ;; The code in the TAGBODY has modified one or more variables      ;; which were used as initial values of other variables; must      ;; stop doing propagation for those values.      (DOLIST ( V VARS )(WHEN (AND (CONSP (SETQ INIT (SECOND (VAR-INIT V))))   (EQ (CAR INIT) 'LOCAL-REF)   (LOGTEST STOP-SUBST-SET (CDDR INIT))   (CONSP (SETQ LAPAD (VAR-LAP-ADDRESS V)))   (EQ (CAR LAPAD) 'LOCAL-REF))  (SETQ PROPAGATE-VAR-SET(LOGDIF PROPAGATE-VAR-SET (CDDR LAPAD)))  (WHEN (ZEROP PROPAGATE-VAR-SET) (RETURN))  ))      (SETQ SUBST-VAR-SET (LOGDIF SUBST-VAR-SET STOP-SUBST-SET)) ) )  );;   (%DISPATCH selector default-action;;   value... form...;;   value... form...;;);;;;   This provides a Lisp interface to the DISPATCH macro-instruction.;;;;   For example:;;     (%DISPATCH X (F3);;     3 5 (F1) 2 (F2) 1);;     If X is 2, then call F2.;;     If X is 3 or 5, then call F1 and F2.;;     If X is 1, do nothing.;;     Otherwise, call F3.(DEFUN (:PROPERTY %DISPATCH P1) ( FORM )  (LET* (( SELECTOR (P1V (SECOND FORM)) ) ( MAX -1 ) ( DEFAULT (P1 (THIRD FORM)) ) ( BODY (LET (( P1VALUE NIL ))  (LOOP FOR X IN (NTHCDR 3 FORM)COLLECT (IF (FIXNUMP X)   ; value tag    (PROGN (WHEN (> X MAX)     (SETQ MAX X) )   X )  ;; Else, form to be executed.  (P1 X) ) ) ) ))    (IF (< MAX 0) ; if no tags`(PROGN ,SELECTOR ,DEFAULT)      `(%DISPATCH ,SELECTOR  ,MAX   ; maximum selector value  ,DEFAULT   ; default action  . ,BODY) ) ))(DEFUN (:PROPERTY FLET P1) (FORM)  ;;  7/12/85 DNG - Construct function using NAMED-LAMBDA instead of LAMBDA;  ;;    cause name to be included in the local variable map.  ;;  2/21/86 DNG - Add support for MAKE-EPHEMERAL-LEXICAL-CLOSURE.  ;;  8/12/86 DNG - Use new function MAKE-NAMED-LAMBDA to include a BLOCK in the local function.  ;;  9/11/86 DNG - Move setting of the LOCAL-FUNCTION-NAME property to LOCAL-FUNCTION-SLOT-NAME.  (LET* ((LOCALS (MAPCAR #'LOCAL-FUNCTION-SLOT-NAME (CADR FORM))))    ;; LOCALS are local variables that really hold the functions.    ;; P1 will translate any reference to a local function    ;; into a FUNCALL to the corresponding variable.    (P1 `(LET ,(MAPCAR #'(LAMBDA (VAR DEF)   `(,VAR (FLET-FUNCTION ,(MAKE-NAMED-LAMBDA DEF))))       LOCALS (CADR FORM))   (FLET-INTERNAL ,(MAPCAR #'(LAMBDA (VAR DEF)       (LIST (CAR DEF) VAR (CONS 'NAMED-LAMBDA DEF)))   LOCALS (CADR FORM))  . ,(CDDR FORM))))))(DEFUN (:PROPERTY FLET-FUNCTION P1) (FORM)  ;;  2/21/86 - Original.  ;;  3/06/86 - Call BREAKOFF directly instead of calling P1FUNCTION.  (BREAKOFF (SECOND FORM) T) )(DEFUN (:PROPERTY FLET-INTERNAL P1) (FORM)  ;;  3/06/86 - Allow declarations at the beginning of the FLET body.  ;;  6/21/86 - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.  (LET ((LOCAL-FUNCTIONS  (NCONC (MAPCAR #'(LAMBDA (ELT)     ;; ELT looks like     ;; (local-function-name tempvar-name definition)     (LIST (CAR ELT)   (LOOKUP-VAR (CADR ELT) VARS)   (CADDR ELT))) (CADR FORM)) LOCAL-FUNCTIONS))(*LOCAL-ENVIRONMENT*  ;; Defining a local function hides any local macro definition of same symbol.  (LIST (FIRST *LOCAL-ENVIRONMENT*)(CONS (LOOP FOR ELT IN (CADR FORM)    NCONC (LIST* (LOCF (FSYMEVAL (CAR ELT))) NIL NIL))      (SECOND *LOCAL-ENVIRONMENT*)))))    (P1PROGN (CONS 'LOCALLY (CDDR FORM))) ))(DEFUN LOCAL-FUNCTION-SLOT-NAME  (DEF)  ;; Create a symbol to be used as the debugger's name for the local variable slot  ;; that holds a local function definition.  ;; INTERN is used instead of MAKE-SYMBOL so that ASSIGN-LAP-ADDRESSES will  ;; include it in the LOCAL-MAP, and will overlap duplicate names.  ;;  7/12/85 DNG - Original version; previously, a GENSYM was used.  ;;  9/11/86 DNG - Include setting of the LOCAL-FUNCTION-NAME property here.  (LET ((SYMBOL (INTERN (STRING-APPEND "#'" (SYMBOL-NAME (CAR DEF)))*PACKAGE*) ))    (SETF (GET SYMBOL 'LOCAL-FUNCTION-NAME) (CAR DEF))    SYMBOL))(DEFUN MAKE-NAMED-LAMBDA (DEF)  ;; Given the CDR of a DEFUN form: (name arglist . body)  ;; Return the list: (NAMED-LAMBDA name arglist (BLOCK name . body))  ;;  8/12/86 DNG - Original.  (LET ((NAME (FIRST DEF))(ARGLIST (SECOND DEF)))    (MULTIPLE-VALUE-BIND (BODY DECLARATIONS DOCUMENTATION)(EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR DEF) NIL T)      (SETQ BODY `((BLOCK ,NAME . ,BODY)))      (UNLESS (NULL DECLARATIONS)(PUSH `(DECLARE . ,DECLARATIONS) BODY))      (UNLESS (NULL DOCUMENTATION)(PUSH DOCUMENTATION BODY))      (LIST* (IF COMPILING-COMMON-LISP 'NAMED-LAMBDA 'GLOBAL:NAMED-LAMBDA)     NAME ARGLIST BODY))))(DEFUN (:PROPERTY LABELS P1) (FORM)  ;;  2/21/86 DNG - Add support for MAKE-EPHEMERAL-LEXICAL-CLOSURE.  ;;  8/12/86 DNG - Use new function MAKE-NAMED-LAMBDA to include a BLOCK in the local function.  ;;  9/11/86 - Modify to permit warnings on unused local functions.  ;; 10/18/86 - Permit tail recursion elimination of local functions.  (LET* ((LOCALS (MAPCAR #'LOCAL-FUNCTION-SLOT-NAME (CADR FORM))) (BINDINGS (MAPCAR #'(LAMBDA (VAR)       ;; Note: We must cons 'DUMMY because it is destructively       ;;  modified in (:PROPERTY %LABELS P1) to plug in the       ;;  real value.       (LIST VAR (LIST 'QUOTE 'DUMMY)))   LOCALS)))    ;; LOCALS are local variables that really hold the functions.    ;; P1 will translate any reference to a local function    ;; into a FUNCALL to the corresponding variable.    (P1 `(LET ,BINDINGS   (%LABELS     ,(MAPCAR #'(LAMBDA (VAR DEF BINDVAR)  (LIST (CAR DEF) VAR (MAKE-NAMED-LAMBDA DEF) BINDVAR))      LOCALS (CADR FORM) BINDINGS)     . ,(CDDR FORM))))))(DEFUN (:PROPERTY %LABELS P1) (FORM)  ;;  3/06/86 - Allow declarations at the beginning of the body.  ;;  6/21/86 - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.  ;;  8/13/86 - Use SETQ instead of PSETQ in the expansion; store the BREAKOFF-FUNCTION  ;;or LEXICAL-CLOSURE form in the VARS table entry.  ;;  9/11/86 - Modify to permit warnings on unused local functions.  ;; 10/18/86 - Permit tail recursion elimination of local functions.  ;;  2/13/87 - Update COMPILAND-INITIAL-ENVIRONMENT-VARS .  (LET ((LOCAL-FUNCTIONS  (NCONC (MAPCAR #'(LAMBDA (ELT)     (LIST (FIRST ELT) ; function name   (LOOKUP-VAR (SECOND ELT) VARS)   (THIRD ELT))) ; definition (SECOND FORM)) LOCAL-FUNCTIONS))(*LOCAL-ENVIRONMENT*  ;; Defining a local function hides any local macro definition of same symbol.  (LIST (FIRST *LOCAL-ENVIRONMENT*)(CONS (LOOP FOR ELT IN (SECOND FORM)    NCONC (LIST* (LOCF (FSYMEVAL (FIRST ELT))) NIL NIL))      (SECOND *LOCAL-ENVIRONMENT*)))))    (LET ((P1VALUE 'DOWNWARD-ONLY))      (DOLIST (ELT (SECOND FORM)) ; for each local function being defined(LET ((VALUE (P1 `(FLET-FUNCTION ,(THIRD ELT)))) ; the function object      (VAR (FIRST (FOURTH ELT))) ; the local variable which holds the function      (INIT (SECOND (FOURTH ELT)))) ; the dummy initial value to be replaced  (SETF (CAR INIT) (CAR VALUE))  (SETF (CDR INIT) (CDR VALUE))  ;; Since the dummy initial value was a constant, the variable was marked  ;; eligible for value propagation.  However, that is not appropriate if  ;; the function is a closure.  (UNLESS (EQ (CAR VALUE) 'BREAKOFF-FUNCTION)    (SETQ PROPAGATE-VAR-SET  (LOGDIF PROPAGATE-VAR-SET  (CDDR (VAR-LAP-ADDRESS (LOOKUP-VAR VAR))))))  (UNLESS (OR (= 0 LEXICAL-CLOSURE-COUNT)      (NOT (COMPILING-FOR-V2)))    ;; Once the first lexical lexical closure has been created, the environment    ;; has been constructed and we can't add any more copied-out values to it.    (DO ((VS (COMPILAND-INITIAL-ENVIRONMENT-VARS *CURRENT-COMPILAND*) (CDR VS)))((NULL VS))      (WHEN (EQ (VAR-NAME (CAR VS)) VAR)(SETF (COMPILAND-INITIAL-ENVIRONMENT-VARS *CURRENT-COMPILAND*)      (CDR VS))(RETURN))))  )))    (P1PROGN (CONS 'LOCALLY (CDDR FORM)))))(DEFUN (:PROPERTY MACROLET P1) (EXP)  ;;  3/06/86 - Allow declarations at the beginning of the body.  ;;  6/21/86 - Change to use *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.  ;; 12/24/86 - Call MAKE-EXPANDER-FUNCTION instead of EXPAND-DEFMACRO .  (LET ((*LOCAL-ENVIRONMENT*  (LIST (FIRST *LOCAL-ENVIRONMENT*)(CONS (AND (CONSP (CADR EXP))   (MAPCAN #'(LAMBDA (ELT)       (LIST (FUNCTION-CELL-LOCATION (CAR ELT))     (CONS 'MACRO (SI:MAKE-EXPANDER-FUNCTION ELT))))   (CADR EXP)))      (SECOND *LOCAL-ENVIRONMENT*))));; If we define it as a local macro, that hides any local function definition.(LOCAL-FUNCTIONS  (REMOVE-IF #'(LAMBDA (ELT) (ASSOC (CAR ELT) (CADR EXP) :TEST #'EQ))     LOCAL-FUNCTIONS)))    (P1PROGN (CONS 'LOCALLY (CDDR EXP))) ))#-Elroy(DEFCOMPILER-SYNONYM THROW *THROW)(DEFPROP NTH-VALUE P1THROW P1)(DEFPROP *THROW P1THROW P1)(DEFPROP THROW  P1THROW P1)(DEFUN P1THROW (FORM)  ;;  5/28/86 DNG - Bind P1VALUE to UNKNOWN-NUMBER-OF-VALUES.  ;;  9/16/86 DNG - Record side-effect.  (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET DATA-ALTERATION-BIT))  (LIST (FIRST FORM)(P1V (SECOND FORM)) ; tag(LET (( P1VALUE 'UNKNOWN-NUMBER-OF-VALUES ))  (P1 (THIRD FORM))))) ; value(s) form(DEFPROP *CATCHP1CATCH P1)(DEFPROP CLI:CATCHP1CATCH P1)(DEFUN P1CATCH (FORM)  ;;  5/10/86 DNG - Original; replaces pre-optimizer *CATCH-PROGNIFY.  (LIST '*CATCH(P1V (SECOND FORM))(P1 (CONS 'PROGN (CDDR FORM)))))(DEFPROP COND P1COND P1)(DEFUN P1COND (X &AUX (PROPAGATE PROPAGATE-VAR-SET))  ;; 12/28/84 - Adjust EXPRESSION-SIZE-LIMIT.  ;; 10/20/86 - Don't call P1PROGN-1 on NIL since 'NIL is not an appropriate default here. (PROG1   (CONS    'COND    (COND      ((NULL (CDR X)) (RETURN-FROM P1COND '(QUOTE NIL)))      ((ATOM (CDR X))       (WARN 'BAD-COND ':IMPOSSIBLE     "The atom ~S appears as the body of a COND." X))      (T (LET-IF INLINE-EXPANSIONS ;; Temporarily increase the size limit in case there is ;; some part of the conditional expression that is removed ;; by optimization after being counted by P1. (( EXPRESSION-SIZE-LIMIT (+ EXPRESSION-SIZE-LIMIT 7) )) (LOOP WITH DEAD-CODE = NIL       FOR FORMS IN (CDR X)       IF (ATOM FORMS) DO       (WARN 'BAD-COND ':IMPOSSIBLE     "The atom ~S appears as a COND-clause." FORMS)       ELSE IF DEAD-CODE DO (P1-DEAD-FORMS FORMS)       ELSE        COLLECT (LET* (( REST (REST FORMS) )( TEST (LET (( P1VALUE (IF (OR (NOT (NULL REST))       (NULL P1VALUE))   'D-INDS ; eval for nil test only T ; need actual result value      ))) (P1 (FIRST FORMS)) ) ) )   (WHEN (QUOTEP TEST)     ;; If the antecedent optimizes to a constant, then either the     ;;  rest of the clause of the rest of the COND is dead code.     ;;  This would be cleaned up by post-optimizer COND-OPT later,     ;;  but pruning the expression before it is processed by P1     ;;  facilitates Procedure Integration and Value Propagation     ;;  optimizations by not counting the dead code in EXPRESSION-SIZE       ;;  and variable use-counts.     (IF (NULL (SECOND TEST)) (PROGN (P1-DEAD-FORMS REST)(SETQ REST NIL))       (SETQ DEAD-CODE T) ) )   (CONS TEST (AND REST      (LET (( PROPAGATE-VAR-SET PROPAGATE-VAR-SET )    ( SUBST-VAR-SET SUBST-VAR-SET ) )(PROG1 (P1PROGN-1 REST)       (SETQ PROPAGATE (LOGAND PROPAGATE PROPAGATE-VAR-SET))      ))))   )    ) ) ) ) )  (SETQ PROPAGATE-VAR-SET PROPAGATE) ) )(DEFUN (:PROPERTY IF P1) (FORM)  (P1COND `(COND (,(SECOND FORM) ,(THIRD FORM)) ('T 'NIL . ,(NTHCDR 3 FORM)) )) )(DEFPROP PROGN   P1PROGN P1)(DEFPROP LOCALLY P1PROGN P1)(DEFUN P1PROGN (FORM)  ;;  6/18/86 DNG - update handling of LOCAL-DECLARATIONS.  ;; 10/21/86 DNG - Modified message for declarations in PROGN.  (SETQ TLEVEL NIL)  (MULTIPLE-VALUE-BIND (BODY THIS-FRAME-DECLARATIONS)      (EXTRACT-DECLARATIONS-RECORD-MACROS (CDR FORM))    (LET ((VARS VARS) (OLDVARS VARS)   (INLINE-DECLARATIONS INLINE-DECLARATIONS)  (OPTIMIZE-SWITCH OPTIMIZE-SWITCH)  (LOCAL-DECLARATIONS LOCAL-DECLARATIONS))      (UNLESS (NULL THIS-FRAME-DECLARATIONS)#+Elroy ; can't do this until LOCALLY is no longer a macro(WHEN (AND COMPILING-COMMON-LISP   (EQ (FIRST FORM) 'PROGN)   (NOT INHIBIT-STYLE-WARNINGS-SWITCH))  (WARN 'P1PROGN :IMPLAUSIBLE"(DECLARE ~S) in a PROGN; use LOCALLY instead."(FIRST THIS-FRAME-DECLARATIONS)) )(SETQ LOCAL-DECLARATIONS      (PROCESS-PERVASIVE-DECLARATIONS THIS-FRAME-DECLARATIONS LOCAL-DECLARATIONS)) )      (SETQ BODY (P1PROGN-1 BODY))      (IF (EQ VARS OLDVARS)  (CONS 'PROGN BODY)(LIST* 'PROGN-WITH-DECLARATIONS VARS BODY))))  )(DEFUN P1PROGN-1 ( FORMS )  ;; Apply P1 to a list of forms where only the last form is  ;;  evaluated for its result value.  ;; 08/27/84 DNG - Redesigned to discard dead code following an  ;;       unconditonal transfer of control.  ;; 12/28/84 DNG - Discard constant and variable arguments whose  ;;       value is not going to be used.  ;; 10/20/86 DNG - Return ('NIL) instead of an empty list so that EXPR-TYPE-P  ;;can meaningfully look at the last argument of a LET.  (OR (LET* ( ( DEST P1VALUE ) ( P1VALUE NIL )     ( FORMS-LEFT FORMS ) BEFORE AFTER )(LOOP UNTIL (NULL FORMS-LEFT)      DO (PROGN (SETQ BEFORE (CAR FORMS-LEFT))(SETQ FORMS-LEFT (CDR FORMS-LEFT))(WHEN (NULL FORMS-LEFT)  (SETQ P1VALUE DEST) )(SETQ AFTER (P1 BEFORE)) )      WHEN (OR P1VALUE (NOT (NO-SIDE-EFFECTS-P AFTER)))      COLLECTING AFTER      ELSE DO (DISCARD AFTER)      UNTIL (AND (CONSP AFTER) (MEMBER (FIRST AFTER) '(RETURN-FROM GO *THROW THROW) :TEST #'EQ)  (PROG1 T (P1-DEAD-FORMS FORMS-LEFT) ) )))      '((QUOTE NIL))))(DEFPROP IGNORE P1IGNORE P1)(DEFUN P1IGNORE (FORM &AUX P1VALUE)  (CONS 'PROGN (MAPCAR #'P1 (APPEND (CDR FORM) '(NIL)))))(DEFPROP THE P1THE P1)(DEFUN P1THE (FORM)  ;;  3/10/86 - Original.  ;;  8/28/86 - Use new function CANONICALIZE-TYPE-FOR-COMPILER .  ;; 10/07/86 - Permit VALUES type.  ;;  2/16/87 - Don't save canonicalized type of T.  (LET (( TYPE (CANONICALIZE-TYPE-FOR-COMPILER (SECOND FORM) FORM T) ))    (IF (OR (EQ TYPE 'UNKNOWN) (EQ TYPE 'T)) ; no useful information(P1 (THIRD FORM))      (P1-WITH-ANNOTATION (THIRD FORM) #'P1 TYPE)      )))#-Elroy(PROGN(ADD-OPTIMIZER THE THE-OPT) ; temporary to get around THE macro(DEFUN THE-OPT (FORM) ; 4/25/86  (CONS '%THE (REST FORM)))(DEFPROP %THE P1THE P1)(Defun %THE (&QUOTE type thing) ; in case it needs to be evaluated. -- 8/15/86  (declare (ignore type))  (si:eval1 thing)))(DEFPROP OR P1ANDOR P1)(DEFPROP AND P1ANDOR P1)(DEFUN P1ANDOR ( FORM )  ;; 10/14/86 - Bind EXPRESSION-SIZE-LIMIT. (LET-IF INLINE-EXPANSIONS ;; Temporarily increase the size limit in case there is ;; some part of the conditional expression that is removed ;; by optimization after being counted by P1. (( EXPRESSION-SIZE-LIMIT (+ EXPRESSION-SIZE-LIMIT 2) ))  (CONS (FIRST FORM)   (LET* ( A ( DEST P1VALUE ) ( P1VALUE T) )    (WHEN (OR (NULL DEST)      (EQ DEST 'D-INDS))      (SETQ P1VALUE 'D-INDS) ) ; argument values used for nil test only    (LOOP FOR ARGS ON (REST FORM)  COLLECTING (SETQ A (IF (REST ARGS); if not last argument (P1 (FIRST ARGS))       (LET (( P1VALUE DEST )) (P1 (FIRST ARGS)) ) ))  UNTIL (AND (NOT (ATOM A))     (EQ (FIRST A) 'QUOTE)     (IF (EQ (FIRST FORM) 'AND) (NULL (SECOND A))       (NOT (NULL (SECOND A))) )     ;; Stop processing the arguments after a constant argument     ;;  which will stop evaluation at execution time.  This is done     ;;  to facilitate Procedure Integration and Value Propagation     ;;  optimizations by not including dead code in EXPRESSION-SIZE     ;;  and variable use-counts.     (PROG1 T (P1-DEAD-FORMS (REST ARGS))) )     ) ) ) ))(DEFPROP MULTIPLE-VALUE P1-MULTIPLE-VALUE P1)(DEFPROP MULTIPLE-VALUE-SETQ P1-MULTIPLE-VALUE P1)(DEFUN P1-MULTIPLE-VALUE (FORM)    (AND (CDDDR FORM) (WARN 'WRONG-NUMBER-OF-ARGUMENTS ':IMPOSSIBLE       "MULTIPLE-VALUE is used with too many arguments."))    (IF (NULL (CDR (CADR FORM)))(IF (NULL (CAR (CADR FORM)))    (P1V (CADDR FORM))  (P1V `(SETQ ,(CAR (CADR FORM)) ,(CADDR FORM))))      (LIST 'MULTIPLE-VALUE    (MAPCAR #'P1SETVAR (CADR FORM))    (P1V (CADDR FORM)))))(DEFPROP MULTIPLE-VALUE-LIST P1MULTIPLE-VALUE-LIST P1)(DEFPROP %PUSH-VALUES-AND-COUNT P1MULTIPLE-VALUE-LIST P1)(DEFUN P1MULTIPLE-VALUE-LIST (FORM)  ;;  5/28/86 DNG - Bind P1VALUE to UNKNOWN-NUMBER-OF-VALUES.  ;; 10/17/86 DNG - Set %PUSH-DONE flag.  (WHEN (EQ (FIRST FORM) '%PUSH-VALUES-AND-COUNT)    (SETQ %PUSH-DONE T)) ; checked by function (:PROPERTY %DOLIST P1)  (LIST (FIRST FORM)(LET (( P1VALUE 'UNKNOWN-NUMBER-OF-VALUES ))  (P1 (SECOND FORM)))))(DEFUN (:PROPERTY MULTIPLE-VALUE-PUSH P1) (FORM)  ;;  9/16/86 - Record side-effect in ALTERED-VAR-SET.  ;; 10/17/86 - Set %PUSH-DONE flag.  (WHEN (CDDDR FORM)    (WARN 'WRONG-NUMBER-OF-ARGUMENTS ':IMPOSSIBLE  "MULTIPLE-VALUE-PUSH is used with too many arguments."))  (COND ((ZEROP (CADR FORM)) (P1 (CADDR FORM)))((AND (FIXNUMP (CADR FORM)) (< -1 (CADR FORM) 64.)) (SETQ %PUSH-DONE T) (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET DATA-ALTERATION-BIT)) `(MULTIPLE-VALUE-PUSH ,(CADR FORM) ,(P1V (CADDR FORM))))(T (WARN 'TOO-MANY-VALUES ':IMPOSSIBLE       "The first argument of MULTIPLE-VALUE-PUSH must be a fixnum between 0 and 63.") (P1V (CADDR FORM)))))(DEFPROP PROG1 P1PROG1 P1)(DEFPROP MULTIPLE-VALUE-PROG1 P1PROG1 P1)(DEFPROP UNWIND-PROTECT P1PROG1 P1)(DEFUN P1PROG1 (FORM)  ;;  5/28/86 DNG - Bind P1VALUE to UNKNOWN-NUMBER-OF-VALUES when appropriate.  ;;  9/22/86 DNG - For first arg of PROG1 bind P1VALUE to SINGLE-VALUE.  (LIST* (FIRST FORM) (LET (( P1VALUE (IF (OR (EQ P1VALUE 'UNKNOWN-NUMBER-OF-VALUES) (CONSP P1VALUE)) ; return value from function     (IF (EQ (FIRST FORM) 'PROG1) 'SINGLE-VALUE       'UNKNOWN-NUMBER-OF-VALUES)   P1VALUE) ))   (P1 (SECOND FORM))) (LET (( P1VALUE NIL ))   (LOOP FOR ELT IN (CDDR FORM) COLLECT (P1 ELT))) ))(DEFPROP MULT-VALUE-CALL P1MULTIPLE-VALUE-CALL P1) ; temporary name to avoid macro expansion(DEFPROP MULTIPLE-VALUE-CALL P1MULTIPLE-VALUE-CALL P1)(DEFUN P1MULTIPLE-VALUE-CALL (FORM)  ;;  9/05/86 CLM - Original.  ;;  9/30/86 DNG - Use FIX-FUNCALL-EVALUATION-ORDER.  ;; 10/13/86 DNG - Extended to handle arbitrary number of argument forms.  (LET* ((SAVE-ALLVARS ALLVARS) (ARGLIST (CDDR FORM)) (FUNCTION (LET ((P1VALUE 'DOWNWARD-ONLY))     (P1 (SECOND FORM)))))    (DECLARE (UNSPECIAL ARGLIST)(LIST ARGLIST))    ;; note: 0-args case was taken care of in pre-optimizer    (IF (NULL (REST ARGLIST)) ; single-argument case can be handled directly by pass 2(PROG1 (FIX-FUNCALL-EVALUATION-ORDER (LIST 'MULTIPLE-VALUE-CALL       FUNCTION       (LET (( P1VALUE 'UNKNOWN-NUMBER-OF-VALUES )) (P1 (THIRD FORM)))       ) SAVE-ALLVARS)       (ARBITRARY-SIDE-EFFECTS))      ;; Else two or more arguments      (LET ((NVALUES (GENSYM))    (FNVAR (GENSYM))    (BODY NIL)    (*OVERLAP-CANDIDATES* SAVE-ALLVARS))(DO ((ARGS ARGLIST (REST ARGS)))    ((NULL ARGS))  (PUSH `(%PUSH-VALUES-AND-COUNT ,(FIRST ARGS)) BODY)  (UNLESS (NULL (REST ARGS))   ; unless last time    (PUSH (IF (EQ ARGS ARGLIST)   ; first time      `(SETQ ,NVALUES (%POP))    `(SETQ ,NVALUES (+ (%POP) ,NVALUES)))  BODY)))(P1 `(LET ((,NVALUES (UNDEFINED-VALUE))   (,FNVAR ,(MARK-P1-DONE FUNCTION)))       ,@(NREVERSE BODY)       (%CALL ,FNVAR (+ (%POP) ,NVALUES)))))      )))(DEFPROP SETQ  P1SETQ P1)(DEFPROP INTERNAL-PSETQ P1SETQ P1)(DEFUN P1SETQ (FORM)  (CONS (CAR FORM) (P1SETQ-1 (CDR FORM))))(DEFUN P1SETQ-1 (PAIRS)  ;;  7/18/85 - Don't check for DEFCONSTANT until after calling P1SETVAR  ;;to allow shadowing by a local variable of the same name.    (COND ((NULL PAIRS) NIL)  ((NULL (CDR PAIRS))   (WARN 'BAD-SETQ ':IMPOSSIBLE "SETQ appears with an odd number of arguments; the last one is ~S." (CAR (LAST PAIRS)))   NIL)  ((NULL (CAR PAIRS))   ;; Check for this here because P1SETVAR allows NIL but reports   ;; an error on other constants.   (WARN 'NIL-OR-T-SET ':IMPOSSIBLE "~S being SETQ'd; this will be ignored." (CAR PAIRS))   (P1V (CADR PAIRS));Just to get warnings on it.   (P1SETQ-1 (CDDR PAIRS)))  (T (LET* (( VALEXP (P1V (CADR PAIRS)) )    ( VAR (P1SETVAR (CAR PAIRS)) ))       ;; process source before destination to allow propagation of       ;;  old value of destination variable.       (IF (NULL VAR) ; Error was reported by P1SETVAR   (P1SETQ-1 (CDDR PAIRS)) (CONS VAR       (CONS VALEXP (P1SETQ-1 (CDDR PAIRS)))))))))(DEFUN P1SETVAR (VAR)  ;;  7/18/85 - Call P1 with DONT-OPTIMIZE argument of T to prevent  ;;substitution of DEFCONSTANT values; check for attempt to  ;;assign a constant after calling P1.  (COND ((NULL VAR) NIL);FOR MULTIPLE-VALUE((NOT (SYMBOLP VAR)) (WARN 'BAD-SETQ ':IMPOSSIBLE       "~S cannot be SETQ'd." VAR) NIL)(T (LET ( FORM )     (LET (( PROPAGATE-VAR-SET 0 ) ; prevent substitution   ( USED-VAR-SET USED-VAR-SET ) ; don't count as a use   ( P1VALUE T ) ; so the use count will be incremented   )       (SETQ FORM (P1 VAR T)) )     (COND ((QUOTEP FORM)    (WARN 'SYSTEM-CONSTANT-SET ':IMPOSSIBLE "Attempt to SETQ the constant ~S; this will be ignored." (SECOND FORM))    NIL )   ((AND (SYMBOLP FORM) ; special variable (OR (GET-FOR-TARGET FORM 'SYSTEM-CONSTANT)     (ASSOC FORM FILE-CONSTANTS-LIST :TEST #'EQ))) ; DEFCONSTANT    (WARN 'SYSTEM-CONSTANT-SET ':IMPOSSIBLE "Defined constant ~S being SETQ'd; this will be ignored." FORM)    NIL )   ( T (ALTERING-VAR FORM) ) ) ) ) ) )(DEFUN ALTERING-VAR ( FORM )  ;; FORM is a variable reference (as returned by P1) which is  ;;  going to be used as the destination of an assignment.  ;; Perform bookkeeping updates for value propagation.  ;; The value returned is simply the argument.  ;;  7/08/86 - Set SPECIAL-VAR-BIT.  (COND ((AND (CONSP FORM) (EQ (CAR FORM) 'LOCAL-REF)) (LET (( BIT (CDDR FORM) ) LAPAD )   (SETQ ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET BIT))   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET BIT))   (WHEN (LOGTEST BIT SUBST-VAR-SET)     (DOLIST ( V VARS )       (WHEN (AND (EQ FORM (SECOND (VAR-INIT V)))  (CONSP (SETQ LAPAD (VAR-LAP-ADDRESS V)))  (EQ (CAR LAPAD) 'LOCAL-REF)) (SETQ PROPAGATE-VAR-SET       (LOGDIF PROPAGATE-VAR-SET (CDDR LAPAD))) (WHEN (ZEROP PROPAGATE-VAR-SET) (RETURN)) ))     (SETQ SUBST-VAR-SET (LOGDIF SUBST-VAR-SET BIT)) )))((NOT (LOGTEST SPECIAL-VAR-BIT ALTERED-VAR-SET)) (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET SPECIAL-VAR-BIT))))  FORM )(DEFPROP SI:STORE-KEYWORD-ARG-VALUES P1-STORE-KEYARGS P1)(DEFPROP SI:STORE-KEYARGSP1-STORE-KEYARGS P1)(DEFPROP SI:%STORE-KEYARGSP1-STORE-KEYARGS P1)(DEFUN P1-STORE-KEYARGS ( FORM )  ;;  1/08/86 - Original.  Needed now because in release 3 the local vars for  ;;keyword args are FEF-ARG-INTERNAL-AUX instead of FEF-ARG-AUX.  ;;  1/24/86 - Call ALTERING-VAR for each keyword variable instead of just  ;;clearing PROPAGATE-VAR-SET in order to prevent unused variables  ;;from being deleted.  ;;  5/22/86 - Modified for new VM2 function STORE-KEYARGS.  ;;  9/03/86 - Remove IGNORE flag from keyword args.  ;; 10/01/86 - Change kind to FEF-ARG-KEY instead of calling ALTERING-VAR and removing the IGNORE flag.  ;; 10/09/86 - Restore call to ALTERING-VAR.  (LET* (( NEW-FORM (P1EVARGS FORM) ) ( FIRST-KEY (SECOND (IF (EQ (FIRST FORM) 'SI:STORE-KEYWORD-ARG-VALUES) (SIXTH NEW-FORM)       (FIFTH NEW-FORM))) ))    ;; STORE-KEYWORD-ARG-VALUES changes all the keyword arg local vars.    ;; Need to prevent propagation of the default values and make sure none of    ;; them get deleted even if they are never referenced.    (DOLIST ( V VARS )      (WHEN (EQ (VAR-KIND V) 'FEF-ARG-INTERNAL-AUX)(SETF (VAR-KIND V) 'FEF-ARG-KEY)) ; to prevent optimization      (LET ((LAPAD (VAR-LAP-ADDRESS V)))(ALTERING-VAR LAPAD)(WHEN (EQ LAPAD FIRST-KEY)  (SETF (VAR-USE-COUNT V) NIL)  (RETURN) )))    (IF (AND (COMPILING-FOR-V2)     (EQ (FIRST FORM) 'SI:STORE-KEYWORD-ARG-VALUES))(CONS 'SI:STORE-KEYARGS(CDDR NEW-FORM))      NEW-FORM )))#-Elroy(COMPILATION-DEFINE 'SI:STORE-KEYARGS);DONT-OPTIMIZE is like PROGN, except that the arguments are not optimized.;Actually, only the top level of the arguments are not optimized;;their subexpressions are handled normally.;; 11/01/84 DNG - Changed to use DONT-OPTIMIZE instead of PROGN in the;;     result form to prevent post-optimization.;;  6/02/86 DNG - Correct to use &AUX instead of &REST.(DEFUN (:PROPERTY DONT-OPTIMIZE P1) (FORM &AUX (FORMS (CDR FORM)))  (DO ((FORMS-LEFT (SETQ FORMS (COPY-LIST FORMS)) (CDR FORMS-LEFT)))      ((NULL FORMS-LEFT) (CONS 'DONT-OPTIMIZE FORMS))    (LET ((P1VALUE P1VALUE))      (AND (CDR FORMS-LEFT) (SETQ P1VALUE NIL))      (RPLACA FORMS-LEFT (P1 (CAR FORMS-LEFT) T)))));Execute body with SELF's mapping table set up.(DEFUN (:PROPERTY WITH-SELF-ACCESSIBLE P1) (FORM) (LET (( SELF-FLAVOR-DECLARATION (CDR (SI:FLAVOR-DECLARATION (CADR FORM))) ))  (P1 `(LET ((SELF-MAPPING-TABLE (%GET-SELF-MAPPING-TABLE ',(CADR FORM)))) . ,(CDDR FORM))))  );Execute body with all instance variables of SELF bound as specials.(DEFUN (:PROPERTY WITH-SELF-VARIABLES-BOUND P1) (FORM)  (P1 `(LET () (%USING-BINDING-INSTANCES (SI:SELF-BINDING-INSTANCES)) . ,(CDR FORM))));The flavor system sometimes generates SELF-REFs by hand.;Just let them through on pass 1.  Pass 2 will compile like refs to instance vars.(DEFUN (:PROPERTY SELF-REF P1) (FORM)  (UNLESS (EQ (SECOND FORM) (FIRST SELF-FLAVOR-DECLARATION))    (WARN 'SELF-REF ':IMPOSSIBLE      "SELF-REF for flavor ~S in method for flavor ~S."      (SECOND FORM) (FIRST SELF-FLAVOR-DECLARATION) ) )  (SETQ SELF-REFERENCES-PRESENT T)  (WHEN (AND (EQ (THIRD FORM) 'T) (NTHCDR 3 FORM))    ;; This is used in a combined method to fetch the mapping table    ;;  of a component flavor from the array leader of the current    ;;  mapping table which the microcode takes from LOCAL|1 which    ;;  should correspond to the variable name .DAEMON-MAPPING-TABLE. .    ;;  Call P1 to increment its use count to make sure it doesn't    ;;  get optimized away.    (P1V 'SI:.DAEMON-MAPPING-TABLE.) )  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT))  FORM )(DEFPROP FUNCALL-WITH-MAPPING-TABLE     P1-FUNCALL-WITH-MAP P1)(DEFPROP FUNCALL-WITH-MAPPING-TABLE-INTERNAL P1-FUNCALL-WITH-MAP P1)(DEFUN P1-FUNCALL-WITH-MAP (FORM)  ;; 10/22/85 DNG - Omit binding of SELF-MAPPING-TABLE to itself when  ;;    the mapping table being passed is the same.  ;;  2/21/86 DNG - Set P1VALUE flag for ephemeral lexical closures.  ;;  9/16/86 DNG - Call ARBITRARY-SIDE-EFFECTS.  ;;  9/18/86 DNG - Use FIX-FUNCALL-EVALUATION-ORDER.  ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE.  ;;  9/24/86 DNG - Pass previous ALLVARS to FIX-FUNCALL-EVALUATION-ORDER.  ;;  9/26/86 DNG - Add binding of *OVERLAP-CANDIDATES* to avoid warning from P1-HAS-BEEN-DONE handler.  (LET (( FUNCT (LET (( P1VALUE 'DOWNWARD-ONLY ))  (P1 (SECOND FORM)) ))( SAVE-ALLVARS ALLVARS )( MAP (THIRD FORM) )( ARGS (MAPCAR #'P1V (NTHCDR 3 FORM)) ) EXPANSION )    (IF (AND (CONSP FUNCT)     (EQ (FIRST FUNCT) 'FUNCTION)     (SETQ EXPANSION (MAYBE-INTEGRATE (SECOND FUNCT) ARGS MAP)) );; use inline expansion(IF (OR (AND (CONSP MAP)     (EQ (FIRST MAP) 'SI:METHOD-MAPPING-TABLE)     (NOT (NULL SELF-FLAVOR-DECLARATION)) )(EQ MAP 'SELF-MAPPING-TABLE) )    EXPANSION; continue using current mapping table  ;; else switch mapping tables  (IF (EQ (FIRST FORM) 'FUNCALL-WITH-MAPPING-TABLE-INTERNAL)      (P1 `(PROGN (SETQ SELF-MAPPING-TABLE ,MAP)  ,(MARK-P1-DONE EXPANSION ) ) )    (P1 `(LET ((SELF-MAPPING-TABLE ,MAP))   ,(MARK-P1-DONE EXPANSION ) ) ) ) )      ;; here to generate a call      (LET* (( NEW-REST (LIST* FUNCT (P1V MAP) ARGS) )     ( NEW-FORM (FIX-FUNCALL-EVALUATION-ORDER  (CONS 'FUNCALL-WITH-MAPPING-TABLE-INTERNAL NEW-REST)  SAVE-ALLVARS) ))(PROG1 (IF (OR (EQ (FIRST FORM) 'FUNCALL-WITH-MAPPING-TABLE-INTERNAL)       (EQ (SECOND NEW-REST) 'SELF-MAPPING-TABLE) )   NEW-FORM (LET ((*OVERLAP-CANDIDATES* SAVE-ALLVARS))   (P1 `(LET ((SELF-MAPPING-TABLE SELF-MAPPING-TABLE))  ,(MARK-P1-DONE NEW-FORM) ))))       (ARBITRARY-SIDE-EFFECTS))))))(DEFPROP LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL P1APPLY P1)(DEFUN (:PROPERTY LEXPR-FUNCALL-WITH-MAPPING-TABLE P1) (FORM)  ;;  6/06/86 DNG - Restored this function which was in version 98 but was lost in Explorer release 1.  (P1 `(LET ((SELF-MAPPING-TABLE SELF-MAPPING-TABLE))         (LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL . ,(CDR FORM)))))(DEFUN INCLUDED-FLAVOR-P ( CALLED-FLAVOR-NAME SELF-FLAVOR-NAME )  ;; Returns true if the the first argument is a flavor which is either the same  ;;  as the second argument or is included in it.  (OR (EQ SELF-FLAVOR-NAME  CALLED-FLAVOR-NAME)      (AND (NOT (NULL SELF-FLAVOR-NAME))   (LET (( SELF-FLAVOR  (SI:COMPILATION-FLAVOR SELF-FLAVOR-NAME (AND QC-FILE-IN-PROGRESS      (NOT QC-FILE-LOAD-FLAG)))))     (AND (NOT (NULL SELF-FLAVOR))  (MEMBER CALLED-FLAVOR-NAME  (OR (SI:FLAVOR-DEPENDS-ON-ALL SELF-FLAVOR)      (SI:FLAVOR-DEPENDS-ON SELF-FLAVOR))  :TEST #'EQ) ) ) ) )  )(DEFUN (:PROPERTY QUOTE-EVAL-AT-LOAD-TIME P1) (FORM)  ;;  8/09/86 - Test QC-FILE-LOAD-FLAG instead of QC-TF-OUTPUT-MODE.  (P1 (IF (NOT (AND QC-FILE-IN-PROGRESS    (NOT QC-FILE-LOAD-FLAG)))  `(QUOTE ,(SI:EVAL1 (CADR FORM)))`(QUOTE (,EVAL-AT-LOAD-TIME-MARKER . ,(CADR FORM))))))(DEFPROP FUNCTION P1FUNCTION P1)(DEFUN P1FUNCTION (FORM)  ;; 1/23/85 - Add call to CHECK-COLD.  ;; 2/21/86 DNG - Merge in function MAYBE-BREAKOFF; add support for  ;;MAKE-EPHEMERAL-LEXICAL-CLOSURE; quoted symbol as &FUNCTIONAL  ;;argument cannot refer to a local function.  ;; 3/10/86 DNG - Fix for local function that is not a closure.  ;; 7/03/86 DNG - Use new function REF-LOCAL-FUNCTION-VAR instead of TRY-REF-LEXICAL-HOME.  ;;11/24/86 DNG - Allow non-top-level DEFMACRO or DEFSUBST to be compiled.  (LET (( FN (SECOND FORM) ))    (COND ((SYMBOLP FN)   (LET ((TM (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)))     (IF (AND TM  ;Ref to a local function made by FLET or LABELS:      (NEQ (FIRST FORM) 'QUOTE)) ; not called from P1ARGC for &FUNCTIONAL arg (PROGN   (UNLESS (OR (MEMBER P1VALUE '(DOWNWARD-ONLY NIL D-INDS) :TEST #'EQ)       (ZEROP 1-IF-LIVE-CODE))     (LET (( INIT (SECOND (VAR-INIT (SECOND TM))) ))       (WHEN (EQ (FIRST INIT) 'LEXICAL-CLOSURE) (SETF (THIRD INIT) NIL))))   ; cannot use ephemeral closure   (REF-LOCAL-FUNCTION-VAR (SECOND TM))) ;Really ref the local var that holds it.       (PROGN (CHECK-COLD FN)      FORM))))   ;Global function definition.  ((FUNCTIONP FN T)   ;Functional constant   (LET (( FUNCTION (LAMBDA-MACRO-EXPAND FN) ))     (IF (CONSP FUNCTION) (BREAKOFF FUNCTION (EQ P1VALUE 'DOWNWARD-ONLY))       (LIST 'QUOTE FN))))  ((VALIDATE-FUNCTION-SPEC FN)   ;Function spec   FORM)  (T (WARN 'BAD-ARGUMENT ':IMPOSSIBLE   "The argument of FUNCTION is ~S, neither a function nor the name of one."   FN)     ;; Arrange to get error when executed also.     (IF (EQ (FIRST FORM) 'QUOTE) FORM       (P1 `(FDEFINITION (QUOTE ,FN))))))))(DEFPROP APPLY P1APPLY P1)(DEFPROP LEXPR-FUNCALL P1APPLY P1)(DEFUN P1APPLY ( FORM )  ;;  2/21/86 DNG - Original.  ;;  9/16/86 DNG - Update var sets.  ;;  9/16/86 DNG - Use FIX-FUNCALL-EVALUATION-ORDER.  ;;  9/24/86 DNG - Pass saved ALLVARS to FIX-FUNCALL-EVALUATION-ORDER to  ;;prevent improper variable overlap.  (PROG1 (LET ((SAVE-ALLVARS ALLVARS))   (FIX-FUNCALL-EVALUATION-ORDER     (LIST* (FIRST FORM)    (LET (( P1VALUE 'DOWNWARD-ONLY ))   ; permit ephemeral closure      (P1 (SECOND FORM)) )    (LET (( P1VALUE 'T ))      (MAPCAR #'P1 (CDDR FORM))))     SAVE-ALLVARS)) (ARBITRARY-SIDE-EFFECTS)))(DEFUN FIX-FUNCALL-EVALUATION-ORDER (FORM OLD-ALLVARS)  ;; Given a FUNCALL or APPLY form, make sure things get done in the right order  ;; if there are any interactions between the function and argument forms.  ;; This is because in VM2 the function is pushed on the stack after the  ;; arguments, which violates the usual left-to-right order.  ;;  9/18/86 DNG - Original.  ;;  9/19/86 DNG - Use MARK-P1-DONE instead of P1-ALREADY-DONE.  ;;  9/23/86 DNG - Avoid generating CALL-N PDL-POP.  ;;  9/24/86 DNG - Bind *OVERLAP-CANDIDATES* to prevent the temporary variable  ;;that holds the function to be called from overlapping a variable  ;;used in one of the argument calculations.  ;; 10/11/86 DNG - Assume that *STANDARD-INPUT* and *STANDARD-OUTPUT* won't be  ;;modified by the arguments.  ;; 10/15/86 DNG - Prevent optimization of the constructed LET.  ;;  1/16/87 DNG - Remove suppression of CALL-N PDL-POP.  (LET ((FUNCTION (SECOND FORM)))    (IF (EQ (CAR-SAFE FUNCTION) 'PROGN);;  (FUNCALL (PROGN a b f) x y) ==> (PROGN a b (FUNCALL f x y))(CONS 'PROGN      (LOOP FOR X ON (REST FUNCTION)    COLLECTING (IF (REST X)   (FIRST X) (POST-OPTIMIZE   (FIX-FUNCALL-EVALUATION-ORDER      (LIST* (FIRST FORM)    (FIRST X)    (CDDR FORM))      OLD-ALLVARS)))))      (IF (OR (NOT (COMPILING-FOR-V2))      (INVULNERABLE-EXPRESSION-P FUNCTION)      ;; some common special cases which are unlikely to be SETQd by an argument:      (MEMBER FUNCTION '(SELF *STANDARD-INPUT* *STANDARD-OUTPUT*      *TERMINAL-IO* *QUERY-IO*) :TEST #'EQ)      (DOLIST (ARG (CDDR FORM) T)(UNLESS (INDEPENDENT-EXPRESSIONS-P ARG FUNCTION)  (RETURN NIL))))  FORM ; ok as is;; (FUNCALL (f1 x) (f2 y)) ==> (LET ((g (f1 x)));; (FUNCALL g (f2 y)))(LET ((TEMP (GENSYM))      (*OVERLAP-CANDIDATES* OLD-ALLVARS))  (P1 `(LET ((,TEMP ,(MARK-P1-DONE FUNCTION))) (HACK-FUNCALL ,TEMP ,(MARK-P1-DONE FORM)))      T) ; don't let LET-OPT undo it     )))))(DEFUN (:PROPERTY HACK-FUNCALL P1) (FORM)  (LET ((ORIGINAL-FORM (P1 (THIRD FORM))))    (ARBITRARY-SIDE-EFFECTS)    (LIST* (FIRST ORIGINAL-FORM) (P1V (SECOND FORM)) (CDDR ORIGINAL-FORM)) ))(DEFUN (:PROPERTY CALL P1) (FORM)  ;;  4/24/86 - For VM2, use ARGS-DESC instead of ARGS-INFO.  ;;  8/15/86 - Optimizer CALL-TO-MULTIPLE-VALUE-LIST changed into a P1 handler.  ;;  9/16/86 - Call ARBITRARY-SIDE-EFFECTS .  (ARBITRARY-SIDE-EFFECTS)  (IF (NOT (AND (= (LENGTH FORM) 4)(MEMBER (THIRD FORM)'('(:OPTIONAL :SPREAD) '(:SPREAD :OPTIONAL)):TEST #'EQUAL)))      (P1EVARGS FORM)    (LET ((ARGFORM (PRE-OPTIMIZE (FOURTH FORM) NIL))  (FIRSTARG (PRE-OPTIMIZE (SECOND FORM) NIL)))      (COND((ATOM ARGFORM) (P1EVARGS FORM))((AND (EQ (CAR ARGFORM) 'MULTIPLE-VALUE-LIST)      (CONSP FIRSTARG)      (EQ (CAR FIRSTARG) 'FUNCTION)      (CONSP (CADR FIRSTARG))      (MEMBER (CAADR FIRSTARG) '(GLOBAL:LAMBDA CLI:LAMBDA)      :TEST #'EQ)      (NOT (MEMBER '&REST (CADADR FIRSTARG) :TEST #'EQ))      (NOT (MEMBER '&KEY (CADADR FIRSTARG) :TEST #'EQ))) ;;(call #'(lambda (x y z) ..) '(:spread :optional) (multiple-value-list ...)) ;;and the lambda does not have a rest arg. ;;since we know how many args it wants, we can avoid consing the list of vals. ;;This weird optimization is for the sake of code made by CATCH-CONTINUATION. (LET ( NARGS #+Elroy MINARGS )   #-Elroy   (SETQ NARGS (LDB %%ARG-DESC-MAX-ARGS (ARGS-INFO (CADR FIRSTARG))))   #+Elroy   (MULTIPLE-VALUE-SETQ ( MINARGS NARGS ) (SI:ARGS-DESC (CADR FIRSTARG)))   (P1 (IF (= NARGS 1)   `(,(CADR FIRSTARG) ,(CADR ARGFORM)) `(PROGN    (MULTIPLE-VALUE-PUSH ,NARGS ,(CADR ARGFORM))    (,(CADR FIRSTARG) . ,(MAKE-LIST NARGS :INITIAL-VALUE '(%POP))))))));; The optimizations done on APPLY are not correct to do here,;; because they would cause the function to get an error;; if it does not want all the arguments.(T (P1EVARGS FORM))))));; 10/17/86 DNG - Deleted P1VALUE-CELL-LOCATION; special cases now handled in V-C-L-FIX .(DEFUN (:PROPERTY VARIABLE-LOCATION P1) (FORM)  ;;  6/17/86 DNG Fix to not make pass 2 barf when the argument is a keyword symbol.  ;;  3/23/87 DNG Set flag in compiland plist when taking location of local variable.  (COND ((NOT (SYMBOLP (SECOND FORM))) (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE       "The argument of VARIABLE-LOCATION is ~S, which is not a symbol."       (CADR FORM)) ''NIL)((KEYWORDP (SECOND FORM)) `(%EXTERNAL-VALUE-CELL ',(SECOND FORM)))(T (LET (( TEM (P1VAR (SECOND FORM)) ))     (ALTERING-VAR TEM)     (COND ((SYMBOLP TEM)    `(%EXTERNAL-VALUE-CELL ',TEM))   (T (WHEN (EQ (CAR TEM) 'LOCAL-REF)(SETF (GETF (COMPILAND-PLIST (VAR-COMPILAND (SECOND TEM)))    'KEEP-CURRENT-FRAME)      T)) ; tested in PASS2      `(VARIABLE-LOCATION ,TEM)))))))(DEFUN (:PROPERTY VARIABLE-MAKUNBOUND P1) (FORM &AUX TEM)  (IF (COND ((NOT (SYMBOLP (CADR FORM)))     (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE   "The argument of VARIABLE-MAKUNBOUND is ~S, which is not a symbol."   (CADR FORM))     NIL)    (T (SETQ TEM (P1VAR (CADR FORM)))       (COND ((SYMBOLP TEM))     ((EQ (CAR TEM) 'SELF-REF))     ((EQ (CAR TEM) 'LOCAL-REF)      (WARN 'VARIABLE-LOCAL ':IMPOSSIBLE    "VARIABLE-MAKUNBOUND is not allowed on local variables such as ~S"    (CADR FORM))      NIL)     ((EQ (CAR TEM) 'LEXICAL-REF)      (WARN 'VARIABLE-LOCAL ':IMPOSSIBLE    "VARIABLE-MAKUNBOUND is not allowed on lexical variables such as ~S"    (CADR FORM))      NIL))))      (P1 `(LOCATION-MAKUNBOUND (VARIABLE-LOCATION ,(CADR FORM))))    ''NIL))(DEFUN (:PROPERTY VARIABLE-BOUNDP P1) (FORM)  (IF (NOT (SYMBOLP (CADR FORM)))      (PROGN(WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE      "The argument of VARIABLE-BOUNDP is ~S, which is not a symbol." (CADR FORM))''NIL)    (LET ((TEM (P1VAR (CADR FORM))))      (COND ((SYMBOLP TEM)     `(BOUNDP ',TEM))    ((EQ (CAR TEM) 'LOCAL-REF) ''T)    ((EQ (CAR TEM) 'SELF-REF)     (P1 `(NOT (= DTP-NULL (%P-DATA-TYPE (VARIABLE-LOCATION ,(CADR FORM)))))))    ((EQ (CAR TEM) 'LEXICAL-REF) ''T)    #+compiler:debug    (T (BARF FORM 'VARIABLE-BOUNDP 'BARF))))));; 10/17/86 DNG - Deleted (:PROPERTY BOUNDP P1); an optimizer in the ZETALISP;;file now handles the special cases.(DEFUN (:PROPERTY UNSHARE-STACK-CLOSURE-VARS P1) ( FORM )  ;; This is used in code generated by the Scheme-to-Common-Lisp translator.  ;;  2/14/86 - Original.  (LIST (FIRST FORM)(LOOP FOR VAR IN (REST FORM)      COLLECT (LOOKUP-VAR VAR VARS))NIL));Any use of BIND must set SPECIALFLAG.(DEFPROP BIND P1BIND P1)(DEFPROP %USING-BINDING-INSTANCES P1BIND P1)(DEFUN P1BIND (FORM)  (UNLESS (ZEROP 1-IF-LIVE-CODE) ; unless in dead code     (SETF (COMPILAND-SPECIAL-FLAG *CURRENT-COMPILAND*) T)    (SETQ TRE-OK NIL)    (SETQ BINDP T)    (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT)))  (P1EVARGS FORM))(DEF SI:%BIND)(DEFUN (:PROPERTY SI:%BIND P1) (FORM)  (P1BIND `(BIND . ,(CDR FORM))));For (CLOSURE '(X Y Z) ...), make sure that X, Y, Z are special.(DEFPROP CLOSURE P1CLOSURE P1)(DEFUN P1CLOSURE (FORM)  ;;  9/16/86 - Update USED-VAR-SET.  ;;  3/25/87 - Watch out for use of D-TAIL-REC calls in the function being closed over.  (AND (NOT (ATOM (CADR FORM)))       (EQ (CAADR FORM) 'QUOTE)       (MAPC #'MSPL2 (CADADR FORM)))  (SETF USED-VAR-SET (LOGIOR USED-VAR-SET SPECIAL-VAR-BIT))  (LET* ((NEW-FORM (P1EVARGS FORM)) (ARG (THIRD NEW-FORM)) (NAME (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) (FN NIL))    (LOOP WHILE (AND (CONSP ARG)     (MEMBER (FIRST ARG)     '( SETQ PROGN PROGN-WITH-DECLARATIONS LET LET* LET-FOR-LAMBDA )))  DO (SETQ ARG (FIRST (LAST ARG))))    (WHEN (CONSP ARG)      (SETQ FN (SECOND ARG))      (COND ((MEMBER (FIRST ARG) '(QUOTE FUNCTION))     (WHEN (VALIDATE-FUNCTION-SPEC FN)       (FUNCTION-SPEC-PUTPROP FN (OR NAME T) 'USED-IN-DYNAMIC-CLOSURE)       (WHEN (AND QC-FILE-IN-PROGRESS (NOT QC-FILE-LOAD-FLAG)) (QC-FILE-FASD-FORM   `(FUNCTION-SPEC-PUTPROP ',FN FDEFINE-FILE-PATHNAME 'USED-IN-DYNAMIC-CLOSURE)))       #+Elroy       (LET ((DEF (FDEFINITION-SAFE FN T))) (WHEN (USES-TAIL-REC-P DEF)   (WARN 'USES-CALLDEST-TAIL-REC :PROBABLE-ERROR "Function ~S is used in a dynamic closure but was optimized to use TAIL-REC calls;it may need to be recompiled before it will work right." FN) ))))    ((MEMBER (FIRST ARG) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))     (SETF (GETF (COMPILAND-PLIST FN) 'KEEP-CURRENT-FRAME) T) ; tested in PASS2     (RETURN-FROM P1CLOSURE NEW-FORM))    ))    (IF (OR (EQ FN 'FUNCALL)    (EQ NAME 'MAKE-DYNAMIC-CLOSURE)    (NOT (COMPILING-FOR-V2))    (EXPR-TYPE-P ARG 'LIST))NEW-FORM ; use misc-op      `(MAKE-DYNAMIC-CLOSURE . ,(REST NEW-FORM)) ; need run-time check      )))(SETF (GET 'SYS:REMOTE-DISK-HANDLER 'USED-IN-DYNAMIC-CLOSURE) T) ; DEFUN compiled before CLOSURE seen#-Elroy ; a DEFSUBST in release 3(DEFUN (:PROPERTY EVENP P1) (FORM)  (P1 `(NOT (LOGTEST 1 ,(CADR FORM)))))#-Elroy ; a DEFSUBST in release 3(DEFUN (:PROPERTY ODDP P1) (FORM)  (P1 `(LOGTEST 1 ,(CADR FORM))))#+compiler:debug(defun (:property LOCAL-REF p1) ( form )  ;; Trap erroneous attempt to re-compile the output of pass 1.  ;; Without this handler, it would hang on the recursive var structure.  (barf form "is not valid input to the compiler." 'barf) );;;;        ==================================;;;;              DO, MAP, etc.;;;;        ==================================(DEFPROP DOP1DO P1)(DEFPROP DO-NAMEDP1DO P1)(DEFPROP DO*P1DO P1)(DEFPROP DO*-NAMEDP1DO P1)(DEFUN P1DO (FORM) ;;  1/06/86 DNG - Give warning on use of old MacLisp-style DO. ;;  1/21/86 DNG - Test OBSOLETE-FUNCTION-WARNING-SWITCH instead of INHIBIT-STYLE-WARNINGS-SWITCH. ;;  8/15/86 DNG - Optimizer DOEXPANDER changed to a P1 handler and renamed P1DO. ;; 10/15/86 DNG - Optimize loop with no bindings and an end test that folds to ;;a constant -- this enables optimizing CHECK-TYPE forms. ;; 10/16/86 CLM - Give warning when there is a nil exit test.  Give warning when compiling an ;;             index-variable specifier that is not correctly formed (instead of going into error ;;             handler).  (Fixes for SPR's 449 & 877) ;; 11/20/86 DNG - Fix to not do value-propagation on the ENDTEST form.  (LET ((X FORM) (PROGNAME) (PROGREST) SERIAL DECLS(*OVERLAP-CANDIDATES* *OVERLAP-CANDIDATES*))    (SETQ PROGREST  (PROG (DOSPECS ENDTEST ENDVALS TAG1 TAG3 PVARS STEPDVARS ONCE)    (COND      ((EQ (CAR X) 'DO-NAMED)       (SETQ PROGNAME (CADR X)) (SETQ X (CDDR X)))      ((EQ (CAR X) 'DO*-NAMED)       (SETQ PROGNAME (CADR X))       (SETQ X (CDDR X))       (SETQ SERIAL T))      ((EQ (CAR X) 'DO*)       (SETQ X (CDR X))       (SETQ SERIAL T))      (T (SETQ X (CDR X))));Get rid of "DO".    (COND      ((AND (CAR X) (ATOM (CAR X)))       ;; Old MacLisp-style DO       (SETQ DOSPECS `((,(CAR X) ,(CADR X) ,(CADDR X)))     ENDTEST (CAR (SETQ X (CDDDR X)))     ENDVALS NIL)       (WHEN (AND OBSOLETE-FUNCTION-WARNING-SWITCH  (NOT RUN-IN-MACLISP-SWITCH)) (WARN 'DO :OBSOLETE       "Obsolete form of DO: ~S~&The new way is: ~S"       FORM       (LIST* (FIRST FORM) DOSPECS (LIST ENDTEST) (CDR X)))))      (T (SETQ DOSPECS (CAR X)) (SETQ X (CDR X)) (IF (CAR X)     (SETQ ENDTEST (CAAR X)   ENDVALS (AND (OR (CDDAR X) (CADAR X))(CDAR X)))   (SETQ ONCE T))))    (SETQ X (CDR X))    (SETQ DOSPECS (REVERSE DOSPECS)) ; Do NOT use NREVERSE, or you will destroy    ; every macro definition in sight!! -DLW    ;; DOVARS has new-style list of DO variable specs,    ;; ENDTEST has the end test form,    ;; ENDVALS has the list of forms to be evaluated when the end test succeeds,    ;; ONCE is T if this is a DO-once as in (DO ((VAR)) () ...),    ;; X has the body.    (SETF (VALUES X DECLS) (EXTRACT-DECLARATIONS-RECORD-MACROS X))    ;; Now process the variable specs.    (DO ((X DOSPECS (CDR X)))((NULL X) NIL)      (COND ((ATOM (CAR X))     (PUSH (CAR X) PVARS))    ((OR (> (LENGTH (CAR X)) 3) (NOT (ATOM (CAAR X))) (WHEN (CDAR X)   (NOT (CONSP (CDAR X)))) (WHEN (CDDAR X)   (NOT (CONSP (CDDAR X)))) )     (WARN 'BAD-BINDING-LIST :IMPOSSIBLE   "Malformatted DO-variable specification ~S"   (CAR X)))    (T (PUSH `(,(CAAR X) ,(CADAR X)) PVARS)       (AND (CDDAR X)    (PUSH `(,(CAAR X) ,(CADDAR X)) STEPDVARS)))))    (WHEN ONCE      (IF COMPILING-COMMON-LISP  (WARN 'BAD-DO :IMPOSSIBLE"Ill formed exit test NIL in DO.")  (AND STEPDVARS       (WARN 'BAD-DO :IMPLAUSIBLE     "A once-only DO contains variables to be stepped: ~S."     STEPDVARS))  (RETURN `(,PVARS . ,X))))    ;; Turn STEPDVARS into a PSETQ form to step the vars,    ;; or into NIL if there are no vars to be stepped.    (SETQ STEPDVARS (APPLY 'NCONC STEPDVARS))    (AND STEPDVARS (SETQ STEPDVARS (CONS (IF SERIAL 'SETQ 'PSETQ)       STEPDVARS)))    (SETQ TAG3 (GENSYM))    (SETQ TAG1 (GENSYM))    (WHEN (NULL ENDTEST)      (AND ENDVALS (WARN 'BAD-DO :IMPOSSIBLE       "The end-test of a DO is NIL, but it says to evaluate ~S on exit."       ENDVALS))      (RETURN `(,PVARS ,TAG1 ,@X ,STEPDVARS (GO ,TAG1))))    (UNLESS (OR PVARS DECLS)      (LET ((SAVE-ALLVARS ALLVARS)    (ENDFORM (LET ((P1VALUE 'D-INDS))       (PROG1 (LET ((SUBST-VAR-SET 0)    (PROPAGATE-VAR-SET 0)) ; prevent value propagation(P1-WITH-ANNOTATION ENDTEST)) ; record usage for MARK-P1-DONE      (UPDATE-PROPAGATE-VAR-SET))))) ; in case of side-effects(COND ((EQUAL ENDFORM '(QUOTE NIL))       (DISCARD ENDFORM)       (RETURN `(()   ,TAG1 ,@X (GO ,TAG1)   (PROGN ,ENDVALS))))      ((ALWAYS-TRUE ENDFORM)       (DISCARD ENDFORM)       (RETURN-FROM P1DO (P1 `(BLOCK ,PROGNAME(AND NIL (TAGBODY ,@X)),@ENDVALS))))      (T (SETQ ENDTEST (MARK-P1-DONE ENDFORM)) (UNLESS (LISTP *OVERLAP-CANDIDATES*)   (SETQ *OVERLAP-CANDIDATES* SAVE-ALLVARS))))))    (SETQ ENDVALS `(RETURN-FROM ,PROGNAME (PROGN ,@ENDVALS)))    (RETURN     `(,PVARS (GO ,TAG3)       ,TAG1 ,@X ,STEPDVARS       ,TAG3 (OR ,ENDTEST (GO ,TAG1)) ,ENDVALS))))    (WHEN DECLS      (SETQ PROGREST (LIST* (FIRST PROGREST)    (CONS 'DECLARE DECLS)    (REST PROGREST))))    (AND PROGNAME (SETQ PROGREST (CONS PROGNAME PROGREST)))    (P1 (CONS (IF SERIAL 'PROG* 'PROG)      PROGREST))))(DEFPROP GLOBAL:MAPP1MAPX P1)(DEFPROP MAPLP1MAPX P1)(DEFPROP MAPCP1MAPX P1)(DEFPROP MAPCARP1MAPX P1)(DEFPROP MAPLISTP1MAPX P1)(DEFPROP MAPCANP1MAPX P1)(DEFPROP MAPCONP1MAPX P1)(DEFUN P1MAPX (FORM) ;;  1/29/86 Use CONS instead of NCONS to avoid warning. ;;  8/15/86 Optimizer MAPEXPAND changed to a P1 handler and renamed P1MAPX. ;;  9/20/86 When speed>space, expand even when function is not a lambda expression. ;; 10/14/86 Expand when the function is declared INLINE.  (IF (NULL (CDDR FORM));Don't bomb out if no args for the function to map.      (PROGN(WARN 'P1MAPX :IMPLAUSIBLE "~S with only one argument will loop forever." (FIRST FORM))(P1-DOWNWARD-FUNARG FORM))    (LET ((FN (PRE-OPTIMIZE (CADR FORM) NIL))  CALL-FN  (TAKE-CARS (MEMBER (CAR FORM) '(MAPC MAPCAR MAPCAN) :TEST #'EQ))  TEM)      (COND((NOT OPEN-CODE-MAP-SWITCH) (P1-DOWNWARD-FUNARG FORM));; Expand maps only if specified function is a quoted LAMBDA or a SUBST,;; or some arg is a call to CIRCULAR-LIST and we are mapping on cars,;; or if speed is more important than space.((NOT (OR (AND (NOT (ATOM FN))       (MEMBER (CAR FN) '(QUOTE FUNCTION) :TEST #'EQ)       (OR (NOT (ATOM (CADR FN)))   (> (OPT-SPEED OPTIMIZE-SWITCH) (OPT-SPACE OPTIMIZE-SWITCH))   (EQ (INLINE-DECL (CADR FN)) 'INLINE)))  (AND (NOT (ATOM FN))       (EQ (CAR FN) 'FUNCTION)       (NOT (ATOM (SETQ TEM (DECLARED-DEFINITION (CADR FN)))))       (MEMBER (CAR TEM)       '(GLOBAL:SUBST GLOBAL:NAMED-SUBST CLI:SUBST NAMED-SUBST MACRO)       :TEST #'EQ))  (AND TAKE-CARS       (SOME #'(LAMBDA (X)     (AND (NOT (ATOM X))  (NULL (CDDR X))  (EQ (CAR X) 'CIRCULAR-LIST))) (THE LIST (CDDR FORM)))))) (P1-DOWNWARD-FUNARG FORM))(T (IF (AND (NOT (ATOM FN))  (MEMBER (CAR FN) '(QUOTE FUNCTION) :TEST #'EQ))     (SETQ CALL-FN (LIST (CADR FN)))   (SETQ CALL-FN (LIST 'FUNCALL FN))) ;; VARNMS gets a list of gensymmed variables to use to hold ;; the tails of the lists we are mapping down. (LET ((VARNMS) (DOCLAUSES) (ENDTEST) (CARS-OR-TAILS) (TEM))       ;; DOCLAUSES looks like ((G0001 expression (CDR G0001)) ...)       ;;  repeated for each variable.       ;; ENDTEST is (OR (NULL G0001) (NULL G0002) ...)       ;; CARS-OR-TAILS is what to pass to the specified function:       ;;  either (G0001 G0002 ...) or ((CAR G0001) (CAR G0002) ...)   (SETQ VARNMS (DO ((L (CDDR FORM) (CDR L))      (OUTPUT))     ((NULL L)      OUTPUT)   (PUSH (GENSYM) OUTPUT)))   (SETQ DOCLAUSES (MAPCAR   #'(LAMBDA (V L)       (IF (AND TAKE-CARS(NOT (ATOM L))(EQ (CAR L) 'CIRCULAR-LIST)(NULL (CDDR L)))   `(,V ,(CADR L)) `(,V ,L (CDR ,V))) )   VARNMS (CDDR FORM)))   (SETQ ENDTEST (CONS 'OR       (MAPCAN #'(LAMBDA (VL)  (AND (CDDR VL) `((NULL ,(CAR VL)))))       DOCLAUSES)))   (SETQ CARS-OR-TAILS (IF TAKE-CARS     (MAPCAR       #'(LAMBDA (DC)  (IF (CDDR DC)      `(CAR ,(CAR DC))    (CAR DC)) )       DOCLAUSES)   VARNMS))   (P1 (COND ((MEMBER (CAR FORM) '(GLOBAL:MAP MAPL MAPC) :TEST #'EQ)   ;NO RESULT  (SETQ TEM`(INHIBIT-STYLE-WARNINGS   (DO-NAMED T     ,DOCLAUSES     (,ENDTEST)     (,@CALL-FN ,@CARS-OR-TAILS))))  ;; Special hack for MAP or MAPC for value:  ;; Bind an extra local to 1st list and return that.  (IF P1VALUE      `(LET ((MAP-RESULT       ,(PROG1 (CADAR DOCLAUSES)       (RPLACA (CDAR DOCLAUSES) 'MAP-RESULT)))) ,TEM MAP-RESULT)    TEM)) ((MEMBER (CAR FORM) '(MAPCAR MAPLIST) :TEST #'EQ)  ;;CONS UP RESULT  (LET ((MAP-RESULT (GENSYM))(MAP-TEMP (GENSYM)))    `(LET ((,MAP-RESULT))       (INHIBIT-STYLE-WARNINGS (DO-NAMED T   ((,MAP-TEMP     (INHIBIT-STYLE-WARNINGS (VARIABLE-LOCATION ,MAP-RESULT)))    . ,DOCLAUSES)   (,ENDTEST)   (RPLACD ,MAP-TEMP (SETQ ,MAP-TEMP   (CONS (,@CALL-FN ,@CARS-OR-TAILS) NIL)))))       ,MAP-RESULT))) (T  ;; MAPCAN and MAPCON:  NCONC the result.  (LET ((MAP-TEM (GENSYM))(MAP-RESULT (GENSYM)))    `(INHIBIT-STYLE-WARNINGS       (DO-NAMED T (,@DOCLAUSES  (,MAP-TEM)  (,MAP-RESULT)) (,ENDTEST  ,MAP-RESULT) (SETQ ,MAP-TEM (NCONC ,MAP-TEM (,@CALL-FN ,@CARS-OR-TAILS))) (OR ,MAP-RESULT (SETQ ,MAP-RESULT ,MAP-TEM)) (SETQ ,MAP-TEM (LAST ,MAP-TEM))))))))))))));; 9/20/86 Moved SUBSET handler to the ZETALISP file.(DEFUN P1EVARGS (FORM)  (DECLARE (OPTIMIZE SPEED))  (LET ((P1VALUE T))    (CONS (CAR FORM) (MAPCAR #'P1 (CDR FORM)))))(DEFUN P1-ALTER (FORM)  ;; Handler for functions which evaluate all arguments and modify data.  ;;  9/16/86 DNG - Original.  (PROG1 (P1EVARGS FORM) (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET DATA-ALTERATION-BIT))))(EVAL-WHEN ( EVAL LOAD )  (DOLIST ( F '( SET SI:SETCAR SI:SETELT SI:SETCDR RPLACA RPLACDAS-1 AS-2 AS-3 ASET SI:SET-ARRAY-LEADER ))    (WHEN (NULL (GET F 'P1))      (SETF (GET F 'P1) 'P1-ALTER) )))(DEFPROP EQ  P1EQ P1)(DEFPROP EQL P1EQ P1)(DEFUN P1EQ (FORM)  ;; 10/17/86 DNG - Original.  ;; 10/21/86 DNG - Fix to not complain about EQL on characters.  (LET ((NEW-FORM (P1-DOWNWARD-FUNARG FORM)))    ;; Warn about using EQ or EQL to compare things that need to be compared using EQUAL.    ;; Conceptually, this is a style checker, but it is implemented as a P1 handler    ;; because we do want it applied to macro expansions.    (LET ((ARG (THIRD NEW-FORM)))      (WHEN (OR (QUOTEP ARG)(QUOTEP (SETQ ARG (SECOND NEW-FORM))))(LET ((VALUE (SECOND ARG)))  (WHEN (AND (OR (CONSP VALUE) (ARRAYP VALUE) (AND (EQ (FIRST FORM) 'EQ)      (NUMBERP VALUE)      (OR (AND COMPILING-COMMON-LISP       *WARN-OF-SUPERSEDED-FUNCTIONS-P*)  (NOT (FIXNUMP VALUE)))) (AND (CHARACTERP VALUE)      (EQ (FIRST FORM) 'EQ)      COMPILING-COMMON-LISP))     (NOT INHIBIT-STYLE-WARNINGS-SWITCH))    (WARN 'IMPLAUSIBLE-COMPARE ':IMPLAUSIBLE  "~S should probably use ~S instead."  FORM (IF (OR (NUMBERP VALUE) (CHARACTERP VALUE)) 'EQL 'EQUAL))))))    NEW-FORM))(DEFUN P1-DOWNWARD-FUNARG ( FORM )  ;; This handler is for functions that can take a function as one of their   ;; arguments but which simply call the function and don't return it or store  ;; it anywhere.  This enables a LAMBDA expression used as an argument to   ;; be compiled using the MAKE-EPHEMERAL-LEXICAL-CLOSURE instruction.  ;; The function should also not have any free references to special variables.  ;;  2/21/86 - Original. [adapted from P1SIMPLE]  ;; 10/18/86 DNG - Update USED-VAR-SET; use P1SIMPLE.  (DECLARE (OPTIMIZE SPEED))  (LET (( NEW-FORM (P1SIMPLE FORM 'DOWNWARD-ONLY) ))    (UNLESS (TRIVIAL-FORM-P NEW-FORM)      (SETF USED-VAR-SET (LOGIOR USED-VAR-SET DATA-ALTERATION-BIT)))    NEW-FORM))(DEFUN P1-DOWNWARD-FUNARG-DESTRUCTIVE ( FORM )  ;;  9/16/86 DNG - Original.  (LET (( NEW-FORM (P1-DOWNWARD-FUNARG FORM) ))    (UNLESS (TRIVIAL-FORM-P NEW-FORM)      (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET DATA-ALTERATION-BIT)))    NEW-FORM))(EVAL-WHEN ( EVAL LOAD )  (DOLIST ( F     '(DEL DEL-IF DEL-IF-NOT CLI:DELETE DELETE-DUPLICATES DELETE-IF DELETE-IF-NOT       MAPCAN MAPCON  MERGE      CLI:NINTERSECTION NSET-DIFFERENCE NSET-EXCLUSIVE-OR NSUBLIS NSUBST NSUBST-IF       NSUBST-IF-NOT NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT CLI:NUNION       SORT SORTCAR STABLE-SORTCAR      CLI:SUBST SUBST-IF SUBST-IF-NOT SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT       ) )    (WHEN (MEMBER (GET F 'P1) '(NIL P1-DOWNWARD-FUNARG))      (SETF (GET F 'P1) 'P1-DOWNWARD-FUNARG-DESTRUCTIVE) ) ) )(EVAL-WHEN ( EVAL LOAD )  (DOLIST ( F     '(ADJOIN ASS CLI:ASSOC ASSOC-IF ASSOC-IF-NOT      COUNT COUNT-IF COUNT-IF-NOT       GLOBAL:EVERY CLI:EVERY FIND FIND-IF FIND-IF-NOT CLI:INTERSECTION      GLOBAL:MAP MAPC MAPCAR MAPL MAPLIST      MEM MEMASS CLI:MEMBER MEMBER-IF MEMBER-IF-NOT NOTANY NOTEVERY       POSITION POSITION-IF POSITION-IF-NOT      RASS CLI:RASSOC RASSOC-IF RASSOC-IF-NOT REDUCE      GLOBAL:REM REM-IF REM-IF-NOT CLI:REMOVE REMOVE-DUPLICATES REMOVE-IF REMOVE-IF-NOT      SEARCH SET-DIFFERENCE SET-EXCLUSIVE-OR CLI:SOME GLOBAL:SOME      SUBLIS SUBSET SUBSET-NOT SUBSETP       TREE-EQUAL CLI:UNION) )    (WHEN (NULL (GET F 'P1))      (SETF (GET F 'P1) 'P1-DOWNWARD-FUNARG) ) ) )(DEFUN P1SIMPLE ( FORM &OPTIONAL ARGS-P1VALUE)  ;; This P1 handler can be used for functions that don't need a  ;; more specialized handler and that meet all of  ;; the following requirements:  ;;   * All arguments are evaluated and don't take multiple values.  ;;   * The function is not a candidate for procedure integration.  ;;   * Only the argument values are significant, not their  ;; addresses.  In other words, the arguments could be copied  ;; to a different place in memory without altering the result  ;; or side-effects of the function.  For example, = meets this  ;; criterion but EQ does not.  ;;   * There are no side effects. (Function NO-SIDE-EFFECTS-P looks  ;; to see if functions have this property.)  ;;   * There are no free references to special variables.  ;; This handler serves two purposes:  ;;   * It provides faster processing of commonly used forms than  ;; using the general-purpose mechanism of P1ARGC.  ;;   * It sets P1VALUE to 'VALUE-ONLY to indicate that the argument  ;; addresses are not significant; this enables certain  ;; optimizations that would be unsafe otherwise.  ;; 1/19/85 - Original version:  ;;  ;; (DEFUN P1SIMPLE ( FORM )  ;;   (CONS (FIRST FORM)  ;; (LET (( P1VALUE 'VALUE-ONLY ))  ;;   (MAPCAR #'P1 (REST1 FORM)))))  ;;  ;; 2/26/85 - Use LOOP ... COLLECT instead of MAPCAR for speed.  ;; 6/26/85 - Re-coded to be faster still, and use CDR-coding besides.  ;;10/18/86 - Optional arg ARGS-P1VALUE.  (DECLARE (OPTIMIZE SPEED))  (PROG* (( P1VALUE (OR ARGS-P1VALUE 'VALUE-ONLY) )  ( RESULT (MAKE-LIST (LENGTH FORM) ':INITIAL-ELEMENT (FIRST FORM)) )  ( NEW RESULT )  ( ORIGINAL (CDR FORM) ) )   REPEAT    (WHEN (NULL ORIGINAL)      (RETURN RESULT) )    (SETQ NEW (CDR NEW))    (RPLACA NEW (P1 (CAR ORIGINAL)))    (SETQ ORIGINAL (CDR ORIGINAL))    (GO REPEAT) ) )(EVAL-WHEN ( EVAL LOAD )  (DOLIST ( F '( CHAR< CHAR<= CHAR> CHAR>=  CHAR-EQUAL   FLOAT ATOM NOT LISTP SYMBOLP MINUSP PLUSP NUMBERP STRINGP ARRAYP GET GETL LENGTH %DATA-TYPE ARRAY-LENGTH COMPILER:UNDEFINED-VALUE SYMBOL-PACKAGE SYMBOL-NAME G-L-P ARRAY-HAS-LEADER-P ARRAY-LEADER-LENGTH  ARRAY-HAS-FILL-POINTER-P ARRAY-TOTAL-SIZE ARRAY-DIMENSION ARRAY-DIMENSIONS BOUNDP FBOUNDP SYMBOL-VALUE SYMBOL-FUNCTION ))    (WHEN (NULL (GET F 'P1))      (SETF (GET F 'P1) 'P1SIMPLE) ) ) )(DEFUN P1ARITHMETIC (FORM)  (P1SIMPLE FORM (IF (OR (EQ P1VALUE 'INTEGER) (MEMBER (FIRST FORM) '(LOGAND LOGIOR LOGXOR LDB DPB)))     'INTEGER   'VALUE-ONLY)))(EVAL-WHEN ( EVAL LOAD )  (DOLIST ( F '(+ - * / = < > /= <= >= 1+ 1-LOGAND LOGIOR LOGXOR LDB DPBMAX MIN))    (WHEN (NULL (GET F 'P1))      (SETF (GET F 'P1) 'P1ARITHMETIC))))(DEFUN P1ACCESSOR (FORM)  (PROG1 (P1SIMPLE FORM) (SETF USED-VAR-SET (LOGIOR USED-VAR-SET DATA-ALTERATION-BIT))))(EVAL-WHEN ( EVAL LOAD )  (DOLIST ( F '(CAR CDR CADR CDDR CAAR CDAR CADDR CDDDR CADDDR CDDDR NTH NTHCDREQUAL EQUALPSTRING-GREATERP STRING-LESSP STRING-NOT-EQUAL STRING-NOT-GREATERPSTRING-NOT-LESSP STRING/= STRING< STRING<= STRING> STRING>=))    (SETF (GET F 'P1) 'P1ACCESSOR)))(DEFUN P1AREF (FORM)  (PROG1 (LIST* (FIRST FORM)(LET ((P1VALUE 'T)) (P1 (SECOND FORM)))(LET ((P1VALUE 'INTEGER))  (MAPCAR #'P1 (CDDR FORM)))) (SETF USED-VAR-SET (LOGIOR USED-VAR-SET DATA-ALTERATION-BIT))))(EVAL-WHEN ( EVAL LOAD )  (DOLIST ( F '(COMMON-LISP-AREF COMMON-LISP-AR-1 COMMON-LISP-AR-2 COMMON-LISP-AR-3CLI:AR-1 GLOBAL:AR-1 AR-2 AR-3 AREF GLOBAL:AREFELT COMMON-LISP-ELT GLOBAL:ELT))    (SETF (GET F 'P1) 'P1AREF)))T 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-SE