From dff333a3468bae9cf80bc10f14c17fd6cca925cd Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 7 Jul 2005 16:44:27 +0000
Subject: [PATCH] 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.
---
 pcl/methods.lisp   | 17 ++++++++++++++---
 pcl/std-class.lisp |  5 ++++-
 2 files changed, 18 insertions(+), 4 deletions(-)

diff --git a/pcl/methods.lisp b/pcl/methods.lisp
index a22c50a73..9cd4352d5 100644
--- a/pcl/methods.lisp
+++ b/pcl/methods.lisp
@@ -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)
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 11e58bde5..97bbefd27 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -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
-- 
GitLab