;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 121.53
;;; Reason:
;;;  sublis-eval-once was broken
;;;  (so what else is new?)
;;; Written 7-Apr-87 21:14:20 by EFH (Edward F. Hardebeck) at site LMI Cambridge
;;; while running on Orson Welles from band 2
;;; with Experimental System 121.51, 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 1729, SDU Boot Tape 3.12, SDU ROM 8.



; From modified file DJ: L.SYS2; SETF.LISP#126 at 7-Apr-87 21:14:21
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; SETF  "

(defun sublis-eval-once-1 (exp alist &optional reuse-flag sequential-flag)
  (cond ((null alist) exp)
	((symbolp exp)
	 (let ((tem (assq exp alist)))
	   (cond ((null tem) exp)
		 ((seo-tempvar tem)
		  (incf (seo-count tem))
		  (seo-tempvar tem))
		 ((eq (seo-count tem) t)
		  (seo-exp tem))
		 (t
		  (setf (seo-tempvar tem)
			(if reuse-flag (car tem) (gensym)))
		  (setf (seo-count tem) 0)
		  (setf (seo-first-use tem)
			(cons 'progn nil))
		  (let ((e1
			  `(,@(loop for tail on *seo-first-uninserted-var*
				    until (eq (car tail) tem)
				    do (setf (seo-tempvar (car tail))
					     (if reuse-flag (caar tail) (gensym)))
				    (setf (seo-first-use (car tail)) (seo-first-use tem))
				    collect `(setq ,(seo-tempvar (car tail))
						   ,(if sequential-flag
							(sublis-eval-once-1
							  (seo-exp (car tail))
							  (ldiff alist tail))
						      (seo-exp (car tail))))
				    finally (setq *seo-first-uninserted-var* (cdr tail)))
			    (setq ,(seo-tempvar tem)
				  ,(if sequential-flag
				       (sublis-eval-once-1 (seo-exp tem)
							   (ldiff alist (memq tem alist)))
				     (seo-exp tem))))))
		    (setf (cdr (seo-first-use tem)) e1)
		    (seo-first-use tem))))))
	((atom exp) exp)
	;; Why do I bother?
	;; EFH 4/7/87
	((eq (car exp) 'si:displaced)
	 `(si:displaced ,(second exp)
			,(sublis-eval-once-1 (third exp) alist reuse-flag sequential-flag)))
	(t
	 (do ((tail exp (cdr tail))
	      accum)
	     ((atom tail)
	      (nreconc accum tail))
	   (push (sublis-eval-once-1 (car tail) alist reuse-flag sequential-flag)
		 accum)))))

))