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