;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 121.54
;;; Reason:
;;;  fix compiler:breakoff to not screw up the lexical variable which
;;;  holds the throw tag for return froms out of lexical closures
;;;  in some obscure and hairy cases
;;;  don't ask me i just work here.   -EFH
;;; Written 9-May-87 00:34:34 by naha at site LMI Cambridge
;;; while running on Love from band 2
;;; with Experimental System 121.52, 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 1733, SDU Boot Tape 3.13, SDU ROM 102, 121.35.



; From modified file DJ: L.SYS; QCP1.LISP#680 at 9-May-87 00:34:35
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "

(defun breakoff (x &optional lexical &aux fname fname-to-give local-name)
  (let ((non-instance-vars)
	(sfd self-flavor-declaration)
	;selfp
	)
    (dolist (home *vars*)
      (and (eq (var-type home) 'fef-local)
	   ;; Omit shadowed bindings.
	   (eq home (assq (var-name home) *vars*))
	   (pushnew (var-name home) non-instance-vars)))
    (dolist (elt *outer-context-vars*)
      (dolist (home elt)
	(push (var-name home) non-instance-vars)))
    (multiple-value-bind (vars-needed-lexically functions-needed-lexically
			  block-names go-tags)
	(cw-top-level-lambda-expression
	  x					;form
	  (append (if sfd (list* 'self (cddr sfd)))
		  non-instance-vars)		;variables we're interested in
	  (mapcar #'car *local-functions*)	;functions we're interested in
	  *function-environment*)
      (multiple-value-bind (nil decls nil)
	  (with-list (env *function-environment*)
	    (extract-declarations (if (memq (car x) '(named-subst named-lambda))
				      (cdddr x) (cddr x))
				  nil t env))
	(let ((downward (assq 'sys:downward-function decls))
	      tem)
	  (dolist (v vars-needed-lexically)
	    (cond ((and (memq v (cddr sfd)) (not (memq v non-instance-vars)))
		   (unless downward
		     (warn 'instance-variable-used-in-internal-lambda :unimplemented
			   "~The ~:[~;special ~]instance variable ~S of flavor ~S~@
				is being referenced by a lexically closed-over function.~@
				This will not work outside of the dynamic scope of ~S.~"
			   (memq v (cadr sfd)) v (car sfd) 'self)))
		  ((and (eq v 'self) sfd)
		   (unless downward
		     (warn 'self-used-in-internal-lambda :unimplemented
			   "~~S is being referenced by a lexically closed-over function.~@
			This will not, of course, work outside of the dynamic scope of ~S.~"
			   'self 'self)))
		  (t
		   ;; Note: if V is not on *VARS*, it must come from an outer lexical level.
		   ;; That is ok, and it still requires this LAMBDA to be lexical to access it.
		   (setq lexical t)
		   (setq tem (assq v *vars*))
		   (when tem
		     (pushnew 'fef-arg-used-in-lexical-closures (var-misc tem) :test #'eq)))))))
      (dolist (f functions-needed-lexically)
	(let ((tem (assq f *local-functions*)))
	  (when tem
	    (setq lexical t)
	    (pushnew 'fef-arg-used-in-lexical-closures
		     (var-misc (cadr tem)) :test #'eq))))
      (dolist (b block-names)
	(let ((tem (assq b *progdesc-environment*)))
	  (when tem
	    (setq lexical t)
	    ;; the flag may already have been set (by P1BLOCK) to a list representing a local variable
	    ;; home which will contain the throw tag.  something seems to be sorta duplicating the
	    ;; some of the work done by P1BLOCK.
	    ;; I admit I don't really understand what is going on here
	    ;; but I think this fixes it. -- EFH 4/9/87
	    (unless (progdesc-used-in-lexical-closures-flag tem)
	      (setf (progdesc-used-in-lexical-closures-flag tem) t)))))
      (dolist (g go-tags)
	(let ((tem (assq g *gotag-environment*)))
	  (when tem
	    (setq lexical t)
	    (setf (gotag-used-in-lexical-closures-flag tem) t)
	    (setf (progdesc-used-in-lexical-closures-flag (gotag-progdesc tem)) t))))))
  (if (and (eq (car x) 'named-lambda)
	   (not (memq (cadr x) *local-function-map*)))
      (setq local-name (cadr x))
      (setq local-name *breakoff-count*))
  (setq fname `(:internal ,function-to-be-defined ,*breakoff-count*)
	fname-to-give `(:internal ,name-to-give-function ,local-name))
  (push local-name *local-function-map*)
  (incf *breakoff-count*)
  (when lexical
    (incf *lexical-closure-count*))
;  (let ((local-decls local-declarations))
;>> this is already in there.
;    ;; Pass along the parent function's self-flavor declaration.
;    (if sfd (push `(:self-flavor . ,sfd) local-decls))
  (setq compiler-queue
	(nconc compiler-queue
	       (ncons
		 (make-compiler-queue-entry
		   :function-spec fname
		   :function-name fname-to-give
		   :definition x
		   :declarations local-declarations

		   ;; The t is a flag for RECORD-VARIABLES-USED-IN-LEXICAL-CLOSURES
		   ;; *VARS* at this point is a list of the lexically visible variables
		   ;; See  RECORD-VARIABLES-USED-IN-LEXICAL-CLOSURES for the gross detail

		   :variables  (when lexical
				 (cons (cons 't *vars*) *outer-context-vars*))
		   :local-functions (and lexical *local-functions*)
		   :progdescs (and lexical *progdesc-environment*)
		   :gotags (and lexical *gotag-environment*)
		   :function-environment (and lexical *function-environment*)
		   ))))
  (let ((tem `(breakoff-function ,fname)))
    (if lexical `(lexical-closure ,tem) tem)))

))