;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 121.59
;;; Reason:
;;;  Fix problem with *P1VALUE* when compiling LET* that has one form
;;;  in its body.
;;; Written 1-May-87 18:13:09 by Rauen at site LMI Cambridge
;;; while running on Debtor in Possession from band 2
;;; with Experimental System 121.58, Experimental Lambda-Diag 15.0, Experimental ZMail 70.2, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, microcode 1730, SDU Boot Tape 3.14, SDU ROM 103, 121.53.



; From file DJ: L.SYS; QCP1.LISP#682 at 1-May-87 18:13:15
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "

(DEFUN P1LET (FORM &OPTIONAL FOR-AUXVARS)
  (unless (cl:listp (cadr form))
    (warn 'invalid-form :impossible
	  "The second element, ~S, of the ~S special form is not a list"
	  (cadr form) (car form))
    (setq form `(,(car form) () . ,(cddr form))))
  (LET ((*VARS* *VARS*)
	OUTER-VARS
	(FN (CAR FORM))
	(*BINDP* NIL)					;%bind not yet used
	(VLIST (CADR FORM))
	(LOCAL-DECLARATIONS LOCAL-DECLARATIONS)
	(ENTRY-LEXICAL-CLOSURE-COUNT *LEXICAL-CLOSURE-COUNT*))
    (IF (EQ FN 'LET-FOR-AUXVARS) (SETQ FN 'LET*))
    (dolist (var vlist)
      (cond ((symbolp var))
	    ((or (atom var)
		 (not (symbolp (car var))))
	     (warn 'variable-not-symbol :impossible
		   "~S appears in a list of variables to be bound."
		   (or (car-safe var) var))
	     (setq vlist (remq var vlist)))
	    ((not (cl:listp (cdr var)))
	     (warn 'invalid-form :impossible
		   "The ~S variable spec ~S is not a proper list"
		   (car form) var)
	     (setq vlist (remq var vlist)))
	    ((cddr var)
	     (warn 'invalid-form :implausible
		   "More than two forms in ~S variable spec ~S"
		   (car form) var)
	     (setq vlist (cl:subst (list (car var) (cdr var)) var vlist)))))
    (MULTIPLE-VALUE-BIND (BODY THIS-FRAME-DECLARATIONS)
	(with-list (env *function-environment*)
	  (EXTRACT-DECLARATIONS-RECORD-MACROS (CDDR FORM) NIL NIL ENV))
      (PROCESS-SPECIAL-DECLARATIONS THIS-FRAME-DECLARATIONS)
      (SETQ OUTER-VARS *VARS*)
      ;; Treat parallel binding as serial if it doesn't matter.
      (WHEN (OR (NULL (CDR VLIST))			; ie if only 1 symbol
		(AND (EQ FN 'LET)
		     (DOLIST (XX VLIST)
		       ;; or if binding each symbol to NIL, a constant, or itself.
		       (OR (ATOM XX)			;(let (x) ...)
			   (CONSTANTP (CADR XX))	;(let ((x 'foo)) ...)
			   (EQ (CAR XX) (CADR XX))	;(let ((x x)) ...)
			   (RETURN NIL)))))
	(SETQ FN 'LET*))
      ;; Flush rebinding a var to itself if it isn't special
      ;; and range of rebinding is rest of function.
      (IF *TLEVEL*
	  (SETQ VLIST (SUBSET-NOT (LAMBDA (VAR)
				    (AND (CONSP VAR)
					 (EQ (CAR VAR) (CADR VAR))
					 (EQ (FIND-TYPE (CAR VAR) THIS-FRAME-DECLARATIONS)
					     'FEF-LOCAL)
					 (EQ (VAR-TYPE (ASSQ (CAR VAR) *VARS*)) 'FEF-LOCAL)))
				  VLIST)))
      ;; All the local declarations should be in effect for the init forms.
      (SETQ LOCAL-DECLARATIONS (APPEND THIS-FRAME-DECLARATIONS LOCAL-DECLARATIONS))
      ;; &AUX vars should be allowed to inherit special declarations
      ;; since that is what it looks like when you put a DECLARE inside the body.
      (IF FOR-AUXVARS
	  (SETQ THIS-FRAME-DECLARATIONS LOCAL-DECLARATIONS))
      (SETQ VLIST (P1SBIND VLIST
			   (IF *TLEVEL* 'FEF-ARG-AUX 'FEF-ARG-INTERNAL-AUX)
			   (EQ FN 'LET)
			   NIL
			   THIS-FRAME-DECLARATIONS))
      ;; Now convert initial SETQs to variable initializations.
      ;; We win only for SETQs of variables bound but with no initialization spec'd,
      ;; which set them to constant values, and only if later vars' inits didn't use them.
      ;; When we come to anything other than a SETQ we can win for, we stop.
      ;; For LET*, 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 ((*P1VALUE* 1)				;setq only wants one value
	   TEM HOME)
	  (())
	(COND ((EQUAL (CAR BODY) '((SETQ)))
	       (POP BODY))
	      ((OR (ATOM (CAR BODY))
		   ;; Don't save the optimized form here because it was optimized
		   ;; with *p1value* set incorrectly.  We cannot just fix *p1value*
		   ;; either because we don't yet know how many values (if any) we
		   ;; do want.  Of course, we really can't trust the optimizer to do
		   ;; the right thing if *p1value* is bogus, so what are we doing here?
		   ;; - JRM 1-May-87 18:03:05
		   (let ((tem (COMPILER-OPTIMIZE (car BODY))))
		     ;(push tem body)
		     (ATOM TEM))
		   (NOT (EQ (CAR TEM) 'SETQ))
		   (NOT (MEMQ (CADR TEM) VLIST))	;we're binding it
		   (NOT (CONSTANTP (CADDR TEM)))	;initializing to constant
		   (AND (SPECIALP (CADR TEM))
			(OR TLFUNINIT (NOT *TLEVEL*))
			(EQ FN 'LET*))
		   (NOT (ZEROP (VAR-USE-COUNT (SETQ HOME (ASSQ (CADR TEM) *VARS*))))))
	       (RETURN NIL))
	      (T (SETQ BODY (CONS `(SETQ . ,(CDDDR TEM)) (CDR BODY)))
		 (SETF (CAR (MEMQ (CADR TEM) VLIST))
		       `(,(CADR TEM) ,(P1 (CADDR TEM))))
		 ;; For a variable bound at function entry, really set up its init.
		 ;; Other vars (FEF-ARG-INTERNAL-AUX) will be initted by code,
		 ;; despite our optimization, but it will be better code.
		 (AND *TLEVEL* (EQ (VAR-KIND HOME) 'FEF-ARG-AUX)
		      (SETF (VAR-INIT HOME) `(FEF-INI-PNTR ,(P1 (CADDR TEM))))))))
      ;; Now P1 process what is left of the body.
      (WHEN (CDR BODY) (if *tlevel* (clear-tlevel)))
      (SETQ BODY (P1PROGN-1 BODY))
      `(,FN ,VLIST ,OUTER-VARS ,*VARS* ,*BINDP*
	,ENTRY-LEXICAL-CLOSURE-COUNT ,*LEXICAL-CLOSURE-COUNT*
	. ,BODY))))

))