;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 126.138
;;; Reason:
;;;  A recent fix to the SETF method for GETF caused a problem that was
;;;  creating circular lists in the case of (PUSH 'hi (GETF foo :prop)).  Now
;;;  we do essentially what the old simple setf-method did (see above) in the
;;;  case of a PLACE that is a symbol.   <31-Oct-88 keith+jim>
;;; Written 31-Oct-88 17:09:17 by keith at site Gigamos Cambridge
;;; while running on Johannes Brahms from band 1
;;; with Experimental System 126.137, Experimental ZWEI 126.27, Experimental ZMail 74.13, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Microcode 1762, SDU Boot Tape 3.14, SDU ROM 103, 10/17.



; From modified file DJ: L.SYS2; SETF.LISP#137 at 31-Oct-88 17:09:34
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; SETF  "

(define-setf-method getf (&environment environment place indicator &optional default)
  (if (symbolp place)
      ;; $$$ A recent fix here was creating circular lists in the
      ;; (admittedly weird) case such as (PUSH 'HI (GETF FOO
      ;; :INDICATOR)).  So, do essentially what the old setf-method did
      ;; (see above).
      ;; 
      ;; <31-Oct-88 keith+jim>
      (let ((new (gensym "NEW-"))
	    (tempvars (setf-make-n-tempvars 3)))
	(values tempvars
		(list place indicator default)
		(list new)
		`(setpropf ,(nth 0 tempvars) ,(nth 1 tempvars) ,new)
		`(getf . ,tempvars)))
    ;; An important optimization: handle non-symbol PLACEs differently:
    (let ((indicator-temp (gensym "INDICATOR-"))
	  (default-temp (gensym "DEFAULT-"))
	  (plloc (gensym "PLLOC-"))
	  (store-temp (gensym "STORE-")))
      (multiple-value-bind (tempvars tempargs storevars storeform refform)
	  (get-setf-method place environment)
	(values (list* indicator-temp default-temp tempvars)
		(list* indicator      default      tempargs)
		(list store-temp)
		`(let ((,(car storevars) ,refform))
		   (do ((,plloc ,(car storevars) (cddr ,plloc)))
		       ((null ,plloc)
			(setq ,(car storevars) (list* ,indicator-temp ,store-temp ,(car storevars)))
			,storeform)
		     (when (eq (car ,plloc) ,indicator-temp)
		       (setf (cadr ,plloc) ,store-temp)
		       (return)))
		   ,store-temp)
		`(getf ,refform ,indicator-temp))))))

))