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