;;;  -*- Mode:Common-Lisp; Package:Compiler; Base:10 -*-

;;;			      RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(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) 1984-1989 Texas Instruments Incorporated. All rights reserved.
;;; Copyright (C) 1980 Massachusetts Institute of Technology


;;;;   *-----------------------------------------------------------*
;;;;   |           --  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.
;;;------------------ The following done after Explorer release 3.0 ------
;;;  6/29/87 DNG - Fix LOCAL-FUNCTION-SLOT-NAME for SPR 5719.
;;;  7/06/87 DNG - Fix P1LET for SPR 5566.
;;;  7/06/87 DNG - Fix P1EQ for SPR 5527.
;;;  8/10/87 DNG - Fix P1ASSOC for SPR 6224.
;;;------------------ The following done after Explorer release 3.1 ------
;;;  9/23/87 DNG - Fix P1FUNCTION for SPR 6548.
;;;------------------ The following done for Explorer release 4.0 ------
;;; 11/30/87 DNG - Fix P1COND for SPR 6972.
;;;------------------ The following done for Explorer release 4.1 ------
;;;  4/13/88 DNG - Modify P1-FUNCALL-WITH-MAP to fix SPR 7153.
;;;------------------ The following done for Explorer release 5.0 ------
;;;  8/04/88 DNG - Added doc string for %BIND.  Improve 
;;;		FIX-FUNCALL-EVALUATION-ORDER for (SEND SELF ...).  
;;;		Use SINGLE-VALUE flag in P1SETQ-1 and P1APPLY .
;;;		Recognize INTERNAL-GET-2 and INTERNAL-GET-3 has having no side-effects.
;;;  8/29/88 clm - Added check to P1THE for correct number of args [spr 8674].
;;;------------------ The following done for Explorer release 6.0 ------
;;;  3/15/89 DNG - Include support for CLOS.  Remove code for #-Elroy.
;;;  3/16/89 DNG - Add handler for LOAD-TIME-VALUE.
;;;  4/10/89 DNG - Use new function VAR-INIT-FORM .
;;;  4/22/89 DNG - Update FIX-FUNCALL-EVALUATION-ORDER for supporting Scheme.
;;;  4/26/89 DNG - Redesigned the internal representation of LET forms -- this 
;;;		simplifies the code as well as facilitating further optimization 
;;;		and bug fixing.  Added setting of *LOOP-VAR-BIT* to facilitate future 
;;;		optimizations.
;;;  5/04/89 DNG - Add optional run-time checking of type declarations.
;;;  5/18/89 DNG - Add binding of *LOOP-VAR-BIT* to handlers for 
;;;		UNWIND-PROTECT, CATCH, BLOCK, and %DISPATCH.  Fix bug in use of 
;;;		*LOOP-VAR-BIT* in UPDATE-PROPAGATE-VAR-SET .


;; (MULTIPLE-VALUE-BIND variable-list m-v-returning-form . body)
;; turns into (MULTIPLE-VALUE-BIND boundvars outer-vars new-vars m-v-returning-form . body)
(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.
  ;;  5/03/89 DNG - Change to use BOUNDVARS instead of VARIABLES in the output form.
 (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))
    (LET ((BOUNDVARS (NTH-VALUE 1 (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) ,BOUNDVARS ,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 LIST	P1ASSOC P1)
(DEFPROP NCONC	P1ASSOC P1)
(DEFPROP APPEND	P1ASSOC 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.
  ;;  8/10/87 DNG - Introduce use of a temporary variable to avoid pushing all of
  ;;		the arguments on the stack first, since that would likely exceed
  ;;		the 256 limit on PDL buffer size. 
  (WHEN (EQ (FIRST FORM) 'NCONC)
    (SETF ALTERED-VAR-SET (LOGIOR ALTERED-VAR-SET DATA-ALTERATION-BIT)))
  (IF (< (LENGTH FORM) 64.)
      (P1EVARGS FORM)
    (LET ((HEAD (LIST* (IF (EQ (CAR FORM) 'LIST)
			   'LIST*
			 (CAR FORM))
		       (FIRSTN 61. (CDR FORM))))
	  (TAIL (CONS (CAR FORM)
		      (NTHCDR 61. (CDR FORM)))))
      (IF (INDEPENDENT-EXPRESSIONS-P HEAD TAIL)
	  (LET ((TEMP (GENSYM)))
	    (P1 `(LET ((,TEMP ,TAIL))
		   ,(NCONC HEAD (LIST TEMP)))
		T))
	(P1 (NCONC HEAD (LIST TAIL)))))))

;;  (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.
  ;;  7/06/87 DNG - Add OVERLAP argument to DYNAMIC-BINDING-HACK to fix unbinding
  ;;		for nested PROGVs [SPR 5566].
  ;;  3/03/89 DNG - Update SETQ optimization to always update the VAR-INIT 
  ;;		field for consistency.
  ;;  4/10/89 DNG - Delete use of obsolete variable TLFUNINIT .
  ;;  4/26/89 DNG - Generate a %LET form for pass 2.
  (LET ((VARS VARS) OUTER-VARS BOUNDVARS
	(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)
	(OVERLAP ALLVARS))
    ;; 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))))
    ;; &AUX vars should be allowed to inherit special declarations
    ;; since that is what it looks like when you put a DECLARE inside the body.
    (MULTIPLE-VALUE-SETQ (VLIST BOUNDVARS)
      (P1SBIND VLIST '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))
		      (NOT TLEVEL)
		      (EQ FN 'LET*))
		 (NOT (NULL (VAR-USE-COUNT (SETQ HOME (LOOKUP-VAR (CADR TEM) VARS))))))
	     (RETURN NIL))
	    (T (LET ((XX (P1V (CADDR TEM))))
		  (SETQ BODY
			(IF (AND (NULL (CDR BODY)) (NULL (CDDDR TEM)))
			    (LIST (CADR TEM))
			  (CONS (CONS 'SETQ (CDDDR TEM)) (CDR BODY))))
		  #+compiler:debug
		  (let ((vv (car-safe (MEMBER (CADR TEM) VLIST :TEST #'EQ))))
		    (DEBUG-ASSERT (or (symbolp vv)
				      (eq (second vv) (VAR-INIT-FORM HOME)))))
		  (RPLACA (MEMBER (CADR TEM) VLIST :TEST #'EQ) 
			  `(,(CADR TEM) ,XX))
		  (P1SETVAR (CADR TEM)) ; to prevent propagation of original NIL value.
		  (SETF (VAR-INIT HOME) (LIST 'FEF-INI-COMP-C XX))))))
    ;; 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 OVERLAP)
      `(,(IF (EQ FN 'LET*) '%LET* '%LET)
	 (,BOUNDVARS ,VARS ,OUTER-VARS ,BINDP ,(> LEXICAL-CLOSURE-COUNT ENTRY-LEXICAL-CLOSURE-COUNT))
	 . ,BODY)
      )
 ))
#+compiler:debug
(progn
(DEF LET-FOR-LAMBDA)
(SYS:DEFPRINT LET-FOR-LAMBDA 1)
(SYS:DEFMACRO-COPY-INDENTATION-FOR-ZWEI 'LET-FOR-LAMBDA 'LET)
)

;; 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.
  ;;  4/26/89 DNG - Generate a %LET.
 (P1-WITH-ANNOTATION FORM #'(LAMBDA (FORM)
  (LET ((VARS VARS) OUTER-VARS INNER-VARS
	BODY VLIST (TRE-OK TRE-OK)  BOUNDVARS
	(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)
    (MULTIPLE-VALUE-SETQ (VLIST BOUNDVARS)
      (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 (,BOUNDVARS ,INNER-VARS ,OUTER-VARS
	      ,BINDP ,(> LEXICAL-CLOSURE-COUNT ENTRY-LEXICAL-CLOSURE-COUNT))
	  . ,BODY)
      )))))

#+compiler:debug
(SETF (GET 'LET-FOR-LAMBDA 'SYS:SPECIALLY-GRIND) (GET 'LET 'SYS:SPECIALLY-GRIND)) ; 4/14/89

(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.
  ;;  4/11/89 DNG - Use *EVAL instead of EVAL1.
  (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))
			(*EVAL (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.
  ;;  5/18/89 DNG - Add binding of *LOOP-VAR-BIT*.  The way it is done here is 
  ;;		actually over-kill; we would like to set it only when the first RETURN 
  ;;		is found, but that is a refinement that will have to wait for next release.
  (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))
	 (*LOOP-VAR-BIT* VAR-BIT))
    (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)) )

(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.
  ;;  4/26/89 DNG - Add use of *LOOP-VAR-BIT* .
  (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* )
	( *LOOP-VAR-BIT* *LOOP-VAR-BIT* )
	( 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 *LOOP-VAR-BIT* VAR-BIT)
			       (SETQ LIVE T)
			       STMT)
	      ELSE WHEN LIVE
		COLLECT (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)

(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*.
  ;;  4/26/89 DNG - Bind *LOOP-VAR-BIT*.
  (LET (( LISTVAL (LET (( P1VALUE 'VALUE-ONLY ))
		    (P1 (THIRD FORM)) ))
	( P1VALUE NIL )
	( *LOOP-VAR-BIT* VAR-BIT ))
    (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 MAP-VARIABLES-IN-SET (FUNCTION CHECK-SET VAR-LIST)
  ;;  5/3/89 DNG - Original.
  (UNLESS (ZEROP CHECK-SET)
    (DOLIST (V VAR-LIST (debug-assert nil nil "Didn't find variables in set #o~O" check-set))
      (WHEN (EQ (VAR-TYPE V) 'FEF-LOCAL)
	(LET ((ADDR (VAR-LAP-ADDRESS V)))
	  (WHEN (EQ (CAR-SAFE ADDR) 'LOCAL-REF)
	    (LET ((BIT (CDDR ADDR)))
	      (WHEN (LOGTEST BIT CHECK-SET)
		;; Found one of the variables in the set.
		(FUNCALL FUNCTION V BIT)
		(SETQ CHECK-SET (LOGDIF CHECK-SET BIT))
		(WHEN (ZEROP CHECK-SET)
		  ;; Found everything we were looking for.
		  (RETURN)))))))))
  (VALUES))

(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.
  ;; 5/03/89 DNG - Use MAYBE-PROPAGATE to reconfirm variables affected by SETQ-OPT.
  ;; 5/18/89 DNG - Fix for when *LOOP-VAR-BIT* is zero.
  (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET ALTERED-VAR-SET))
  ;; Need to make sure that SETQ-OPT has not changed the initial value form to 
  ;; something that is not eligible for propagation.  Only need to check 
  ;; variables bound within the innermost loop.
  (MAP-VARIABLES-IN-SET
     #'(LAMBDA (V BIT)
	  ;; Reconfirm its eligibility for propagation.
	  (UNLESS (MAYBE-PROPAGATE V)
	     ;; Nope; remove it from the set.
	     (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET BIT))))
     (IF (> *LOOP-VAR-BIT* 0)
	 (LOGDIF PROPAGATE-VAR-SET (- *LOOP-VAR-BIT* 1))
       PROPAGATE-VAR-SET)
     VARS)
  (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 (VAR-INIT-FORM 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 )
  ;;  5/18/89 DNG - Add binding of *LOOP-VAR-BIT*.
  (LET* (( SELECTOR (P1V (SECOND FORM)) )
	 ( MAX -1 )
	 ( DEFAULT (P1 (THIRD FORM)) )
	 ( BODY (LET (( P1VALUE NIL )
		      (*LOOP-VAR-BIT* *LOOP-VAR-BIT*))
		  (LOOP FOR X IN (NTHCDR 3 FORM)
			COLLECT (IF (FIXNUMP X)	   ; value tag
				    (PROGN (SETQ *LOOP-VAR-BIT* VAR-BIT)
					   (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.
  ;; 10/26/88 DNG - Preserve CDDR of *LOCAL-ENVIRONMENT*.
  ;; 11/16/88 DNG - Permit non-symbol function names.
  ;;  4/20/89 DNG - Include actual definition in *LOCAL-ENVIRONMENT* instead of 
  ;;		NIL; this is to avoid confusion with an undefined function in places 
  ;;		like TICLOS:FREEZE .
  (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 (AND (SYMBOLP (CAR ELT))
					(LIST* (LOCF (SYMBOL-FUNCTION (CAR ELT))) (THIRD ELT) NIL)))
		       (SECOND *LOCAL-ENVIRONMENT*))
		 (CDDR *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.
  ;;  6/29/87 DNG - If the name is already a gensym, don't create an interned
  ;;		symbol since that would prevent overlapping local slots. [SPR 5719]
  ;; 11/16/88 DNG - Support non-symbol function names [such as (SETF ...)].
  (LET ((FSPEC (CAR DEF)))
    (LET ((SYMBOL (IF (AND (SYMBOLP FSPEC)
			   (NULL (SYMBOL-PACKAGE FSPEC)))
		      (MAKE-SYMBOL (SYMBOL-NAME FSPEC))
		    (INTERN (FORMAT NIL "#'~A" FSPEC)
			    *PACKAGE*))))
      (SETF (GET SYMBOL 'LOCAL-FUNCTION-NAME) FSPEC)
      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.
  ;; 11/23/88 DNG - Extend to handle non-symbol function names.
  (LET ((NAME (FIRST DEF))
	(ARGLIST (SECOND DEF)))
    (MULTIPLE-VALUE-BIND (BODY DECLARATIONS DOCUMENTATION)
	(EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR DEF) NIL T)
      (IF (SYMBOLP NAME)
	  (SETQ BODY `((BLOCK ,NAME . ,BODY)))
	(IF (AND (CONSP NAME) (EQ (CAR NAME) 'SETF) (SYMBOLP (SECOND NAME)))
	    (SETQ BODY `((BLOCK ,(SECOND 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)
	     (IF (CONSP NAME) (LIST NAME) 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 .
  ;; 10/26/88 DNG - Preserve CDDR of *LOCAL-ENVIRONMENT*.
  ;;  4/20/89 DNG - Include actual definition in *LOCAL-ENVIRONMENT* instead of 
  ;;		NIL; this is to avoid confusion with an undefined function in places 
  ;;		like TICLOS:FREEZE .
  ;;  4/24/89 DNG - Fix for non-symbol function specs.
  (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 (AND (SYMBOLP (FIRST ELT))
					(LIST* (LOCF (SYMBOL-FUNCTION (FIRST ELT))) (THIRD ELT) NIL)))
		       (SECOND *LOCAL-ENVIRONMENT*))
		 (CDDR *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 .
  ;; 10/26/88 DNG - Preserve CDDR of *LOCAL-ENVIRONMENT*.
  (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*))
		 (CDDR *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))) ))


(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 *CATCH		P1CATCH P1)
(DEFPROP CLI:CATCH	P1CATCH P1)
(DEFUN P1CATCH (FORM)
  ;;  5/10/86 DNG - Original; replaces pre-optimizer *CATCH-PROGNIFY.
  ;;  5/18/89 DNG - Add binding of *LOOP-VAR-BIT*.
  (LIST '*CATCH
	(P1V (SECOND FORM))
	(LET ((*LOOP-VAR-BIT* VAR-BIT))
	  (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.
  ;; 11/30/87 DNG - Fix to update PROPAGATE even when REST is null.  [SPR 6972]
  ;;  4/26/89 DNG - Add use of *LOOP-VAR-BIT*.
 (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 AND *LOOP-VAR-BIT* = *LOOP-VAR-BIT*
	       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) ) )
		   (SETQ *LOOP-VAR-BIT* VAR-BIT) ; set this after the first test
		   (CONS TEST
			 (IF 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))
				      ))
			   (PROGN (SETQ PROPAGATE (LOGAND PROPAGATE PROPAGATE-VAR-SET))
				  NIL)))
		   )
    ) ) ) ) )
  (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)
	(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.
  ;; 11/17/88 DNG - Optimize nested PROGNs.
  (OR (LET* ( ( DEST P1VALUE ) ( P1VALUE NIL )
	     ( FORMS-LEFT FORMS ) BEFORE AFTER
	     (BODY
	       (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) ) ))))
	(WHEN (EQ (CAR-SAFE (FIRST BODY)) 'PROGN)
	  ;; optimize (PROGN (PROGN a b) x y) ==> (PROGN a b x y)
	  ;; This doesn't help by itself but may enable other optimizations.
	  (SETQ BODY (NCONC (REST (FIRST BODY)) (REST BODY))))
	BODY)
      '((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.
  ;;  8/29/88 clm - Added check for too many arguments.
  ;;  3/16/89 DNG - Use new function CHECK-ARG-COUNT to check for too few as well as too many args.
  ;;  5/04/89 DNG - Add use of VALIDATE-TYPES-P and THE-TYPE-ERROR.
  (CHECK-ARG-COUNT FORM 2 2)
  (LET ((TYPE (CANONICALIZE-TYPE-FOR-COMPILER (SECOND FORM) FORM T) )
	(EXP (THIRD FORM)))
    (IF (OR (EQ TYPE 'UNKNOWN) (EQ TYPE 'T))	; no useful information
	(P1 EXP)
      (P1-WITH-ANNOTATION 
	(IF (VALIDATE-TYPES-P)
	    `(LET-FOR-LAMBDA ((.VALUE. ,EXP))
	       (DECLARE (OPTIMIZE (SAFETY 0) (SPACE 2) (SPEED 1)))
	       (IF (TYPEP .VALUE. ',(SECOND FORM))
		   .VALUE.
		 (THE-TYPE-ERROR .VALUE.
				 ',(IF (OR (ATOM EXP) (< (LENGTH EXP) 3))
				       EXP
				     (LET ((*PRINT-LENGTH* 3) (*PRINT-LEVEL* 2))
				       (PRINC-TO-STRING EXP)))
				 ',(SECOND FORM))))
	  EXP)
	#'P1 TYPE))))

(DEFPROP OR P1ANDOR P1)
(DEFPROP AND P1ANDOR P1)
(DEFUN P1ANDOR ( FORM )
  ;; 10/14/86 - Bind EXPRESSION-SIZE-LIMIT.
  ;;  3/17/89 - Bind P1VALUE to D-INDS or SINGLE-VALUE instead of T.
  ;;		This enables optimizing (AND (NOT (NULL a)) b) ==> (AND a b)
  ;;  4/26/89 - Add use of *LOOP-VAR-BIT*.
 (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 (IF (EQ (FIRST FORM) 'AND) 'D-INDS 'SINGLE-VALUE) )
	  ( *LOOP-VAR-BIT* *LOOP-VAR-BIT* ))
    (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
				 (PROG1 (P1 (FIRST ARGS))
					(SETQ *LOOP-VAR-BIT* VAR-BIT))
			       (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)
  ;;  3/16/89 DNG - Use new function CHECK-ARG-COUNT.
  ;;  5/03/89 DNG - Add option for run-time type checking.
  (CHECK-ARG-COUNT FORM 2 2)
  (IF (NULL (CDR (CADR FORM)))
      (IF (NULL (CAR (CADR FORM)))
	  (P1V (CADDR FORM))
	(P1V `(SETQ ,(CAR (CADR FORM)) ,(CADDR FORM))))
    (LET ((NEW-FORM (LIST 'MULTIPLE-VALUE
			  (MAPCAR #'P1SETVAR (CADR FORM))
			  (P1V (CADDR FORM)))))
      (IF (VALIDATE-TYPES-P)
	  (LIST* 'PROG1 NEW-FORM
		 (LET ((P1VALUE NIL) TYPE NAME)
		   (LOOP FOR ADDR IN (SECOND NEW-FORM)
			 DO (SETQ TYPE
				  (IF (SYMBOLP ADDR)
				      (PROGN (SETQ NAME ADDR)
					     (OR (GETDECL NAME 'DECLARED-TYPE 'NIL)
						 (GETDECL NAME 'VARIABLE-TYPE 'T)))
				    (IF (EQ (CAR-SAFE ADDR) 'LOCAL-REF)
					(PROGN (SETQ NAME (VAR-NAME (SECOND ADDR)))
					       (VAR-DECLARED-TYPE (SECOND ADDR)))
				      'T)))
			 UNLESS (EQ TYPE 'T)
			 COLLECT (P1 `(OR (TYPEP ,NAME ',TYPE)
					  (ASSIGNMENT-TYPE-ERROR ,NAME ',NAME ',TYPE)))
			 )))
	NEW-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.
  ;;  3/16/89 DNG - Use new function CHECK-ARG-COUNT.
  (CHECK-ARG-COUNT FORM 2 2)
  (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)
(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))) ))

(DEFUN (:PROPERTY UNWIND-PROTECT P1) (FORM)
  ;;  5/18/89 DNG - Original; created to bind *LOOP-VAR-BIT*.
  (LET ((*LOOP-VAR-BIT* VAR-BIT))
    (P1PROG1 FORM)))

(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.
  ;;  8/04/88 DNG - Call P1 with P1VALUE bound to 'SINGLE-VALUE instead of using P1V.
  ;;  5/04/89 DNG - Add option for run-time checking of the value against the 
  ;;		declared type of the variable.
  ;;  5/06/89 DNG - Add binding of *OVERLAP-CANDIDATES*.
    (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* (( SAVE-ALLVARS ALLVARS )
		    ( VALEXP (LET ((P1VALUE 'SINGLE-VALUE)) (P1 (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))
		 (PROGN
		   (DEBUG-ASSERT (NEQ (CAR PAIRS) '.VALUE.)) ; EXPR-TYPE-P assumes this won't be altered.
		   (WHEN (VALIDATE-TYPES-P)
		     (LET ((TYPE (IF (SYMBOLP VAR)
				     (OR (GETDECL VAR 'DECLARED-TYPE 'NIL)
					 (GETDECL VAR 'VARIABLE-TYPE 'T))
				   (IF (EQ (CAR-SAFE VAR) 'LOCAL-REF)
				       (VAR-DECLARED-TYPE (SECOND VAR))
				     'T))))
		       (UNLESS (EQ TYPE 'T)
			 (SETQ VALEXP
			       (LET (( *OVERLAP-CANDIDATES* SAVE-ALLVARS ))
				 (P1V `(LET-FOR-LAMBDA ((.VALUE. ,(MARK-P1-DONE VALEXP)))
					 (DECLARE (OPTIMIZE (SAFETY 0) (SPACE 2) (SPEED 1)))
					 (IF (TYPEP .VALUE. ',TYPE)
					     .VALUE.
					   (ASSIGNMENT-TYPE-ERROR .VALUE. ',(FIRST PAIRS) ',TYPE))
					 )))))))
		   (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.
  ;;  5/10/88 DNG - Warn when altering a CLOS method argument.
  ;;  5/12/88 DNG - Don't warn when arg class is T.
  (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 (VAR-INIT-FORM 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)) ))
	 (WHEN (AND (GETF (VAR-DECLARATIONS (SECOND FORM)) 'MAPPING-TABLE)
		    (NOT (EQ (VAR-DATA-TYPE (SECOND FORM)) 'T)))
	   (WARN 'ALTERING-VAR :PROBABLE-ERROR
		 "Assigning to method argument ~S; slot accesses cannot be correctly optimized."
		 (VAR-NAME (SECOND FORM)))
	   (SETF (GETF (VAR-DECLARATIONS (SECOND FORM)) 'MAPPING-TABLE) NIL)
	   ))
	((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-KEYARGS	P1-STORE-KEYARGS P1)

;; (SI:STORE-KEYWORD-ARG-VALUES frame-pointer rest-arg keykeys allow-other-keys location-of-first-cell)
;;	      1			     2		 3	  4	   5		       6
(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 (EQ (FIRST FORM) 'SI:STORE-KEYWORD-ARG-VALUES)
	  `(SI:STORE-KEYARGS . ,(CDDR NEW-FORM))
	NEW-FORM )))



;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.
  ;;  4/13/88 DNG - Fix to prevent invalid instance variable references after 
  ;;		the SELF-MAPPING-TABLE has been changed by a 
  ;;		FUNCALL-WITH-MAPPING-TABLE-INTERNAL. [SPR 7153]
  (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)
	      (PROG1 (P1 `(PROGN (SETQ SELF-MAPPING-TABLE ,MAP)
				 ,(MARK-P1-DONE EXPANSION ) ) )
		      (WHEN SELF-FLAVOR-DECLARATION
			 ;; Mapping table changed; can't reference ivars anymore.
			(SETF (CDDR SELF-FLAVOR-DECLARATION) NIL)))
	    (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 (SECOND NEW-REST) 'SELF-MAPPING-TABLE)
		       (AND (EQ (FIRST FORM) 'FUNCALL-WITH-MAPPING-TABLE-INTERNAL)
			     ;; Mapping table changed; can't reference ivars anymore. [SPR 7153]
			    (PROGN (WHEN (CDDR SELF-FLAVOR-DECLARATION)
				     (SETQ SELF-FLAVOR-DECLARATION
					   (LIST (FIRST SELF-FLAVOR-DECLARATION)
						 (SECOND SELF-FLAVOR-DECLARATION))))
				   T)))
		   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) ) ) ) )
  )

(comment ; obsolete
(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))))))
)

(DEFUN (:property %load-time-value p1) (FORM)
  (check-arg-count form 1 2)
  (let ((opt (let ((*local-environment* *compile-file-environment*)	; don't use local macros
		   (local-functions nil) (vars nil))
	       ;; expand macros but not defsubsts.
	       (pre-optimize (second form) t t)))
	(read-only-p (third form)))
    (unless (member read-only-p '(nil t) :test #'eq)
      (warn (car form) ':ignorable-mistake "Second arg of ~S should be either T or NIL." form)
      (setq read-only-p (compile-time-eval read-only-p 'declare)))
    (when file-in-cold-load
      (warn 'load-time-value ':probable-error "Can't use ~S in the cold load." 'load-time-value))
    (list (first form) opt read-only-p)
    ))

(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.
  ;; 9/23/87 DNG - Use new function NOT-EPHEMERAL to fix SPR 6548.
  ;;11/16/88 DNG - Support local (SETF ...) functions.
  (LET (( FN (SECOND FORM) ))
    (COND ((OR (SYMBOLP FN)
	       (AND (CONSP FN) (MEMBER (CAR FN) '(SETF LOCF))
		    (VALIDATE-FUNCTION-SPEC FN)))
	   (LET ((TM (IF (ATOM FN)
			 (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQ)
		       (ASSOC FN LOCAL-FUNCTIONS :TEST #'EQUAL))))
	     (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))
		     (NOT-EPHEMERAL (VAR-INIT-FORM (SECOND TM)))) ; 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))))))))

(DEFUN NOT-EPHEMERAL (INIT)
  ;; Given the initial value expression of a variable, if it constructs a 
  ;; lexical closure, then mark the closure as not being ephemeral, and 
  ;; recursively mark any closures that it references from the inherited 
  ;; environment [but not closures it creates itself].
  ;; Called from P1FUNCTION and BREAKOFF.
  ;;  9/23/87 DNG - Original version.  [for SPR 6548]
  (WHEN (AND (CONSP INIT)
	     (EQ (FIRST INIT) 'LEXICAL-CLOSURE)
	     (THIRD INIT))
    (SETF (THIRD INIT) NIL) ; change ephemeral flag from true to false
    (LET* ((COMPILAND (SECOND INIT))
	   (USED (COMPILAND-USED-VAR-SET COMPILAND)))
      (UNLESS (ZEROP USED)
	(DOLIST ( V (COMPILAND-INHERITED-VARS COMPILAND))
	  (WHEN (EQ (VAR-TYPE V) 'FEF-LOCAL)
	    (LET (( THIS-VAR-BIT (CDDR (VAR-LAP-ADDRESS V))))
	      (WHEN (LOGTEST USED THIS-VAR-BIT)
		;; This is one of the referenced variables.
		;; If this closure is not ephemeral, then any that it uses can't be either.
		(LET ((VINIT (VAR-INIT V)))
		  (WHEN (CONSP VINIT)
		    (NOT-EPHEMERAL (SECOND VINIT)) ))
		(WHEN (ZEROP (SETF USED (LOGDIF USED THIS-VAR-BIT)))
		  ;; Found all that we were looking for.
		  (RETURN))
	      )))))))
  (VALUES))

(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.
  ;;  8/04/88 DNG -  Bind P1VALUE to 'SINGLE-VALUE instead of T.
  ;;  4/18/89 DNG - Set USED-ONLY-ONCE flag [like P1 does for FUNCALL].
  (PROG1 (LET ((SAVE-ALLVARS ALLVARS))
	   (FIX-FUNCALL-EVALUATION-ORDER
	     (LIST* (FIRST FORM)
		    (LET* (( P1VALUE 'DOWNWARD-ONLY )	   ; permit ephemeral closure
			    (TM (COMPILAND-CHILDREN *CURRENT-COMPILAND*))
			    (F (P1 (SECOND FORM))))
		      (WHEN (AND (MEMBER (CAR-SAFE F) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))
				   (EQ (SECOND F) (FIRST (COMPILAND-CHILDREN *CURRENT-COMPILAND*)))
				   (EQ TM (REST (COMPILAND-CHILDREN *CURRENT-COMPILAND*))))
			 ;; Encourage PROCEDURE-INTEGRATION.
			 (SETF (GETF (COMPILAND-PLIST (SECOND F)) 'USED-ONLY-ONCE) T))
		      F)
		    (LET (( P1VALUE 'SINGLE-VALUE ))
		      (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.
  ;;  8/04/88 DNG - Improve the code generated for (SEND SELF ... non-trivial-arg).
  ;;  4/22/89 DNG - Evaluate function last in Scheme mode.
 (IF (COMPILING-SCHEME-P)
     ;; Scheme does not require left-to-right evaluation order, and in fact, 
     ;; PC Scheme actually evaluates the function after the arguments.
     FORM
  (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)
	      (AND (EQUAL FUNCTION '(%FUNCTION-INSIDE-SELF))
		   SELF-FLAVOR-DECLARATION) ; from (SEND SELF ...) in a DEFMETHOD
	      (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)
  ;;  5/05/89 DNG - Watch out for the possibility of the form being optimized into something different.
  ;;  5/10/89 clm - It appears the new check for optimization didn't cover all cases.  Ran into a problem
  ;;                of FORM being (HACK-FUNCALL xxxx (P1-HAS-BEEN-DONE (FUNCALL...).  This was failing the
  ;;                EQ test against FORM2, which after passing through P1 no longer had the P1-HAS-BEEN-DONE 
  ;;                tag.
  (LET ((FORM2 (P1 (THIRD FORM))))
    (IF (or (EQ (FIRST FORM2) (FIRST (THIRD FORM)))
	    (eq (first form2) (first (fourth (third form)))))
	;; Unless optimized into something different
	(PROGN
	  (ARBITRARY-SIDE-EFFECTS)
	  (LIST* (FIRST FORM2) (P1V (SECOND FORM)) (CDDR FORM2)) )
      FORM2)))

(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 MINARGS )
	   (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))))))

(DEFUN (:PROPERTY %STACK-FRAME-POINTER P1) ( FORM )
  ;; Tail recursion elimination cannot be done on a
  ;; function containing a call to %stack-frame-pointer;
  ;; the value returned by %stack-frame-pointer would
  ;; no longer be valid after the stack was changed by TRE.
  ;; 12/02/87 CLM - Original version.
  (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*)
				    'KEEP-CURRENT-FRAME)
			      T)
  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.
  ;; 12/01/87 CLM - Added handling for NIL and T.
  (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)
	((OR (KEYWORDP (SECOND FORM))
	     (MEMBER (SECOND FORM) '(NIL T) :TEST #'EQ))
	 `(%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))))
(SETF (GET 'SI:%BIND 'ARGLIST) (GET 'BIND 'ARGLIST))
(SETF (DOCUMENTATION 'SI:%BIND) (DOCUMENTATION 'BIND))

;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.
  ;;  5/02/89 DNG - Removed special handling for tail-recursive calls, which 
  ;;		has been made unnecessary by later microcode changes.
  (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)))
    ;;(LOOP WHILE (AND (CONSP ARG)
    ;;		     (MEMBER (FIRST ARG)
    ;;			     '( SETQ PROGN PROGN-WITH-DECLARATIONS %LET %LET*)))
    ;;	  DO (SETQ ARG (FIRST (LAST ARG))))
    (WHEN (AND (CONSP ARG)
	       (MEMBER (FIRST ARG) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE)))
      (SETF (GETF (COMPILAND-PLIST (SECOND ARG)) 'KEEP-CURRENT-FRAME) T)	; tested in PASS2
      )
    NEW-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 DO		P1DO P1)
(DEFPROP DO-NAMED	P1DO P1)
(DEFPROP DO*		P1DO P1)
(DEFPROP DO*-NAMED	P1DO 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:MAP	P1MAPX P1)
(DEFPROP MAPL		P1MAPX P1)
(DEFPROP MAPC		P1MAPX P1)
(DEFPROP MAPCAR		P1MAPX P1)
(DEFPROP MAPLIST	P1MAPX P1)
(DEFPROP MAPCAN		P1MAPX P1)
(DEFPROP MAPCON		P1MAPX 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.

;;;		Special forms used in CLOS - added to this file 3/15/89

(DEF SYS:NEXT-METHOD-LIST)
(DEFUN (:PROPERTY SYS:NEXT-METHOD-LIST P1) (FORM)
  ;;  5/05/88 DNG - Original.
  (LET ((VAR (LOOKUP-VAR '.NEXT-METHOD-LIST.)))
    (IF (NULL VAR)
	(PROGN (WARN (FIRST FORM) ':IMPOSSIBLE
		     "Call to ~S not within a method." (FIRST FORM))
	       '(QUOTE NIL))
      (PROGN (SETF (VAR-KIND VAR) 'FEF-ARG-KEY)	; prevent optimization from deleting this.
	     (P1 '.NEXT-METHOD-LIST.) ; to update use count
	     ))))

(DEF %LOCAL-SLOT)
(DEFPROP %LOCAL-SLOT (NUMBER) ARGLIST)
(SETF (DOCUMENTATION '%LOCAL-SLOT) "Return the value from the specified local variable slot.")
(DEFUN (:PROPERTY %LOCAL-SLOT P1) (FORM)
  ;;  5/05/88 DNG - Original.
  (VAR-LAP-ADDRESS (MAKE-MAP-HOME (GENSYM) (EVAL (SECOND FORM)))))

(def list-of-maps) ; used in SYS:ENCAPSULATE to obtain a list of the mapping tables.
(defun (:property list-of-maps p1) (ignore)
  ;; 12/21/88 DNG - Original.
  (let ((collection '()))
    (declare (list collection))
    (dolist (var vars)
      (when (and (eq (var-init-kind var) 'fef-ini-map)
		 (not (eq (var-name var) '.next-method-list.)))
	(push (var-lap-address var) collection)
	(var-increment-use-count var)))
    (cons 'list collection)))

(DEFUN (:PROPERTY SYS:%APPLY-METHOD P1) (FORM)
  ;;  5/10/88 DNG - Original.
  (LET ((RESULT (P1APPLY FORM)))
    (UNLESS (OR (ZEROP 1-IF-LIVE-CODE)
		(EQUAL (THIRD RESULT) '(QUOTE NIL)))
      ;; Tell PASS1-CLOS-FINISH that we need local mapping tables.
      (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'SYS:%APPLY-METHOD) T) )
    RESULT))

(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 RPLACD
		AS-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.
  ;;  7/06/87 DNG - Check for STRINGP instead of ARRAYP [since EQUAL is not
  ;;		better for arrays] and don't warn when the value came from
  ;;		a #. or #, instead of the source code.  [SPR 5527]
  ;;		Don't warn about using EQ for fixnums or characters in the
  ;;		cold load since code at that level is not portable anyway.
  (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)
			 (STRINGP VALUE)
			 (AND (EQ (FIRST FORM) 'EQ)
			      (NUMBERP VALUE)
			      (OR (AND COMPILING-COMMON-LISP
				       *WARN-OF-SUPERSEDED-FUNCTIONS-P*
				       (NOT SI:FILE-IN-COLD-LOAD))
				  (NOT (FIXNUMP VALUE))))
			 (AND (CHARACTERP VALUE)
			      (EQ (FIRST FORM) 'EQ)
			      COMPILING-COMMON-LISP
			      (NOT SI:FILE-IN-COLD-LOAD)))
		     (NOT INHIBIT-STYLE-WARNINGS-SWITCH)
		     (OR (NOT (SI:%POINTERP VALUE))
			 ;; See if the value was pulled from somewhere else using
			 ;; #. or #, instead of being part of the source code. [SPR 5527]
			 (LET ((AREA (SI:%AREA-NUMBER VALUE)))
			   (OR (EQL AREA QCOMPILE-TEMPORARY-AREA)
			       (EQL AREA SOURCE-CODE-AREA)))))
	    (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
		 SYS:COMPLEMENT ; 5/3/89
		 ))
    (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 DPB
		MAX 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 NTHCDR
		EQUAL EQUALP
		STRING-GREATERP STRING-LESSP STRING-NOT-EQUAL STRING-NOT-GREATERP
		STRING-NOT-LESSP STRING/= STRING< STRING<= STRING> STRING>=
		INTERNAL-GET-2 INTERNAL-GET-3 ; added 8/4/88 by DNG for FUNCTION-WITHOUT-SIDE-EFFECTS-P .
		LOCATE-IN-INSTANCE ; added 3/16/89 to recognize that this has no side-effects.
		;; the following added 4/27/89 by DNG
		SYS:%INSTANCE-REF TICLOS:FLAVOR-INSTANCE-ACCESS TICLOS:STANDARD-INSTANCE-ACCESS
		))
    (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-3
		CLI:AR-1 GLOBAL:AR-1 AR-2 AR-3 AREF GLOBAL:AREF
		ELT COMMON-LISP-ELT GLOBAL:ELT))
    (SETF (GET F 'P1) 'P1AREF)))