From e5d1aeaf4a7ab07855b62b359a2081f76933d198 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Mon, 20 Jun 2005 13:03:21 +0000 Subject: [PATCH] From Gerd, cmucl-imp, 2005-06-18: (progn (defclass foo92b (foo92a) ((s :initarg :s))) (defclass foo92a () ()) (let ((x (make-instance 'foo92b :s 5)) (update-counter 0)) (defclass foo92b (foo92a) ((s) (s1) (s2))) ; still subclass of foo92a (slot-value x 's) (defmethod update-instance-for-redefined-class ((object foo92b) added-slots discarded-slots property-list &rest initargs) (incf update-counter)) (make-instances-obsolete 'foo92a) (slot-value x 's) update-counter)) Expected: 1 Got: 0 [Taken from clisp's clos.tst] * src/pcl/std-class.lisp (force-cache-flushes): Use new state :obsolete if some superclass has been obsoleted. * src/pcl/cache.lisp (check-wrapper-validity): If state is :invalid, recurse because force-cache-flushes can change the state. --- pcl/cache.lisp | 19 ++++++++++--------- pcl/std-class.lisp | 11 +++++++++-- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/pcl/cache.lisp b/pcl/cache.lisp index aa9c6a4c5..5d8efb1c6 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.34 2003/05/31 09:23:23 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.35 2005/06/20 13:03:21 rtoy Rel $") ;;; ;;; The basics of the PCL wrapper cache mechanism. @@ -411,16 +411,17 @@ ;; previous call to REGISTER-LAYOUT for a superclass of ;; INSTANCE's class. See also the comment above ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this. + ;; Note that FORCE-CACHE-FLUSHES may change LAYOUT-INVALID, + ;; so we have to recurse. ((eq state :invalid) - (let ((class (class-of instance))) - (force-cache-flushes class) - (class-wrapper class))) + (force-cache-flushes (class-of instance)) + (check-wrapper-validity instance)) + ((eq (car state) :flush) + (flush-cache-trap owrapper (second state) instance)) + ((eq (car state) :obsolete) + (obsolete-instance-trap owrapper (second state) instance)) (t - (ecase (first state) - (:flush - (flush-cache-trap owrapper (second state) instance)) - (:obsolete - (obsolete-instance-trap owrapper (second state) instance))))))) + (internal-error "Unknown wrapper state"))))) (declaim (inline check-obsolete-instance)) (defun check-obsolete-instance (instance) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 2a9797904..11e58bde5 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.78 2005/05/31 18:10:05 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.79 2005/06/20 13:03:21 rtoy Exp $") (in-package :pcl) @@ -1341,7 +1341,14 @@ (with-pcl-lock (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper :flush nwrapper)))))) + (flet ((obsolete-super-p () + (some (lambda (layout) + (eq (car-safe (kernel:layout-invalid layout)) + :obsolete)) + (kernel:layout-inherits owrapper)))) + (invalidate-wrapper owrapper + (if (obsolete-super-p) :obsolete :flush) + nwrapper))))))) (defun flush-cache-trap (owrapper nwrapper instance) (declare (ignore owrapper)) -- GitLab