;;; -*- Mode:Common-Lisp; Package:COMPILER; Base:10; Patch-file:T -*-

;;; Reason: Update compiler to enable value propagation for variables initialized by SETQ.

;;;                           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, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 05/08/89 15:08:40 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Experimental REL6H 6.11, Experimental SYSTEM 6.0, Experimental VIRTUAL-MEMORY 6.0,
;;;  Experimental EH 6.0, Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0,
;;;  Experimental LOCAL-FILE 6.0, Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0,
;;;  Experimental BASIC-NAMESPACE 6.0, Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0,
;;;  Experimental DISK-LABEL 6.0, Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0,
;;;  Experimental NETWORK-PATHNAME 6.0, Experimental COMPILER 6.0, Experimental TV 6.0,
;;;  Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0, Experimental MEMORY-AUX 6.0,
;;;  Experimental NVRAM 6.0, Experimental SYSLOG 6.0, Experimental STREAMER-TAPE 6.0,
;;;  Experimental CLEH 1.0, Experimental UCL 6.0, Experimental INPUT-EDITOR 6.0, Experimental METER 6.0,
;;;  Experimental ZWEI 6.0, Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0,
;;;  Experimental NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0,
;;;  Experimental SERIAL 6.0, Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0,
;;;  Experimental PRINTER-TYPES 6.0, Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0,
;;;  Experimental MAIL-DAEMON 6.0, Experimental MAIL-READER 6.0, Experimental TELNET 6.0,
;;;  Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0, Experimental PROFILE 6.0,
;;;  VISIDOC 6.0, Experimental TI-CLOS 17.4, Experimental CLX 5.0, Experimental CLUE 20.0,
;;;  Experimental X11M 3.0, Experimental RPC 6.0, Experimental NFS 6.0, Experimental BUG 11.4,
;;;  IP 3.45, Experimental DOCUMENTER 618.0,  microcode 426, Band Name: Rel6H,Scribe,
;;; &c, u426 5/4


#!C
; From file P1DEFS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1DEFS.#"


(DEFVAR SETQ-PROPAGATE-ENABLE T "Enable propagation of variables initialized by a SETQ.") ; 5/7/89
))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1OPT.#"


(DEFUN SETQ-OPT (FORM)
  ;;  3/03/89 DNG - Add optimization to convert SETQ to initialization.  
  ;;		Currently, this is done only for the cases needed for optimizing the 
  ;;		macro expansion of (SETF (SLOT-VALUE ...)...).
  ;;  3/10/89 DNG - Fix to not trap when source argument is a special variable.
  ;;  5/03/89 DNG - Generalized conversion of SETQ to initialization.
  ;;  5/07/89 DNG - Check SETQ-PROPAGATE-ENABLE .
  (WHEN (NULL (REST FORM))			; (SETQ) ==> NIL
    (RETURN-FROM SETQ-OPT '(QUOTE NIL)))
  (DO ((PAIRS (REST FORM) (CDDR PAIRS)))
      ((NULL PAIRS) FORM)
    (WHEN (EQ (FIRST PAIRS) (SECOND PAIRS))	; setting a variable to itself
      (LET ((NEWFORM (CONS (FIRST FORM) (SETQ-OPT-1 (REST FORM)))))
	;; (SETQ ... a b x x y z ...) ==> (SETQ ... a b y z ...)
	(WHEN P1VALUE
	  ;; if the value of the SETQ form is going to be used, 
	  ;;  check whether the last assignment was deleted;
	  ;;  if so, construct a PROGN to hold the value.
	  (LOOP WHILE (CDDR PAIRS)
		DO (SETQ PAIRS (CDDR PAIRS)))
	  (WHEN (EQ (FIRST PAIRS) (SECOND PAIRS))
	    (SETQ NEWFORM (LIST 'PROGN (POST-OPTIMIZE NEWFORM) (FIRST PAIRS)))))
	(RETURN-FROM SETQ-OPT NEWFORM)))
    (WHEN (EQ (CAR-SAFE (FIRST PAIRS)) 'LOCAL-REF)	; assigning to a local variable
      (LET ((VAR (SECOND (FIRST PAIRS))) INIT-FORM)
	(IF (EQ (VAR-INIT-KIND VAR) 'FEF-INI-SETQ)
	    (WHEN (AND (EQL (VAR-KIND VAR) 'FEF-ARG-DELETED)
		       (NO-SIDE-EFFECTS-P (SECOND PAIRS))
		       (EQ PAIRS (CDR FORM)))
	      (DISCARD (SECOND PAIRS))
	      (RETURN-FROM SETQ-OPT `(SETQ . ,(CDDR PAIRS))))
	  (WHEN (AND (EQL (VAR-USE-COUNT VAR) 1)	; not used before this assignment
		     (EQ (VAR-KIND VAR) 'FEF-ARG-INTERNAL-AUX)
		     ;; Make sure we aren't in conditionally executed code.
		     (>= (CDDR (FIRST PAIRS)) *LOOP-VAR-BIT*)
		     (EQ (VAR-TYPE VAR) 'FEF-LOCAL)
		     (NO-SIDE-EFFECTS-P (SETQ INIT-FORM (VAR-INIT-FORM VAR)))
		     (OR SETQ-PROPAGATE-ENABLE ; new optimization enabled
			 ;; or simple case of gensym variables generated by SETQ
			 (AND (NULL (SYMBOL-PACKAGE (VAR-NAME VAR)))
			      (EQUAL INIT-FORM '(UNDEFINED-VALUE)))))
	    ;; What we have here is a local variable whose first reference is as the 
	    ;; destination of an unconditional SETQ.  This means that the initial 
	    ;; value in the binding will never be used and can be discarded, and that 
	    ;; we know what the initial value should be for purposes of value 
	    ;; propagation and type testing.
	    (UNLESS (NULL INIT-FORM) (DISCARD INIT-FORM))
	    (SETF (VAR-INIT VAR) (LIST 'FEF-INI-SETQ (SECOND PAIRS)))
	    (SETF (VAR-USE-COUNT VAR) 0)
	    (WHEN (EQ PAIRS (CDR FORM))
	      ;; Don't do this for other than the first assignment in the SETQ 
	      ;; because otherwise PROPAGATE-VALUES could mistakenly try to 
	      ;; substitute the destination.
	      (SETF ALTERED-VAR-SET (LOGDIF ALTERED-VAR-SET (CDDR (FIRST PAIRS))))
	      (MAYBE-PROPAGATE VAR))
	    (comment
	      ;; This is probably not needed; may not even be desirable.
	      ;; Leave it out to be safe.  -- DNG 4/28/89
	      (WHEN (AND (EQ PAIRS (CDR FORM))	; first assignment
			 (INVULNERABLE-EXPRESSION-P (SECOND PAIRS)))	; safe to move
		;; (LET ((g (UNDEFINED-VALUE))) ... (SETQ g x) ...)  ==>
		;; (LET ((g x)) ... ...)
		(SETF (VAR-INIT-KIND VAR) 'FEF-INI-COMP-C)
		(IF (CDDR PAIRS)
		    (PROGN (SETF (VAR-USE-COUNT VAR) 0)
			   (RETURN-FROM SETQ-OPT `(SETQ . ,(CDDR PAIRS))))
		  (RETURN-FROM SETQ-OPT (FIRST PAIRS))
		  ))))))))
  FORM)
))

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1HAND.#"


(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.
  (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))))
     (LOGDIF PROPAGATE-VAR-SET (- *LOOP-VAR-BIT* 1))
     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)) ) )
  )
))

#!C
; From file P2HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P2HAND.#"



;Bind a list of variables "in parallel":  compute all values, then bind them all.
;Return the number of special bindings made (BIND-POP and BIND-NIL instructions).
;Note: an attempt to bind NIL is ignored at this level.
;Note: if several variables have init forms of (%pop),
;they are popped off the pdl LAST ONE FIRST!
;The "correct" thing would be to pop the first one first,
;but this would require another stack to keep them on to reverse them.
(DEFUN P2-P-BIND (BOUNDVARS)
  ;;  8/23/85 - Set KEEP-CURRENT-FRAME flag when a special variable is bound.
  ;; 10/30/85 - Change instruction BINDNIL to BIND-NIL and BINDPOP to BIND-POP.
  ;; 12/07/85 - For release 3, FEF-ARG-AUX special variable is not bound on function entry.
  ;;  4/26/89 DNG - Original version of P2-P-BIND replaces P2PBIND.
  ;;  5/03/89 DNG - Add check for FEF-INI-SETQ.
  (IF (NULL BOUNDVARS)
      0
    (LET* ((PDLLVL PDLLVL)
	   (HOME (FIRST BOUNDVARS))
	   (VARNAME (VAR-NAME HOME))
	   (INITFORM (AND (NOT (EQ (VAR-INIT-KIND HOME) 'FEF-INI-SETQ))
			  (VAR-INIT-FORM HOME)))
	   NBINDS)
      (COND ((NULL VARNAME)
	     (DEBUG-ASSERT NIL NIL "binding NIL") ; don't think this is needed anymore. -- DNG 5/3/89
	     ;; If trying to bind NIL, just discard the value to bind it to.
	     (P2 INITFORM 'D-PDL)
	     (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS)))
	     (OUTF '(MOVE D-IGNORE PDL-POP)))
	    ;; If this variable's binding is fully taken care of by function entry,
	    ;; we have nothing to do here.
	    ((AND (NOT (MEMBER (VAR-KIND HOME) '(FEF-ARG-INTERNAL-AUX FEF-ARG-KEY) :TEST #'EQ))
		  (NOT (EQ (VAR-INIT-KIND HOME) 'FEF-INI-COMP-C)))
	     (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS))))
	    ;; Detect and handle internal special bound variables.
	    ((EQ (VAR-TYPE HOME) 'FEF-SPECIAL)
	     (COND ((OR (EQ INITFORM 'NIL)
			(EQUAL INITFORM '(QUOTE NIL)))
		    (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS)))
		    (OUTIV 'BIND-NIL HOME))
		   (T (P2PUSH INITFORM)
		      (INCPDLLVL)
		      (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS)))
		      (OUTIV 'BIND-POP HOME)))
	     (SETQ KEEP-CURRENT-FRAME T)
	     (INCF NBINDS))
	    ((OR (EQUAL INITFORM '(UNDEFINED-VALUE))
		 #+compiler:debug		;temporary while COMPILER2 package is used
		 (EQUAL INITFORM '(COMPILER:UNDEFINED-VALUE)))
	     (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS))))
	    ((OR (EQ INITFORM 'NIL)
		 (EQUAL INITFORM '(QUOTE NIL)))
	     (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS)))
	     (WHEN (OR TAGOUT (VAR-OVERLAP-VAR HOME))
	       (OUTIV 'SET-NIL HOME)))
	    (T (P2PUSH INITFORM)
	       (INCPDLLVL)
	       (SETQ NBINDS (P2-P-BIND (REST BOUNDVARS)))
	       (OUTIV 'POP HOME)))
      NBINDS)))

))

#!C
; From file P2HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P2HAND.#"


(DEFUN P2SETQ-1 (VAR VALUE DEST)
  ;; 12/26/84 DNG - Modified to use P2-DESTINATION instead of P2-SOURCE.
  ;;  7/10/85 DNG - Use 'SETE property for release 3.
  ;;  8/24/85 DNG - Use SET-T instruction.
  ;;  8/25/88 clm - Handle local variables moved to lexical environment by EXTEND-LOCAL-VARIABLES .
  ;;  5/03/89 DNG - Add handling for FEF-INI-SETQ.
  (LET (INSTR)
    (COND ((MEMBER VAR '(NIL T) :TEST #'EQ) NIL)
	  ((AND (EQ (CAR-SAFE VAR) 'LOCAL-REF)
		(EQ (VAR-KIND (SECOND VAR)) 'FEF-ARG-DELETED))
	   ;; SETQ-OPT decided that this SETQ was going to assign the initial value 
	   ;; of the variable, but %LET-OPT decided later that the variable wasn't 
	   ;; needed at all.  So just evaluate the value expression without storing 
	   ;; it anywhere.
	   (DEBUG-ASSERT (EQ (VAR-INIT-KIND (SECOND VAR)) 'FEF-INI-SETQ))
	   (UNLESS (AND (EQ DEST 'D-IGNORE)
			(NO-SIDE-EFFECTS-P VALUE))
	     (P2 VALUE DEST)))
	  ((AND (CONSP VAR)
		(or (EQ (CAR VAR) 'LEXICAL-REF)
		    (and (eq (car var) 'local-ref)
			 (eq (car (var-lap-address (second var))) 'lexical-ref)
			 (atom (lex-ref-address (var-lap-address (second var)))))))
	   (P2PUSH VALUE)
	   (MOVEM-AND-MOVE-TO-DEST VAR DEST))
	  ((MEMBER VALUE '('0 (QUOTE NIL)) :TEST #'EQUAL)
	   (OUTI
	     `(,(CDR (ASSOC (CADR VALUE)
			    '((0 . SET-ZERO) (NIL . SET-NIL)) :TEST #'EQ))
	       0
	       ,(P2-DESTINATION VAR)))
	   (UNLESS (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ)
	     (P2 VALUE DEST)))
	  ((AND (EQUAL VALUE ''T)
		(INSTRUCTION-EXISTS-P 'SET-T))
	   (OUTI `(SET-T 0 ,(P2-DESTINATION VAR)))
	   (UNLESS (MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ)
	     (P2 VALUE DEST)))
	  ((AND (NOT (ATOM VALUE))
		(CDR VALUE)
		(EQUAL (CADR VALUE) VAR)
		(SETQ INSTR (GET-FOR-TARGET (CAR VALUE) 'SETE))
		(MEMBER DEST '(D-IGNORE D-INDS) :TEST #'EQ))
	   (OUTI `(,INSTR D-INDS ,(P2-DESTINATION VAR))))
	  (T (P2PUSH VALUE)
	     (MOVEM-AND-MOVE-TO-DEST VAR DEST))))
  NIL)
))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1OPT.#"


(DEFUN PROPAGATE-VALUES (FORM)
  ;; FORM is an S-expression which has already been processed by P1.
  ;; Scans the expression looking for local variable references
  ;;  which can be replaced by the variable's initial value,
  ;;  making the substitution in place.  Also re-optimizes any
  ;;  forms whose arguments have been changed.
  ;; 1/25/85 - Original version.
  ;; 2/29/85 - Allow for some more special forms.
  ;; 3/04/85 - Do constant folding on *PLUS etc.
  ;; 3/23/85 - Fix replacement of initial value of variable.
  ;; 9/28/85 - Recognize special form VARIABLE-LOCATION.
  ;; 1/07/86 - Special handling for PROG1.
  ;; 5/05/86 - Check (CONSP NEW-FORM) before doing (FIRST NEW-FORM) [SPR 1827];
  ;;	       eliminate obsolete reference to P2NODEST.
  ;; 7/03/86 - Add handling for LEXICAL-CLOSURE.
  ;; 8/14/86 - No longer need special handling for *PLUS, etc.
  ;; 9/09/86 - Increment use count of propagated BREAKOFF-FUNCTION.
  ;; 9/19/86 - Allow propagating BREAKOFF-FUNCTION; add use of
  ;;		DONT-PROPAGATE-INTO-LOOP; mark compilands that have only one use.
  ;;10/18/86 - Don't need to bind GOTAGS anymore.
  ;;11/04/86 - Fix to handle MULTIPLE-VALUE-PUSH correctly.
  ;; 6/18/87 - Fix updating of PROPAGATE-VAR-SET for SPR 4977, and
  ;;		don't process arguments of UNSHARE-STACK-CLOSURE-VARS.
  ;; 4/24/89 - Add recognition of %LOAD-TIME-VALUE .
  ;; 4/26/89 - Add support for %LET and %LET*.
  ;; 5/03/89 - Be careful to not change the destination of a SETQ.
  (DECLARE (VALUES NEW-FORM ANY-TOP-LEVEL-CHANGES?))
  (DECLARE (INLINE TRIVIAL-FORM-P))
  (IF (OR (ATOM FORM)
	  (NOT (DEBUG-ASSERT (SYMBOLP (FIRST FORM)))))
      (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL))
    (LET ((CHANGED NIL))
      (IF (EQ (FIRST FORM) 'THE-EXPR)
	  (PROGN
	    (LET ((USED-VAR-SET (EXPR-USED FORM))
		  (ALTERED-VAR-SET (EXPR-ALTERED FORM))
		  (PROPAGATE-VAR-SET PROPAGATE-VAR-SET)
		  (OPTIMIZE-SWITCH (EXPR-OPTIMIZE FORM)))
	      (SETF (EXPR-FORM FORM) (PROPAGATE-VALUES (EXPR-FORM FORM)))
	      (SETF (EXPR-USED FORM) USED-VAR-SET))
	    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (EXPR-USED FORM)))
	    (SETQ CHANGED T))
	(LET (ARG-LIST
	      (CLAUSE-LIST NIL)
	      (P1VALUE P1VALUE)
	      (P1VALUE-FIRST T)
	      (P1VALUE-LAST T)
	      (P1VALUE-MIDDLE T)
	      (BIND-VARS NIL)
	      (BIND-VALS NIL))
	  (SETQ ARG-LIST
		(COND
		  ((MEMBER (FIRST FORM) '(%LET %LET*) :TEST #'EQ)
		   ;; (%LET ( bound-vars new-vars outer-vars bindp closuresp ) . body)
		   (LET ((VARS (SECOND (SECOND FORM))))
		     (SETQ BIND-VARS '(VARS)
			   BIND-VALS (LIST VARS))
		     (DOLIST (V (FIRST (SECOND FORM)))   ; each variable in lambda list
		       (LET ((LAPA (VAR-LAP-ADDRESS V)))
			 (UNLESS
			   (OR (WHEN (EQ (VAR-INIT-KIND V) 'FEF-INI-COMP-C)
				 (MULTIPLE-VALUE-BIND (NEW-INIT CHANGED-INIT)
				     (PROPAGATE-VALUES (VAR-INIT-FORM V))
				   (WHEN CHANGED-INIT
				     (SETF (VAR-INIT-FORM V) NEW-INIT)
				     (SETQ CHANGED T)
				     (WHEN (AND (EQ (VAR-KIND V) 'FEF-ARG-INTERNAL-AUX)
						(EQ (VAR-TYPE V) 'FEF-LOCAL)
						(CONSP NEW-INIT)
						(MEMBER (FIRST NEW-INIT)
							'(QUOTE LOCAL-REF FUNCTION BREAKOFF-FUNCTION)
							:TEST #'EQ)
						(NOT (LOGTEST (CDDR LAPA) ALTERED-VAR-SET))
						(NOT (AND (EQ (FIRST NEW-INIT) 'LOCAL-REF)
							  (LOGTEST (CDDR NEW-INIT)
								   ALTERED-VAR-SET))))
				       (SETQ PROPAGATE-VAR-SET
					     (LOGIOR PROPAGATE-VAR-SET (CDDR LAPA)))))))
			       (NOT (EQ (CAR-SAFE LAPA) 'LOCAL-REF))
			       (LOGTEST (CDDR LAPA) DONT-PROPAGATE-INTO-LOOP))
			   ;; Kludge for SPR 4977 - make sure that PROPAGATE-VAR-SET doesn't
			   ;; have the bit set for a different variable that happens to have
			   ;; the same bit mask.  This can happen when a LET is wrapped around
			   ;; a form that has already been processed by P1, as in
			   ;; FIX-FUNCALL-EVALUATION-ORDER for example.
			   (SETQ PROPAGATE-VAR-SET
				 (LOGDIF PROPAGATE-VAR-SET (CDDR LAPA)))
			   ))))
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST P1VALUE)
		   (NTHCDR 2 FORM))
		  ((ZEROP (LOGAND PROPAGATE-VAR-SET USED-VAR-SET))
		   ;; There aren't any variables eligible for substitution, so quit.
		   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
		  ((EQ (FIRST FORM) 'PROGN)
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST P1VALUE) (REST FORM))
		  ((MEMBER (FIRST FORM) '(BLOCK BLOCK-FOR-PROG
					   BLOCK-FOR-WITH-STACK-LIST)
			   :TEST #'EQ)
		   ;;(SETQ BIND-VARS '(GOTAGS)
		   ;;	   BIND-VALS (LIST (APPEND (SECOND FORM) GOTAGS)))
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST P1VALUE) (CDDDR FORM))
		  ((EQ (FIRST FORM) 'MULTIPLE-VALUE-BIND)
		   (NTHCDR 4 FORM))
		  ((MEMBER (FIRST FORM)
			   '(PROGN-WITH-DECLARATIONS RETURN-FROM MULTIPLE-VALUE
			     MULTIPLE-VALUE-PUSH MULTIPLE-VALUE-SETQ CLOSURE GO
			     SETQ INTERNAL-PSETQ)
			   :TEST #'EQ)
		   (CDDR FORM))
		  ((EQ (FIRST FORM) 'COND)
		   (SETQ CLAUSE-LIST (REST FORM))
		   (SETQ P1VALUE-FIRST 'D-INDS
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST P1VALUE) NIL)
		  ((MEMBER (FIRST FORM) '(AND OR) :TEST #'EQ)
		   (WHEN (OR (NULL P1VALUE) (EQ P1VALUE 'D-INDS))
		     (SETQ P1VALUE-FIRST 'D-INDS
			   P1VALUE-MIDDLE 'D-INDS))
		   (SETQ P1VALUE-LAST P1VALUE) (REST FORM))
		  ((EQ (FIRST FORM) 'TAGBODY)
		   ;;(SETQ BIND-VARS '(GOTAGS)
		   ;;      BIND-VALS (LIST (APPEND (SECOND FORM) GOTAGS)))
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST NIL)
		   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET
						   DONT-PROPAGATE-INTO-LOOP))
		   (CDDR FORM))
		  ((EQ (FIRST FORM) '%DOLIST)
		   (SETQ P1VALUE-FIRST NIL
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST NIL)
		   (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET
						   DONT-PROPAGATE-INTO-LOOP))
		   (CDDR FORM))
		  ((EQ (FIRST FORM) 'LOCAL-REF) (LIST FORM))
		  ((TRIVIAL-FORM-P FORM)
		   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
		  ((MEMBER (FIRST FORM) '( VARIABLE-LOCATION UNSHARE-STACK-CLOSURE-VARS 
					  %LOAD-TIME-VALUE) :TEST #'EQ)
		   ;; special form with no evaluated arguments
		   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
		  ((MEMBER (FIRST FORM) '(PROG1 MULTIPLE-VALUE-PROG1)
			   :TEST #'EQ)
		   (SETQ P1VALUE-FIRST P1VALUE
			 P1VALUE-MIDDLE NIL
			 P1VALUE-LAST NIL) (REST FORM))
		  ((EQ (FIRST FORM) 'LEXICAL-CLOSURE)
		   #|
		   (LET* ((COMPILAND (SECOND FORM))
			  (USED-VAR-SET (COMPILAND-USED-VAR-SET COMPILAND))
			  (ALTERED-VAR-SET (COMPILAND-ALTERED-VAR-SET COMPILAND))
			  (PROPAGATE-VAR-SET PROPAGATE-VAR-SET)
			  (OPTIMIZE-SWITCH (COMPILAND-OPTIMIZE COMPILAND)))
		     (SETF (COMPILAND-EXP2 COMPILAND)
			   (PROPAGATE-VALUES (COMPILAND-EXP2 COMPILAND)))
		     (SETF (COMPILAND-USED-VAR-SET COMPILAND) USED-VAR-SET))
		    |#
		   (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
		  ((DEBUG-ASSERT
		     (OR (NOT (QUOTES-ANY-ARGS (FIRST FORM)))
			 (MEMBER (FIRST FORM)
				 '(SETQ INTERNAL-PSETQ SET-AR-1
					UNWIND-PROTECT *CATCH CATCH) :TEST #'EQ)))
		   (REST FORM))
		  (T (RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL))) ))
	  (PROGV BIND-VARS BIND-VALS
	    (DO ((FORM-LIST (OR ARG-LIST (POP CLAUSE-LIST)) (POP CLAUSE-LIST)))
		((AND (NULL FORM-LIST)
		      (NULL CLAUSE-LIST)))
	      (LOOP FOR ARGS ON FORM-LIST DO
		    (LET ((ARG (FIRST ARGS)))
		      (COND
			((ATOM ARG))
			((EQ (FIRST ARG) 'LOCAL-REF)
			 (WHEN (LOGTEST (CDDR ARG) PROPAGATE-VAR-SET)
			   (LET* ((V (SECOND ARG))
				  (NEW (OR (VAR-INIT-FORM V) '(QUOTE NIL))))
			     (SETQ CHANGED T)
			     (DECF (VAR-USE-COUNT V))
			     (DEBUG-ASSERT (>= (VAR-USE-COUNT V) 0)
					   ((VAR-USE-COUNT V) USED-VAR-SET)
					   "Negative var use count")
			     (WHEN (ZEROP (VAR-USE-COUNT V))	   ; no more uses
			       (SETQ USED-VAR-SET (LOGDIF USED-VAR-SET (CDDR ARG)))
			       (SETQ ALTERED-VAR-SET
				     (LOGDIF ALTERED-VAR-SET (CDDR ARG))))
			     (COND ((ATOM NEW))
				   ((EQ (CAR NEW) 'LOCAL-REF)
				    (INCF (VAR-USE-COUNT (SECOND NEW)))
				    (SETQ USED-VAR-SET (LOGIOR USED-VAR-SET (CDDR NEW))))
				   ((MEMBER (CAR NEW) '(BREAKOFF-FUNCTION LEXICAL-CLOSURE))
				    (WHEN (AND (= (VAR-USE-COUNT V) 0)
					       (= (COMPILAND-USE-COUNT (SECOND NEW)) 1))
				      ;; flag for PROCEDURE-INTEGRATION
				      (SETF (GETF (COMPILAND-PLIST (SECOND NEW))
						  'USED-ONLY-ONCE)
					    T))
				    (INCF (COMPILAND-USE-COUNT (SECOND NEW))))
				   ((TRIVIAL-FORM-P NEW))
				   ((DEBUG-ASSERT (ZEROP (VAR-USE-COUNT V)))
				    ;; rather than scanning the expression incrementing
				    ;; the use counts for everything it references, just
				    ;; delete the original expression.
				    (SETF (VAR-INIT-FORM V) 'DELETED-VALUE)))
			     (IF (EQ ARG FORM)
				 (RETURN-FROM PROPAGATE-VALUES (VALUES NEW T))
			       (SETF (FIRST ARGS) NEW)))))
			((TRIVIAL-FORM-P ARG))
			(T
			 (SETQ P1VALUE
			       (COND ((NULL (REST ARGS)) P1VALUE-LAST)
				     ((EQ ARGS FORM-LIST) P1VALUE-FIRST)
				     (T P1VALUE-MIDDLE)))
			 (MULTIPLE-VALUE-BIND (NEW-ARG WAS-CHANGED)
			     (PROPAGATE-VALUES ARG)
			   (WHEN WAS-CHANGED
			     (SETF (FIRST ARGS) NEW-ARG)
			     (SETQ CHANGED T)))))))	   ; end of LOOP
	      )	   ; end of DO
	    )	   ; end of PROGV
	  )	   ; end of LET on ARG-LIST and P1VALUE
	)	   ; end of IF THE-EXPR
      (IF CHANGED
	  (LET ((NEW-FORM (POST-OPTIMIZE FORM)))
	    (RETURN-FROM PROPAGATE-VALUES (VALUES NEW-FORM (NEQ NEW-FORM FORM))))
	(RETURN-FROM PROPAGATE-VALUES (VALUES FORM NIL)))
      )	; end of LET CHANGED
    )	; end of IF ATOM
  )
))

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1FUNS.#"


(DEFUN P1-LET-FOR-P-I ( FORM )
  ;; The code that follows has been adapted from the handler
  ;;  for LET-FOR-LAMBDA; it differs from an internal lambda in that
  ;;  the lexical environment is not inherited within the body.
  ;; 1/26/85 - Separated from PROCEDURE-INTEGRATION to facilitate use of P1-WITH-ANNOTATION.
  ;; 6/21/86 - Bind *LOCAL-ENVIRONMENT* instead of LOCAL-MACROS.
  ;; 7/07/86 - Include old VARS in result form instead of declarations.
  ;; 7/10/86 - To allow integrating local functions, move the binding of
  ;;		LOCAL-DECLARATIONS to PROCEDURE-INTEGRATION and use *P-I-VARS* to
  ;;		initialize VARS.
  ;; 9/16/86 - Add call to VARIABLE-WRAPUP.
  ;; 9/20/86 - Move the binding of INHIBIT-STYLE-WARNINGS-SWITCH to include the call to VARIABLE-WRAPUP.
  ;; 12/15/86 DNG - Add use of DYNAMIC-BINDING-HACK.
  ;;  4/26/89 DNG - Generate %LET form.
  ;;  5/03/89 DNG - Make sure VAR-BIT doesn't overlap the variables visible to 
  ;;		the closure.  Make sure the bits in PROPAGATE-VAR-SET don't refer to 
  ;;		different variables in an internal function.
  ;;  5/04/89 DNG - Bind *LOCAL-ENVIRONMENT* to *COMPILE-FILE-ENVIRONMENT* instead of NIL.
  (LET ((VARS VARS) (OLD-VARS VARS) NEW-VARS OLD-VAR-BIT
	(BINDP) (BODY) (VLIST)
	(INLINE-DECLARATIONS INLINE-DECLARATIONS)
	(LOCAL-DECLARATIONS NIL)		; NIL to prevent inheritance in FIND-TYPE
	(THIS-FRAME-DECLARATIONS NIL)
	(ENTRY-LEXICAL-CLOSURE-COUNT LEXICAL-CLOSURE-COUNT)
	(INHIBIT-STYLE-WARNINGS-SWITCH T)
	)
    (DECLARE (SPECIAL *P-I-COMPILAND*)) ; bound in PROCEDURE-INTEGRATION
    (UNLESS (NULL *P-I-COMPILAND*)
      (LOOP UNTIL (AND (> VAR-BIT PROPAGATE-VAR-SET)
		       (> VAR-BIT (COMPILAND-USED-VAR-SET *P-I-COMPILAND*)))
	    DO (SETQ VAR-BIT (* VAR-BIT 2))))
    (SETQ OLD-VAR-BIT VAR-BIT)
    ;; Take all DECLAREs off the body.
    (SETF (VALUES BODY THIS-FRAME-DECLARATIONS)
	  (EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR FORM) NIL))
    
    ;; Bind the arguments
    
    (SETQ VLIST (P1SBIND (CADR FORM)
			 'FEF-ARG-INTERNAL-AUX
			 'DONT-P1 NIL THIS-FRAME-DECLARATIONS))
    (SETQ NEW-VARS VARS)
    
    ;; Now P1 process the body, in a context that
    ;;  does not allow any lexical inheritance from the calling function.
    (LET* (( HIDDEN-ACTIVE-VARS (CONS OLD-VARS HIDDEN-ACTIVE-VARS) )
	   ( VARS (LOOP FOR V ON VARS
			UNTIL (EQ V OLD-VARS)	; keep just the local args
			COLLECT (FIRST V) ) )
	   ( OUTER-GOTAGS GOTAGS )
	   ( GOTAGS NIL )
	   ( PROGDESCS NIL )
	   ( RETPROGDESC NIL )
	   ( LOCAL-FUNCTIONS NIL )
	   ( *LOCAL-ENVIRONMENT* *COMPILE-FILE-ENVIRONMENT* )
	   )
      (IF (NULL *P-I-COMPILAND*)
	  ;; allow propagating the arguments, but nothing before that.
	  (%BIND (LOCF PROPAGATE-VAR-SET) (LOGDIF PROPAGATE-VAR-SET (- OLD-VAR-BIT 1)))
	(PROGN
	  (MAP-VARIABLES-IN-SET
	    #'(LAMBDA (V BIT)
		(UNLESS (MEMBER V (COMPILAND-INHERITED-VARS *P-I-COMPILAND*) :TEST #'EQ)
		  ;; This bit refers to a different variable in the two contexts.
		  (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET BIT))))
	    (LOGAND PROPAGATE-VAR-SET (LOGIOR (COMPILAND-USED-VAR-SET *P-I-COMPILAND*)
					      (COMPILAND-ALTERED-VAR-SET *P-I-COMPILAND*)))
	    OLD-VARS)
	  (SETQ VARS (NCONC VARS (COMPILAND-INHERITED-VARS *P-I-COMPILAND*)))
	  (SETQ GOTAGS	(COMPILAND-INHERITED-GOTAGS *P-I-COMPILAND*)
		PROGDESCS (COMPILAND-INHERITED-PROGDESCS *P-I-COMPILAND*)
		RETPROGDESC (COMPILAND-INHERITED-RETPROGDESC *P-I-COMPILAND*)
		LOCAL-DECLARATIONS (COMPILAND-DECLARATIONS *P-I-COMPILAND*)
		LOCAL-FUNCTIONS (COMPILAND-INHERITED-LOCAL-FUNCTIONS *P-I-COMPILAND*)
		*LOCAL-ENVIRONMENT* (COMPILAND-INHERITED-LOCAL-MACROS *P-I-COMPILAND*)) ))
      (UNLESS (NULL SELF-FLAVOR-DECLARATION)
	(LET (( TEM (LOOKUP-VAR 'SI:.DAEMON-MAPPING-TABLE. OLD-VARS) ))
	  (UNLESS (NULL TEM)
	    ;; In a combined flavor method, this magic variable which
	    ;;  holds the current mapping table needs to be kept visible.
	    (PUSH TEM VARS) ) ) )
      (DOLIST ( P (REST P1VALUE) )
	;; keep tags that may be needed for tail recursion elimination
	(PUSH (ASSOC (SECOND P) OUTER-GOTAGS :TEST #'EQ)
	      GOTAGS) )
      (SETQ LOCAL-DECLARATIONS
	    (PROCESS-PERVASIVE-DECLARATIONS THIS-FRAME-DECLARATIONS))
      (SETQ BODY (P1PROGN-1 BODY))		; process the body
      )						; end of LET*
    (VARIABLE-WRAPUP NEW-VARS OLD-VARS)
    ;; expansion has been successfully completed.
    (DYNAMIC-BINDING-HACK BINDP VLIST)
    `(%LET (,(MAPCAR #'(LAMBDA (X)
			    (LOOKUP-VAR (IF (CONSP X) (CAR X) X)))
		       VLIST)
	     ,NEW-VARS ,OLD-VARS ,BINDP ,(> LEXICAL-CLOSURE-COUNT ENTRY-LEXICAL-CLOSURE-COUNT))
	. ,BODY)
    ) )
))

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1HAND.#"


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

#!C
; From file P2HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P2HAND.#"


(DEFUN (:PROPERTY MULTIPLE-VALUE-BIND P2) (TAIL DEST)
  ;; 01/14/86 DNG - Move the binding of PDLLVL so that it is restored
  ;;                after the call to P2PBIND.  This is so that a RETURN out of
  ;;                the body won't pop values that have already been %POPped.
  ;;  1/22/86 DNG - Fix to unbind special variables.
  ;;  8/19/86 DNG - Use PUSH-NILS instead of a DO loop generating MOVEs.
  ;;  5/03/89 DNG - Modified to use P2SB1 instead of P2PBIND.
  (LET ((BOUNDVARS (CAR TAIL))
	(NBINDS 0))
    (LET ((PDLLVL PDLLVL)
	  (MVTARGET (LENGTH BOUNDVARS))
	  (VARS (SECOND TAIL))
	  (MVFORM (FOURTH TAIL)))
      ;; Compile the form to leave N things on the stack.
      ;; If it fails to do so, then it left only one, so push the other N-1.
      (MKPDLLVL (+ PDLLVL MVTARGET))
      (AND (P2MV MVFORM 'D-PDL MVTARGET)
	   (PUSH-NILS (- MVTARGET 1)))
      ;; Now pop them off, binding the variables to them.
      ;; Note that the vlist contains the variables
      ;; in the original order,
      ;; each with an initialization of (%POP).
      (DOLIST (HOME (REVERSE BOUNDVARS))
	(IF (OR (NULL HOME)
		(NOT (DEBUG-ASSERT (NEQ (VAR-KIND HOME) 'FEF-ARG-DELETED)))
		(NOT (DEBUG-ASSERT (NEQ (VAR-INIT-KIND HOME) 'FEF-INI-SETQ))))
	    (OUT-AUX 'POP-PDL 1) ; just pop the value off
	  (WHEN (P2SB1 HOME) ; assign it to the variable
	    (INCF NBINDS)))))
    (LET ((VARS (THIRD TAIL))
	  (BODY (CDDDDR TAIL))
	  (PROGDESCS PROGDESCS))
      (UNLESS (ZEROP NBINDS)
	;; Push a dummy progdesc so that GOs exiting this form can unbind our specials.
	(PUSH (MAKE-PROGDESC NAME '(LET)
			     PDL-LEVEL PDLLVL
			     NBINDS NBINDS)
	      PROGDESCS))
      (P2PROG12N (LENGTH BODY) DEST BODY))
    (UNBIND DEST NBINDS)))
))

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1HAND.#"


(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))))

))

#!C
; From file P1OPT.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1OPT.#"


(ADD-POST-OPTIMIZER MULTIPLE-VALUE-BIND MULTIPLE-VALUE-BIND-OPT)
;; (MULTIPLE-VALUE-BIND boundvars outer-vars new-vars m-v-returning-form . body)
;;	     1		   2	       3	4	   5		    6...
(DEFUN MULTIPLE-VALUE-BIND-OPT (FORM)
  ;;  5/03/89 DNG - Original.
  (WHEN (AND SETQ-PROPAGATE-ENABLE
	     (>= (OPT-SPEED-OR-SPACE OPTIMIZE-SWITCH)
		 (OPT-DEBUG OPTIMIZE-SWITCH)))
    (DO ((VS (SECOND FORM) (CDR VS)))
	((NULL VS))
      (LET ((V (FIRST VS)))
	(UNLESS (NULL V)
	  (WHEN (AND (MEMBER (VAR-USE-COUNT V) '(0 NIL))	; not used
		     (EQ (VAR-KIND V) 'FEF-ARG-INTERNAL-AUX)
		     (EQ (VAR-TYPE V) 'FEF-LOCAL))
	    ;; Delete the variable.
	    (SETF (VAR-KIND V) 'FEF-ARG-DELETED)
	    (SETF (FIRST VS) NIL)
	    )))))
  FORM)
))

#!C
; From file P1HAND.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1HAND.#"


(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))))))))))
))

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1FUNS.#"


(DEFUN VAR-COMPUTE-INIT (HOME PARALLEL)
  (DECLARE (OPTIMIZE (SPEED 2)) (INLINE ADRREFP P1V))
  ;; 12/07/85 - Simplified for release 3 -- no more ADL.
  ;;  1/06/86 - Fix binding of special variable to (UNDEFINED-VALUE).
  ;;  6/02/86 - Report error on &REST arg with default value.
  ;;  7/02/86 - Allow BREAKOFF-FUNCTIONs to be value-propagated.
  ;;  7/30/86 - Fix to always call P1 for initial value so EXPRESSION-SIZE is incremented.
  ;;  2/04/87 DNG - Check for discrepency between declared type and initial value.
  ;; 11/11/87 DNG - Fix SPR 6881 by not propagating lexical variables altered in closures.
  ;;  8/04/88 DNG - Call P1 with P1VALUE bound to 'SINGLE-VALUE instead of 
  ;;		using P1V.  Remove obsolete VM1 code.
  ;;  4/22/89 DNG - When in Scheme mode, it is not safe to propagate FUNCTION 
  ;;		forms since they could really be global Scheme variables.
  ;;  4/28/89 DNG - Use new functions MAYBE-PROPAGATE and VAR-DECLARED-TYPE .
  ;;  5/03/89 DNG - Add option for run-time type checking.
  ;;  5/06/89 DNG - Add binding of *OVERLAP-CANDIDATES*.
  (LET* ( INIT-TYPE
	 ( INIT-DATA NIL )
	 ( NAME (VAR-NAME HOME) )
	 ( KIND (VAR-KIND HOME) )
	 ( TYPE (VAR-TYPE HOME) )
	 ( INIT-SPECS (VAR-INIT HOME) )
	 ( INIT-FORM (CAR INIT-SPECS) )
	 ( SPECIFIED-FLAG-NAME (CADR INIT-SPECS) )
	 ( SAVE-ALLVARS ALLVARS ))
    (DECLARE (TYPE SYMBOL NAME KIND TYPE))
	(COND ((OR (EQ KIND 'FEF-ARG-REQ)
		   (EQ KIND 'FEF-ARG-REST))
	       (UNLESS (NULL INIT-FORM)
		 (WARN 'BAD-ARGUMENT-LIST ':IMPOSSIBLE
		       "The ~A argument ~S was given a default value."
		       (IF (EQ KIND 'FEF-ARG-REQ) "required" "&REST")
		       NAME) )
	       (SETQ INIT-TYPE 'FEF-INI-NONE) )
	      ((NULL INIT-FORM)
	       (SETQ INIT-TYPE (IF (EQ KIND 'FEF-ARG-OPT)
				   'FEF-INI-NIL
				 'FEF-INI-COMP-C)))
	      ((OR (EQUAL INIT-FORM '(UNDEFINED-VALUE))
		   #+compiler:debug	   ; temporary while COMPILER2 package is used.
		   (EQUAL INIT-FORM '(COMPILER:UNDEFINED-VALUE)) )
	       (IF (EQ TYPE 'FEF-LOCAL)
		   (SETQ INIT-TYPE 'FEF-INI-NONE)
		 (SETQ INIT-FORM NIL
		       INIT-TYPE 'FEF-INI-COMP-C) ) )
	      (T (UNLESS (EQ PARALLEL 'DONT-P1)	   ; unless P1 was already applied
		   (LET ((TLEVEL NIL))
		     (SETQ INIT-FORM (LET ((P1VALUE 'SINGLE-VALUE))
				       (P1 INIT-FORM)))) )
		 (IF (AND (EQUAL INIT-FORM '(QUOTE NIL))
			  (EQ KIND 'FEF-ARG-OPT))
		     (SETQ INIT-TYPE 'FEF-INI-NIL)
		   (SETQ INIT-TYPE 'FEF-INI-COMP-C) )
		 (SETQ INIT-DATA INIT-FORM) ) )
    (UNLESS (EQ KIND 'FEF-ARG-OPT)
      ;; If something not an optional arg was given a specified-flag,
      ;; discard that flag now.  There has already been an error message.
      (SETQ SPECIFIED-FLAG-NAME NIL) )
    (WHEN (AND (EQ INIT-TYPE 'FEF-INI-COMP-C)
	       (VALIDATE-TYPES-P))
      (LET ((TYPE (VAR-DECLARED-TYPE HOME)))
	(UNLESS (EQ TYPE 'T)
	  ;; Generate code to check that the initial value conforms to the type declaration.
	  (SETQ INIT-DATA
		(LET-IF (NOT (EQ PARALLEL 'DONT-P1))
			(( *OVERLAP-CANDIDATES* SAVE-ALLVARS ))
		  (P1V `(LET-FOR-LAMBDA ((.VALUE. ,(MARK-P1-DONE INIT-DATA)))
			  (DECLARE (OPTIMIZE (SAFETY 0) (SPACE 2) (SPEED 1)))
			  (IF (TYPEP .VALUE. ',TYPE)
			      .VALUE.
			    (ASSIGNMENT-TYPE-ERROR .VALUE. ',NAME ',TYPE))))))
	  (SETQ INIT-FORM INIT-DATA)
	  )))
    (SETF (VAR-INIT HOME)
	  (LIST* INIT-TYPE INIT-DATA
		 (AND SPECIFIED-FLAG-NAME
		      (DOLIST (V ALLVARS)
			(AND (EQ (VAR-NAME V) SPECIFIED-FLAG-NAME)
			     (MEMBER 'FEF-ARG-SPECIFIED-FLAG (VAR-MISC V))
			     (RETURN V))))))
    (WHEN (AND (EQ KIND 'FEF-ARG-INTERNAL-AUX)
	       (EQ TYPE 'FEF-LOCAL)
	       (OR (< (OPT-SAFETY OPTIMIZE-SWITCH) 2)
		   (EQ NAME '.VALUE.)) ; used in type checking
	       (EQ INIT-FORM INIT-DATA))
      (MAYBE-PROPAGATE HOME))
    (UNLESS (EQ KIND 'FEF-ARG-REQ)
      (BLOCK CHECK-DECLARATION
	(LET ((DECLARED-TYPE (VAR-DATA-TYPE HOME)))
	  (DECLARE (NOTINLINE VAR-DECLARED-TYPE))
	  (IF (OR (EQ DECLARED-TYPE 'T)
		  (NOT (TYPE-SPECIFIER-P DECLARED-TYPE *COMPILE-FILE-ENVIRONMENT*)))
	      (RETURN-FROM CHECK-DECLARATION)
	    (IF (OR (NULL INIT-FORM) (QUOTEP INIT-FORM))
		;; Note that TYPEP can only be used with the canonicalized type (not the 
		;; original source type) because it doesn't look in the compile-time environment.
		(IF (TYPEP (SECOND INIT-FORM) DECLARED-TYPE)
		    (RETURN-FROM CHECK-DECLARATION)
		  (WARN 'SI:DISJOINT-TYPEP ':IMPOSSIBLE
			"(DECLARE (TYPE ~S ~S) is inconsistent with its initial value of ~S."
			(VAR-DECLARED-TYPE HOME) NAME (SECOND INIT-FORM)) )
	      (LET ((INIT-TYPE (TYPE-OF-EXPRESSION INIT-FORM)))
		(IF (AND (NEQ INIT-TYPE 'T)
			 (SI:DISJOINT-TYPEP INIT-TYPE DECLARED-TYPE NIL *COMPILE-FILE-ENVIRONMENT*))
		    (WARN 'SI:DISJOINT-TYPEP ':IMPOSSIBLE
			  "~S is declared to be of type ~S but its initial value is a ~S."
			  NAME (VAR-DECLARED-TYPE HOME) INIT-TYPE)
		  (RETURN-FROM CHECK-DECLARATION)
		  ))))
	  (REMF (VAR-DECLARATIONS HOME) 'TYPE) ; discard the bad declaration
	  (SETF (VAR-DATA-TYPE HOME) 'T)
	  )))
    (IF (NULL INIT-FORM)
	NAME
      (LIST NAME INIT-FORM))))
))

#!C
; From file MINDEFS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; MINDEFS.#"


;; These three functions are used for run-time error reporting when the compiler 
;; has generated code to validate conformance to type declarations.
(DEFUN ASSIGNMENT-TYPE-ERROR (VALUE VARIABLE-NAME TYPE-SPECIFIER)
  ;;  5/03/89 DNG - Original.
  (UNLESS (TYPEP VALUE TYPE-SPECIFIER)
    (CERROR "Proceed, assigning the value anyway."
	    "Assigning value ~S to variable ~A, which was declared to be of type ~S."
	    VALUE VARIABLE-NAME TYPE-SPECIFIER))
  VALUE)

(DEFUN ARGUMENT-TYPE-ERROR (VALUE VARIABLE-NAME TYPE-SPECIFIER)
  ;;  5/03/89 DNG - Original.
  (UNLESS (TYPEP VALUE TYPE-SPECIFIER)
    (CERROR "Proceed, using the value anyway."
	    "Parameter ~A was declared to be of type ~S, but is being given the value ~S."
	    VARIABLE-NAME TYPE-SPECIFIER VALUE))
  VALUE)

))

#!C
; From file P1FUNS.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "TEST: COMPILER; P1FUNS.#"


(DEFUN P1SBIND (X KIND PARALLEL IGNORE-NIL-P THIS-FRAME-DECLARATIONS)
  ;;  7/18/85 - Add check for binding of a DEFCONSTANT; previously done in VAR-MAKE-HOME. [SPR 194]
  ;;  9/14/85 - Use EQ instead of STRING-EQUAL to test for IGNORE.
  ;;  1/09/86 - Allow "variable appears twice" message to be suppressed by INHIBIT-STYLE-WARNINGS-SWITCH.
  ;;  3/07/86 - Don't set LOCAL-DECLARATIONS from redundant &SPECIAL flag.
  ;;  4/22/89 - In Scheme mode, permit variables names beginning with ":" or "&".
  ;;  4/26/89 - Return BOUNDVARS as second value.
  ;;  5/03/89 - For MULTIPLE-VALUE-BIND, include NILs in BOUNDVARS.
  ;;  5/08/89 - For parallel binding, don't update PROPAGATE-VAR-SET until after all the bindings are done.

  (DECLARE (VALUES VLIST BOUNDVARS))
  (LET (TM EVALCODE VARN (MYVARS NIL) (BOUNDVARS NIL) MISC-TYPES
	SPECIFIED-FLAGS (SPECIALNESS NIL) ALREADY-REST-ARG)
    ;; First look at the var specs and make homes, pushing them on MYVARS (reversed).
    (PROG ()
	  (SETQ EVALCODE 'FEF-QT-DONTCARE)
       A  (COND ((NULL X) (RETURN))
		((SETQ TM (ASSOC (CAR X)
				'((&OPTIONAL . FEF-ARG-OPT)
				  (&REST . FEF-ARG-REST) (&AUX . FEF-ARG-AUX))
				:TEST #'EQ))
		 (COND ((OR (EQ KIND 'FEF-ARG-AUX)
			    (EQ KIND 'FEF-ARG-INTERNAL-AUX))
			(WARN 'BAD-BINDING-LIST ':IMPOSSIBLE
			      "A lambda-list keyword (~S) appears in an internal binding list."
			      (CAR X)))
		       (T (SETQ KIND (CDR TM))))
		 (GO B))
		((SETQ TM (ASSOC (CAR X) '((&EVAL . FEF-QT-EVAL)
					   (&QUOTE . FEF-QT-QT)
					   (&QUOTE-DONTCARE . FEF-QT-DONTCARE))
				 :TEST #'EQ))
		 (SETQ EVALCODE (CDR TM))
		 (GO B))
		((SETQ TM (ASSOC (CAR X) '((&FUNCTIONAL . FEF-FUNCTIONAL-ARG)) :TEST #'EQ))
		 (PUSH (CDR TM) MISC-TYPES)
		 (GO B))
		((EQ (CAR X) '&SPECIAL)
		 (SETQ SPECIALNESS T)
		 (GO B))
		((EQ (CAR X) '&LOCAL)
		 (SETQ SPECIALNESS NIL)
		 (GO B))
		((MEMBER (CAR X) LAMBDA-LIST-KEYWORDS :TEST #'EQ)
		 (GO B)))
	  ;; LAMBDA-list keywords have jumped to B.
	  ;; Now (CAR X) should be a variable or (var init).
	  (SETQ VARN (COND ((ATOM (CAR X)) (CAR X)) (T (CAAR X))))
	  (UNLESS (SYMBOLP VARN)
	    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE
		  "~S appears in a list of variables to be bound." VARN)
	    (GO B))
	  (WHEN (AND (KEYWORDP VARN) ; this check added 8/13/84 by D.N.G.
		     (NOT (COMPILING-SCHEME-P)))
	    (WARN 'VARIABLE-NOT-SYMBOL ':IMPOSSIBLE
		  "The keyword ~S appears in a list of variables to be bound.
Keywords are constants and so cannot be used as names of variables." VARN)
	    (GO B))
	  (WHEN (AND (OR (GET-FOR-TARGET VARN 'SYSTEM-CONSTANT)
			 (ASSOC VARN FILE-CONSTANTS-LIST :TEST #'EQ))
		     (NOT (EQ VARN 'NIL)) ; permitted in MULTIPLE-VALUE-BIND
		     (EQ (FIND-TYPE VARN THIS-FRAME-DECLARATIONS)
			 'FEF-SPECIAL) )
	    (WARN 'SYSTEM-CONSTANT-BOUND ':IMPLAUSIBLE
		  "Attempt to bind the constant ~S; the new binding will be local.
If that is what you want, this message can be suppressed by (DECLARE (UNSPECIAL ~S))."
		  VARN VARN)
	    (PUSH `(UNSPECIAL ,VARN) THIS-FRAME-DECLARATIONS) )
	  (WHEN (AND (NOT (OR (EQ VARN 'LISP:IGNORE)
			      (STRING-EQUAL VARN "IGNORED")
			      (NULL VARN)))
		     ;; Does this variable appear again later?
		     ;; An exception is made in that a function argument can be repeated
		     ;; after an &AUX.
		     (DOLIST (X1 (CDR X))
		       (COND ((EQ X1 '&AUX) (RETURN NIL))
			     ((OR (EQ X1 VARN)
				  (AND (NOT (ATOM X1)) (EQ (CAR X1) VARN)))
			      (RETURN T))))
		     (OR PARALLEL
			 (NOT INHIBIT-STYLE-WARNINGS-SWITCH)) )
	    (WARN 'BAD-BINDING-LIST ':IMPLAUSIBLE
		  "The variable ~S appears twice in one binding list."
		  VARN) )
	  (WHEN (AND (CHAR= (CHAR (SYMBOL-NAME VARN) 0) #\&)
		     (NOT (COMPILING-SCHEME-P)))
	    (WARN 'MISSPELLED-KEYWORD ':IMPLAUSIBLE
		  "~S is probably a misspelled keyword." VARN))
	  (WHEN ALREADY-REST-ARG
	    (WARN 'BAD-LAMBDA-LIST ':IMPOSSIBLE
		  "Argument ~S comes after the &REST argument." VARN))
	  (WHEN (EQ KIND 'FEF-ARG-REST)
	    (SETQ ALREADY-REST-ARG T))
	  (COND ((AND IGNORE-NIL-P (NULL VARN))
		 (LET ((P1VALUE NIL))
		   (P1 (CADAR X))) ;Out of order, but works in these simple cases
		 (PUSH NIL BOUNDVARS))
		((OR (NULL VARN) (EQ VARN T))
		 (WARN 'NIL-OR-T-SET ':IMPOSSIBLE "There is an attempt to bind ~S." VARN))
		(T
		 ;; Make the variable's home.
		 (IF SPECIALNESS
		     (LET ((DECL (LIST 'SPECIAL
				       (COND ((SYMBOLP (CAR X)) (CAR X))
					     ((SYMBOLP (CAAR X)) (CAAR X))
					     (T (CADAAR X))))))
		       (UNLESS (SPECIALP (SECOND DECL))
			 ;; If already special anyway, don't put it on LOCAL-DECLARATIONS
			 ;; to avoid warning from FIND-TYPE on a later binding.
			 (PUSH DECL LOCAL-DECLARATIONS) )
		       (PUSH DECL THIS-FRAME-DECLARATIONS)))
		 (LET ((V (P1BINDVAR (CAR X) KIND EVALCODE MISC-TYPES
				     THIS-FRAME-DECLARATIONS)))
		   (PUSH V MYVARS)
		   (PUSH V BOUNDVARS))))
	  (SETQ MISC-TYPES NIL)
       B
	  (SETQ X (CDR X))
	  (GO A))
															       
    ;; Arguments should go on ALLVARS now, so all args precede all boundvars.
    (OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
	(EQ KIND 'FEF-ARG-AUX)
	(SETQ ALLVARS (APPEND SPECIFIED-FLAGS MYVARS ALLVARS)))
    (MAPC #'VAR-COMPUTE-INIT SPECIFIED-FLAGS (CIRCULAR-LIST NIL))

    (PROCESS-BINDING-DECLARATIONS MYVARS THIS-FRAME-DECLARATIONS)

    ;; Now do pass 1 on the initializations for the variables.
    (DO ((ACCUM)
	 (NEW-PROPAGATE 0)
	 (VS (REVERSE MYVARS) (CDR VS)))
	((NULL VS)
	 ;; If parallel binding, put all var homes on VARS
	 ;; after all the inits are thru.
	 (WHEN PARALLEL
	   (SETQ PROPAGATE-VAR-SET (LOGIOR PROPAGATE-VAR-SET NEW-PROPAGATE))
	   (UNLESS (ZEROP ALTERED-VAR-SET)
	     ;; Prevent propagation of new variables whose initial
	     ;; values are local variables which were changed as
	     ;; a side effect of a parallel binding.
	     (MAP-VARIABLES-IN-SET
	       #'(LAMBDA (V BIT)
		   (LET ((INIT (VAR-INIT-FORM V)))
		     (WHEN (AND (CONSP INIT)
				(EQ (CAR INIT) 'LOCAL-REF)
				(LOGTEST (CDDR INIT) ALTERED-VAR-SET))
		       (SETQ PROPAGATE-VAR-SET
			     (LOGDIF PROPAGATE-VAR-SET BIT)) )))
	       NEW-PROPAGATE
	       MYVARS) )
	   (SETQ VARS (APPEND MYVARS VARS))
	   (COND ((OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
		      (EQ KIND 'FEF-ARG-AUX))
		  (MAPC #'VAR-CONSIDER-OVERLAP MYVARS)
		  (SETQ ALLVARS (APPEND MYVARS ALLVARS)))))
	 (VALUES (NREVERSE ACCUM)
		 (NREVERSE BOUNDVARS)))
      (IF PARALLEL
	  (LET ((OLD-PROPAGATE PROPAGATE-VAR-SET))
	    (PUSH (VAR-COMPUTE-INIT (CAR VS) PARALLEL) ACCUM)
	    ;; For parallel binding, shouldn't update PROPAGATE-VAR-SET until after 
	    ;; all the bindings are done.
	    (LET ((NEW (LOGDIF PROPAGATE-VAR-SET OLD-PROPAGATE)))
	      (SETQ NEW-PROPAGATE (LOGIOR NEW-PROPAGATE NEW))
	      (SETQ PROPAGATE-VAR-SET (LOGDIF PROPAGATE-VAR-SET NEW))))
	;; For sequential binding, put each var on VARS
	;; after its own init.
	(PROGN (PUSH (VAR-COMPUTE-INIT (CAR VS) PARALLEL) ACCUM)
	       (COND ((OR (EQ KIND 'FEF-ARG-INTERNAL-AUX)
			  (EQ KIND 'FEF-ARG-AUX))
		      (VAR-CONSIDER-OVERLAP (CAR VS))
		      (PUSH (CAR VS) ALLVARS)))
	       (PUSH (CAR VS) VARS)
	       (LET ((TEM (CDDR (VAR-INIT (CAR VS)))))
		 (AND TEM (PUSH TEM VARS))))))))
))