;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.107
;;; Reason:
;;;  Fix PUSHNEW, which was mis-optimized under certain (slightly bizarre)
;;;  circumstances.  The optimized code was applying the :TEST function to
;;;  its arguments in the wrong order; now we call TEST on the ITEM, compared
;;;  to the ELEMENT in the PLACE being compared.
;;;  
;;;  This was obviously a problem only for TEST functions which care
;;;  about argument order.  For example,
;;;  
;;;  
;;;     (let((x '(1 2 3))) (pushnew 4 x :test '<))
;;;  
;;;  returned (1 2 3), not (4 1 2 3).  Check it with ADJOIN or MEMBER.
;;;  
;;;  [ASIDE: In fact, let's implement PUSHNEW purely in terms of ADJOIN, and
;;;  so forth. This kind of bug used to exist in other CL sequence functions,
;;;  which were also over-hairified.  A comment in the code notes that ADJOIN
;;;  should be optimized, not PUSHNEW.  That is, PUSHNEW should be
;;;  implemented in terms of ADJOIN.  I agree with all my heart.  The
;;;  optimizer is just a potential source of lossage, since 1) ADJOIN is
;;;  already highly optimized, and 2) the MEM--- functions being optimized
;;;  for are mostly microcoded.  If nobody objects, I will flush
;;;  OPTIMIZE-PUSHNEW for release 5.]
;;; Written 25-Jun-88 21:29:09 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 1
;;; with Experimental System 124.106, Experimental Local-File 74.3, 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.SYS2; SETF.LISP#131 at 25-Jun-88 21:29:10
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; SETF  "

(defun optimize-pushnew (value place options environment)
  (if (or (not (symbolp place)) (oddp (length options)))
      ;; stupid optimizer doesn't try to win on this.
      nil
    (let (test xtest)
      (do ((x options (cddr x)))
	  ((null x))
	(cond ((or (eq (car x) ':test)
		   (equal (car x) '':test))
	       (if (not test)
		   ;; note: cannot use (function test) as this would lose inside FLET
		   ;;  redefinition of test
		   (cond ((list-match-p (cadr x) `(quote ,test)))
			 ((and (list-match-p (cadr x) `(function ,test))
			       (symbolp test)	;or else fsymeval-in-environment blows out
			       (not (fsymeval-in-environment test environment nil))))
			 (t (return (setq test nil))))))
	      (t (setq test nil) (return))))
      (if (null options) (setq test 'eql))
      (cond ((and (symbolp test) (not (null test)))
	     (setq xtest (cdr (assq test *test-member-alist*)))
	     (flet ((make-test (item)
			       (if xtest
				   `(,xtest ,item ,place)
				 (let ((x (gensym)))
				   `(do ((,x ,place (cdr ,x)))
					((null ,x))
				      ;;Compare ITEM to (FUNCALL <:key> ELEMENT) !
				      (if (,test ,item (car ,x)) (return ,x)))))))
	       (if (or (symbolp value) (constantp value))
		   `(progn (or ,(make-test value)
			       (push ,value ,place))
			   ,place)
		   (let ((tem (gensym)))
		     `(let ((,tem ,value))
			(or ,(make-test tem)
			    (push ,tem ,place))
			,place)))))
	    ;; stupid optimizer doesn't try to hack this either...
	    (t nil)))))

))