EQL bug in Victoria Day PCL

[Gregor.pa@Xerox.COM]

There is a bug in Victoria Day PCL with certain uses of EQL
specializers.  I believe that this bug could also strike people doing
simple meta-level programming, but have not heard any reports of such.  

The following patch should deal with this problem.  You can either put
this in a separate file and compile and load that on top of PCL, or you
can make the changes to the PCL sources and recompile.

;from file defs.lisp (this is an addition)
(defvar *notice-methods-change-force-p* ())

;from file boot.lisp
(defun fix-early-generic-functions (&optional noisyp)
  (allocate-instance (find-class 'standard-generic-function));Be sure this
						              ;class has an
						              ;instance.
  (let* ((class (find-class 'standard-generic-function))
	 (wrapper (class-wrapper class))
	 (n-static-slots (class-no-of-instance-slots class))
	 #+Lucid
	 (lucid::*redefinition-action* nil)
	 (*notice-methods-change-force-p* t))
    (flet ((fix-structure (gf)
	     (let ((static-slots
		     (%allocate-static-slot-storage--class n-static-slots)))
	       (setf (funcallable-instance-wrapper gf) wrapper
		     (funcallable-instance-static-slots gf) static-slots))))

      (dolist (early-gf-spec *early-generic-functions*)
	(when noisyp (format t "~&~S..." early-gf-spec))
	(let* ((early-gf (gdefinition early-gf-spec))
	       (early-static-slots
		 (funcallable-instance-static-slots early-gf))
	       (early-discriminator-code nil)
	       (early-methods nil)
	       (aborted t))
	  (flet ((trampoline (&rest args)
		   (apply early-discriminator-code args)))
	    (if (not (listp early-static-slots))
		(when noisyp (format t "already fixed?"))
		(unwind-protect
		    (progn
		      (setq early-discriminator-code
			    (early-gf-discriminator-code early-gf))
		      (setq early-methods
			    (early-gf-methods early-gf))
		      (setf (gdefinition early-gf-spec) #'trampoline)
		      (when noisyp (format t "trampoline..."))
		      (fix-structure early-gf)
		      (when noisyp (format t "fixed..."))
		      (initialize-instance early-gf)
		      (dolist (early-method early-methods)
			(destructuring-bind
			     (class quals lambda-list specs fn doc slot-name)
			     (cadddr early-method)
			  (setq specs
				(early-method-specializers early-method t))
			  (real-add-method early-gf 
					   (real-make-a-method class
							       quals
							       lambda-list
							       specs
							       fn
							       doc
							       slot-name))
			  (when noisyp (format t "m"))))
		      (setf (slot-value early-gf 'name) early-gf-spec)
		      (setq aborted nil))
		  (setf (gdefinition early-gf-spec) early-gf)
		  (when noisyp (format t "."))
		  (when aborted
		    (setf (funcallable-instance-static-slots early-gf)
			  early-static-slots)))))))
	  
      (dolist (fns *early-functions*)
	(setf (symbol-function (car fns)) (symbol-function (caddr fns))))
      (dolist (fixup *generic-function-fixups*)
	(destructuring-bind (gf-spec lambda-list specializers method-fn-name)
			    fixup
	  (let* ((fn (if method-fn-name
			 (symbol-function method-fn-name)
			 (symbol-function gf-spec)))
		 (gf (make-instance 'standard-generic-function))
		 (method (make-a-method
			   'standard-method () lambda-list specializers fn nil)))
	    (set-function-name gf gf-spec)
	    (setf (generic-function-name gf) gf-spec)
	    (real-add-method gf method)
	    (setf (gdefinition gf-spec) gf)))))))

;from file methods.lisp
(defun notice-methods-change (generic-function)
  (let ((old-discriminator-code
	  (generic-function-discriminator-code generic-function)))
   (if *notice-methods-change-force-p*
       (notice-methods-change-1 generic-function)
       ;; Install a lazy evaluation discriminator code updator as the
       ;; funcallable-instance function of the generic function.  When
       ;; it is called, it will update the discriminator code of the
       ;; generic function, unless it is inside a recursive call to
       ;; the generic function in which case it will call the old
       ;; version of the discriminator code for the generic function.
       ;;
       ;; Note that because this closure will be the discriminator code
       ;; of a generic function it must be careful about how it changes
       ;; the discriminator code of that same generic function.  If it
       ;; isn't careful, it could change its closure variables out from
       ;; under itself.
       ;;
       ;; In order to prevent this we take a simple measure:  we just
       ;; make sure that it doesn't try to reference its own closure
       ;; variables after it makes the dcode change.  This is done by
       ;; having notice-methods-change-2 do the work of making the
       ;; change AND calling the actual generic function (a closure
       ;; variable) over.  This means that at the time the dcode change
       ;; is made, there is a pointer to the generic function on the
       ;; stack where it won't be affected by the change to the closure
       ;; variables.
       ;;
       (set-funcallable-instance-function
	 generic-function
	 #'(lambda (&rest args)
	     #+Genera
	     (declare (dbg:invisible-frame :clos-internal))
	     (if (memq generic-function *invalid-generic-functions-on-stack*)
		 (if old-discriminator-code
		     (apply old-discriminator-code args)
		     (error "Tried to call an invalid generic function ~
                              that never was valid at all."))
		 (notice-methods-change-2 generic-function args)))))))
-------