Commit dff333a3 authored by rtoy's avatar rtoy
Browse files

Fix for update-dependent on gfs, from Gerd Moellman, 2005-06-26: 

This is for one of Bruno's bug reports.  For example,

(defclass upd-history ()
  ((history :initform ())))

(defmethod update-dependent ((gf generic-function) (history upd-history)
			     &rest args)
  (push args (slot-value history 'history)))

(defun history-event-list (history)
  (mapcar (lambda (event)
	    (mapcar (lambda (x)
		      (if (typep x 'method)
			  (list 'method (mapcar #'class-name
						(method-specializers x)))
			  x))
		    event))
	  (reverse (slot-value history 'history))))

(let ((hist (make-instance 'upd-history)))
   (defgeneric upd0 (x))
   (add-dependent #'upd0 hist)
   (defmethod upd0 ((x integer)))
   (history-event-list hist))
=>  ((add-method (method (integer)))))

But, instead of the above expected result, it produces

=>  (nil (add-method (method (integer)))))

The nil is from a reinitialize-instance of the gf, which is triggered
by load-defmethod calling ensure-generic-function, which in turn calls
ensure-generic-function-using-class on the existing gf, which finally
calls reinitialize-instance.

I'm not 100% sure if this is correct or not.  My reading of CLHS/MOP
is that this is at least not forbidden.  Opinions?

	* src/pcl/methods.lisp (real-add-method, update-gf-dependents):
	New function.
	(real-add-method, real-remove-method): Call it.
	(reinitialize-instance) <:around standard-generic-function>:
	Update dependent objects.

	* src/pcl/std-class.lisp (update-dependent): New default method.
parent 6fb3b96a

pcl/methods.lisp

+14 −3
Changes for pcl/methods.lisp: 14 added lines, 3 removed lines.
Original line number Diff line number Diff line
@@ -26,7 +26,7 @@ 
;;;



(file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.43 2003/09/05 23:03:36 gerd Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.44 2005/07/07 16:44:27 rtoy Exp $")



(in-package :pcl)
@@ -413,6 +413,11 @@ 
  (loop (when (null methods) (return gf))

	(real-add-method gf (pop methods) methods)))



(defun update-gf-dependents (gf action method)

  (map-dependents gf

		  (lambda (dependent)

		    (update-dependent gf dependent action method))))



(defun real-add-method (gf method &optional skip-dfun-update-p)

  (when (method-generic-function method)

    (error "~@<The method ~S is already part of the generic ~
@@ -483,6 +488,7 @@ 
	(update-ctors 'add-method :generic-function gf :method method)

	(update-dfun gf))

      (update-accessor-pvs 'add-method gf method old)

      (update-gf-dependents gf 'add-method method)

      gf)))

  

(defun real-remove-method (gf method)
@@ -496,7 +502,8 @@ 
      (set-arg-info gf)

      (update-ctors 'remove-method :generic-function gf :method method)

      (update-dfun gf)

      (update-accessor-pvs 'remove-method gf method)))

      (update-accessor-pvs 'remove-method gf method)

      (update-gf-dependents gf 'remove-method method)))

  gf)
@@ -557,7 +564,11 @@ 
      (when (and (arg-info-valid-p (gf-arg-info gf))

		 (not (null args))

		 (or lambda-list-p (cddr args)))

	  (update-dfun gf)))))

	  (update-dfun gf))

      ;;

      ;; Update dependent objects.

      (map-dependents gf (lambda (dependent)

			   (apply #'update-dependent gf dependent args))))))





(defun compute-applicable-methods-function (gf arguments)

pcl/std-class.lisp

+4 −1
Changes for pcl/std-class.lisp: 4 added lines, 1 removed line.
Original line number Diff line number Diff line
@@ -26,7 +26,7 @@ 
;;;



(file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.79 2005/06/20 13:03:21 rtoy Exp $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.80 2005/07/07 16:44:27 rtoy Exp $")



(in-package :pcl)
@@ -1637,6 +1637,9 @@ 
  (dolist (dependent (plist-value metaobject 'dependents))

    (funcall function dependent)))



(defmethod update-dependent (metaobject dependent &rest initargs)

  (declare (ignore initargs)))





;;;

;;; Conditions