;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.95
;;; Reason:
;;;  Fix error compiling a simple variable binding case:
;;;  
;;;  (defun foo1 (x)
;;;    (let ((x x))
;;;      x))
;;; Written 23-Jun-88 15:29:44 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 1
;;; with Experimental System 124.94, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, Tiger 28.0, microcode 1761, SDU Boot Tape 3.14, SDU ROM 103, Beta 3 for in-house.



; From modified file DJ: L.SYS; QCP1.LISP#723 at 23-Jun-88 15:29:45
#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 (find (CAR VAR) *VARS* :key #'var-name))
					     '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
						    (find (CADR TEM) *VARS* :key #'var-name))))))
	       (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))))

))