X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=a6cec9da75692ca75355811cf125b3f1b1e08e0d;hb=add57c72c932fbf70c8ba8297154936c908b410e;hp=043e0da3dad61d7b6a10cedd91e57c7a057c3eb5;hpb=dc86450e18fb7b90bf6be7d8df8b8ebcb0d090f9;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 043e0da..a6cec9d 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -86,6 +86,20 @@
 	(compute-slot-accessor-info slotd type gf)))
     (initialize-internal-slot-gfs name)))
 
+;;; CMUCL (Gerd PCL 2003-04-25) comment:
+;;;
+;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
+;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
+;;; writing/testing effective slot SLOTD.
+;;;
+;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on
+;;; GF.  Store the effective method in the effective slot definition
+;;; object itself; these GFs have special dispatch functions calling
+;;; effective methods directly retrieved from effective slot
+;;; definition objects, as an optimization.
+;;;
+;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
+;;; or some such.
 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
 				       type gf)
   (let* ((name (slot-value slotd 'name))
@@ -104,57 +118,9 @@
 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
   :instance)
 
-(defmethod shared-initialize :after ((object documentation-mixin)
-				     slot-names
-				     &key (documentation nil documentation-p))
-  (declare (ignore slot-names))
-  (when documentation-p
-    (setf (plist-value object 'documentation) documentation)))
-
-;;; default if DOC-TYPE doesn't match one of the specified types
-(defmethod documentation (object doc-type)
-  (warn "unsupported DOCUMENTATION: type ~S for object ~S"
-	doc-type
-	(type-of object))
-  nil)
-
-;;; default if DOC-TYPE doesn't match one of the specified types
-(defmethod (setf documentation) (new-value object doc-type)
-  ;; CMU CL made this an error, but since ANSI says that even for supported
-  ;; doc types an implementation is permitted to discard docs at any time
-  ;; for any reason, this feels to me more like a warning. -- WHN 19991214
-  (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S"
-	doc-type
-	(type-of object))
-  new-value)
-
-(defmethod documentation ((object documentation-mixin) doc-type)
-  (declare (ignore doc-type))
-  (plist-value object 'documentation))
-
-(defmethod (setf documentation) (new-value
-				 (object documentation-mixin)
-				 doc-type)
-  (declare (ignore doc-type))
-  (setf (plist-value object 'documentation) new-value))
-
-(defmethod documentation ((slotd standard-slot-definition) doc-type)
-  (declare (ignore doc-type))
-  (slot-value slotd 'documentation))
-
-(defmethod (setf documentation) (new-value
-				 (slotd standard-slot-definition)
-				 doc-type)
-  (declare (ignore doc-type))
-  (setf (slot-value slotd 'documentation) new-value))
-
 ;;;; various class accessors that are a little more complicated than can be
 ;;;; done with automatically generated reader methods
 
-(defmethod class-finalized-p ((class pcl-class))
-  (with-slots (wrapper) class
-    (not (null wrapper))))
-
 (defmethod class-prototype ((class std-class))
   (with-slots (prototype) class
     (or prototype (setq prototype (allocate-instance class)))))
@@ -326,10 +292,16 @@
 
 (setf (gdefinition 'load-defclass) #'real-load-defclass)
 
-(defun ensure-class (name &rest all)
-  (apply #'ensure-class-using-class name (find-class name nil) all))
+(defun ensure-class (name &rest args)
+  (apply #'ensure-class-using-class
+	 (let ((class (find-class name nil)))
+	   (when (and class (eq name (class-name class)))
+	     ;; NAME is the proper name of CLASS, so redefine it
+	     class))
+	 name
+	 args))
 
-(defmethod ensure-class-using-class (name (class null) &rest args &key)
+(defmethod ensure-class-using-class ((class null) name &rest args &key)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)
     (set-class-type-translation (class-prototype meta) name)
@@ -338,10 +310,11 @@
     (set-class-type-translation class name)
     class))
 
-(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
+(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
   (multiple-value-bind (meta initargs)
       (ensure-class-values class args)
-    (unless (eq (class-of class) meta) (change-class class meta))
+    (unless (eq (class-of class) meta)
+      (apply #'change-class class meta initargs))
     (apply #'reinitialize-instance class initargs)
     (setf (find-class name) class)
     (set-class-type-translation class name)
@@ -353,12 +326,11 @@
 (defun fix-super (s)
   (cond ((classp s) s)
         ((not (legal-class-name-p s))
-          (error "~S is not a class or a legal class name." s))
+	 (error "~S is not a class or a legal class name." s))
         (t
-          (or (find-class s nil)
-              (setf (find-class s)
-                      (make-instance 'forward-referenced-class
-                                     :name s))))))
+	 (or (find-class s nil)
+	     (make-instance 'forward-referenced-class
+			    :name s)))))
 
 (defun ensure-class-values (class args)
   (let* ((initargs (copy-list args))
@@ -459,7 +431,6 @@
 		 (direct-slots nil direct-slots-p)
 		 (direct-default-initargs nil direct-default-initargs-p)
 		 (predicate-name nil predicate-name-p))
-  (declare (ignore slot-names))
   (cond (direct-superclasses-p
 	 (setq direct-superclasses
 	       (or direct-superclasses
@@ -489,15 +460,22 @@
       (setq direct-default-initargs
 	    (plist-value class 'direct-default-initargs)))
   (setf (plist-value class 'class-slot-cells)
-	(let (collect)
+	(let ((old-class-slot-cells (plist-value class 'class-slot-cells))
+	      (collect '()))
 	  (dolist (dslotd direct-slots)
 	    (when (eq :class (slot-definition-allocation dslotd))
-	      (let ((initfunction (slot-definition-initfunction dslotd)))
-		(push (cons (slot-definition-name dslotd)
-			       (if initfunction
-				   (funcall initfunction)
-				   +slot-unbound+))
-                      collect))))
+	      ;; see CLHS 4.3.6
+	      (let* ((name (slot-definition-name dslotd))
+		     (old (assoc name old-class-slot-cells)))
+		(if (or (not old)
+			(eq t slot-names)
+			(member name slot-names))
+		    (let* ((initfunction (slot-definition-initfunction dslotd))
+			   (value (if initfunction
+				      (funcall initfunction)
+				      +slot-unbound+)))
+		      (push (cons name value) collect))
+		    (push old collect)))))
           (nreverse collect)))
   (setq predicate-name (if predicate-name-p
 			   (setf (slot-value class 'predicate-name)
@@ -507,9 +485,71 @@
 				     (make-class-predicate-name (class-name
 								 class))))))
   (add-direct-subclasses class direct-superclasses)
-  (update-class class nil)
   (make-class-predicate class predicate-name)
-  (add-slot-accessors class direct-slots))
+  (update-class class nil)
+  (do* ((slots (slot-value class 'slots) (cdr slots))
+	(dupes nil))
+       ((null slots) (when dupes
+		       (style-warn
+			;; FIXME: the indentation request ("~4I")
+			;; below appears not to do anything.  Finding
+			;; out why would be nice.  -- CSR, 2003-04-24
+			"~@<slot names with the same SYMBOL-NAME but ~
+                         different SYMBOL-PACKAGE (possible package problem) ~
+                         for class ~S:~@:_~4I~<~@{~S~^~:@_~}~:>~@:>"
+			class
+			dupes)))
+    (let* ((slot (car slots))
+	   (oslots (remove (slot-definition-name slot) (cdr slots)
+			   :test #'string/= :key #'slot-definition-name)))
+      (when oslots
+	(pushnew (cons (slot-definition-name slot)
+		       (mapcar #'slot-definition-name oslots))
+		 dupes
+		 :test #'string= :key #'car))))
+  (add-slot-accessors class direct-slots)
+  (make-preliminary-layout class))
+
+(defmethod shared-initialize :after ((class forward-referenced-class)
+				     slot-names &key &allow-other-keys)
+  (declare (ignore slot-names))
+  (make-preliminary-layout class))
+
+(defvar *allow-forward-referenced-classes-in-cpl-p* nil)
+
+;;; Give CLASS a preliminary layout if it doesn't have one already, to
+;;; make it known to the type system.
+(defun make-preliminary-layout (class)
+  (flet ((compute-preliminary-cpl (root)
+	   (let ((*allow-forward-referenced-classes-in-cpl-p* t))
+	     (compute-class-precedence-list root))))
+    (unless (class-finalized-p class)
+      (let ((name (class-name class)))
+	(setf (find-class name) class)
+	;; KLUDGE: This is fairly horrible.  We need to make a
+	;; full-fledged CLASSOID here, not just tell the compiler that
+	;; some class is forthcoming, because there are legitimate
+	;; questions one can ask of the type system, implemented in
+	;; terms of CLASSOIDs, involving forward-referenced classes. So.
+	(when (and (eq *boot-state* 'complete)
+		   (null (find-classoid name nil)))
+	  (setf (find-classoid name)
+		(make-standard-classoid :name name)))
+	(set-class-type-translation class name)
+	(let ((layout (make-wrapper 0 class))
+	      (classoid (find-classoid name)))
+	  (setf (layout-classoid layout) classoid)
+	  (setf (classoid-pcl-class classoid) class)
+	  (setf (slot-value class 'wrapper) layout)
+	  (let ((cpl (compute-preliminary-cpl class)))
+	    (setf (layout-inherits layout)
+		  (order-layout-inherits
+		   (map 'simple-vector #'class-wrapper
+			(reverse (rest cpl))))))
+	  (register-layout layout :invalidate t)
+	  (setf (classoid-layout classoid) layout)
+	  (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))
+
 
 (defmethod shared-initialize :before ((class class) slot-names &key name)
   (declare (ignore slot-names name))
@@ -531,12 +571,16 @@
 		    (apply #'update-dependent class dependent initargs))))
 
 (defmethod shared-initialize :after ((class condition-class) slot-names
-				     &key direct-superclasses)
+				     &key direct-slots direct-superclasses)
   (declare (ignore slot-names))
   (let ((classoid (find-classoid (class-name class))))
     (with-slots (wrapper class-precedence-list prototype predicate-name
 			 (direct-supers direct-superclasses))
 	class
+      (setf (slot-value class 'direct-slots)
+	    (mapcar (lambda (pl) (make-direct-slotd class pl))
+		    direct-slots))
+      (setf (slot-value class 'finalized-p) t)
       (setf (classoid-pcl-class classoid) class)
       (setq direct-supers direct-superclasses)
       (setq wrapper (classoid-layout classoid))
@@ -544,7 +588,62 @@
       (setq prototype (make-condition (class-name class)))
       (add-direct-subclasses class direct-superclasses)
       (setq predicate-name (make-class-predicate-name (class-name class)))
-      (make-class-predicate class predicate-name))))
+      (make-class-predicate class predicate-name)
+      (setf (slot-value class 'slots) (compute-slots class))))
+  ;; Comment from Gerd's PCL, 2003-05-15:
+  ;;
+  ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
+  ;; override condition accessors with generic functions.  We do this
+  ;; differently.
+  (update-pv-table-cache-info class))
+
+(defmethod direct-slot-definition-class ((class condition-class)
+					 &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'condition-direct-slot-definition))
+
+(defmethod effective-slot-definition-class ((class condition-class)
+					    &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'condition-effective-slot-definition))
+
+(defmethod finalize-inheritance ((class condition-class))
+  (aver (slot-value class 'finalized-p))
+  nil)
+
+(defmethod compute-effective-slot-definition
+    ((class condition-class) slot-name dslotds)
+  (let ((slotd (call-next-method)))
+    (setf (slot-definition-reader-function slotd)
+	  (lambda (x)
+	    (handler-case (condition-reader-function x slot-name)
+	      ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
+	      ;; is unbound; maybe it should be a CELL-ERROR of some
+	      ;; sort?
+	      (error () (values (slot-unbound class x slot-name))))))
+    (setf (slot-definition-writer-function slotd)
+	  (lambda (v x)
+	    (condition-writer-function x v slot-name)))
+    (setf (slot-definition-boundp-function slotd)
+	  (lambda (x)
+	    (multiple-value-bind (v c)
+		(ignore-errors (condition-reader-function x slot-name))
+	      (declare (ignore v))
+	      (null c))))
+    slotd))
+
+(defmethod compute-slots ((class condition-class))
+  (mapcan (lambda (superclass)
+	    (mapcar (lambda (dslotd)
+		      (compute-effective-slot-definition
+		       class (slot-definition-name dslotd) (list dslotd)))
+		    (class-direct-slots superclass)))
+	  (reverse (slot-value class 'class-precedence-list))))
+
+(defmethod compute-slots :around ((class condition-class))
+  (let ((eslotds (call-next-method)))
+    (mapc #'initialize-internal-slot-functions eslotds)
+    eslotds))
 
 (defmethod shared-initialize :after
     ((slotd structure-slot-definition) slot-names &key
@@ -602,6 +701,19 @@
                (cons nil nil))))
     (values defstruct-form constructor reader-names writer-names)))
 
+(defun make-defstruct-allocation-function (class)
+  (let ((dd (get-structure-dd (class-name class))))
+    (lambda ()
+      (let ((instance (%make-instance (dd-length dd)))
+	    (raw-index (dd-raw-index dd)))
+	(setf (%instance-layout instance)
+	      (sb-kernel::compiler-layout-or-lose (dd-name dd)))
+	(when raw-index
+	  (setf (%instance-ref instance raw-index)
+		(make-array (dd-raw-length dd)
+			    :element-type '(unsigned-byte 32))))
+	instance))))
+
 (defmethod shared-initialize :after
       ((class structure-class)
        slot-names
@@ -636,22 +748,24 @@
 			      (make-direct-slotd class pl))
 			    direct-slots)))
 	(setq direct-slots (slot-value class 'direct-slots)))
-    (when defstruct-p
-      (let ((include (car (slot-value class 'direct-superclasses))))
-        (multiple-value-bind (defstruct-form constructor reader-names writer-names)
-            (make-structure-class-defstruct-form name direct-slots include)
-          (unless (structure-type-p name) (eval defstruct-form))
-          (mapc (lambda (dslotd reader-name writer-name)
-		  (let* ((reader (gdefinition reader-name))
-			 (writer (when (gboundp writer-name)
-				   (gdefinition writer-name))))
-		    (setf (slot-value dslotd 'internal-reader-function)
-			  reader)
-		    (setf (slot-value dslotd 'internal-writer-function)
-			  writer)))
-                direct-slots reader-names writer-names)
-          (setf (slot-value class 'defstruct-form) defstruct-form)
-          (setf (slot-value class 'defstruct-constructor) constructor))))
+    (if defstruct-p
+	(let ((include (car (slot-value class 'direct-superclasses))))
+	  (multiple-value-bind (defstruct-form constructor reader-names writer-names)
+	      (make-structure-class-defstruct-form name direct-slots include)
+	    (unless (structure-type-p name) (eval defstruct-form))
+	    (mapc (lambda (dslotd reader-name writer-name)
+		    (let* ((reader (gdefinition reader-name))
+			   (writer (when (gboundp writer-name)
+				     (gdefinition writer-name))))
+		      (setf (slot-value dslotd 'internal-reader-function)
+			    reader)
+		      (setf (slot-value dslotd 'internal-writer-function)
+			    writer)))
+		  direct-slots reader-names writer-names)
+	    (setf (slot-value class 'defstruct-form) defstruct-form)
+	    (setf (slot-value class 'defstruct-constructor) constructor)))
+	(setf (slot-value class 'defstruct-constructor)
+	      (make-defstruct-allocation-function class)))
     (add-direct-subclasses class direct-superclasses)
     (setf (slot-value class 'class-precedence-list)
             (compute-class-precedence-list class))
@@ -659,6 +773,7 @@
     (let ((lclass (find-classoid (class-name class))))
       (setf (classoid-pcl-class lclass) class)
       (setf (slot-value class 'wrapper) (classoid-layout lclass)))
+    (setf (slot-value class 'finalized-p) t)
     (update-pv-table-cache-info class)
     (setq predicate-name (if predicate-name-p
 			   (setf (slot-value class 'predicate-name)
@@ -670,7 +785,7 @@
     (make-class-predicate class predicate-name)
     (add-slot-accessors class direct-slots)))
 
-(defmethod direct-slot-definition-class ((class structure-class) initargs)
+(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'structure-direct-slot-definition))
 
@@ -685,7 +800,10 @@
 
 (defun fix-slot-accessors (class dslotds add/remove)
   (flet ((fix (gfspec name r/w)
-	   (let ((gf (ensure-generic-function gfspec)))
+	   (let* ((ll (case r/w (r '(object)) (w '(new-value object))))
+		  (gf (if (fboundp gfspec)
+			  (ensure-generic-function gfspec)
+			  (ensure-generic-function gfspec :lambda-list ll))))
 	     (case r/w
 	       (r (if (eq add/remove 'add)
 		      (add-reader-method class gf name)
@@ -742,6 +860,7 @@
     (return-from update-class))
   (when (or finalizep (class-finalized-p class)
 	    (not (class-has-a-forward-referenced-superclass-p class)))
+    (setf (find-class (class-name class)) class)
     (update-cpl class (compute-class-precedence-list class))
     ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
     ;; class.  The hoops above are to ensure that FINALIZE-INHERITANCE
@@ -750,14 +869,18 @@
     ;; (section 5.5.2 of AMOP).
     (update-slots class (compute-slots class))
     (update-gfs-of-class class)
-    (update-inits class (compute-default-initargs class))
+    (update-initargs class (compute-default-initargs class))
     (update-ctors 'finalize-inheritance :class class))
   (unless finalizep
     (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
 
 (defun update-cpl (class cpl)
   (if (class-finalized-p class)
-      (unless (equal (class-precedence-list class) cpl)
+      (unless (and (equal (class-precedence-list class) cpl)
+		   (dolist (c cpl t)
+		     (when (position :class (class-direct-slots c)
+				     :key #'slot-definition-allocation)
+		       (return nil))))
 	;; comment from the old CMU CL sources:
 	;;   Need to have the cpl setup before update-lisp-class-layout
 	;;   is called on CMU CL.
@@ -792,8 +915,10 @@
 				  :key #'slot-definition-location)))
 	   (nslots (length nlayout))
 	   (nwrapper-class-slots (compute-class-slots class-slots))
-	   (owrapper (class-wrapper class))
-	   (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
+	   (owrapper (when (class-finalized-p class)
+		       (class-wrapper class)))
+	   (olayout (when owrapper
+		      (wrapper-instance-slots-layout owrapper)))
 	   (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
 	   (nwrapper
 	    (cond ((null owrapper)
@@ -820,9 +945,10 @@
 	      (wrapper-class-slots nwrapper) nwrapper-class-slots
 	      (wrapper-no-of-instance-slots nwrapper) nslots
 	      wrapper nwrapper))
-
+      (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)
-	(update-pv-table-cache-info class)))))
+	(update-pv-table-cache-info class)
+	(maybe-update-standard-class-locations class)))))
 
 (defun compute-class-slots (eslotds)
   (let (collect)
@@ -849,33 +975,24 @@
 		   (update-gf-dfun class gf))
 		 gf-table)))))
 
-(defun update-inits (class inits)
+(defun update-initargs (class inits)
   (setf (plist-value class 'default-initargs) inits))
 
 (defmethod compute-default-initargs ((class slot-class))
-  (let ((cpl (class-precedence-list class))
-	(direct (class-direct-default-initargs class)))
-    (labels ((walk (tail)
-	       (if (null tail)
-		   nil
-		   (let ((c (pop tail)))
-		     (append (if (eq c class)
-				 direct
-				 (class-direct-default-initargs c))
-			     (walk tail))))))
-      (let ((initargs (walk cpl)))
-	(delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
+  (let ((initargs (loop for c in (class-precedence-list class)
+			append (class-direct-default-initargs c))))
+    (delete-duplicates initargs :test #'eq :key #'car :from-end t)))
 
 ;;;; protocols for constructing direct and effective slot definitions
 
-(defmethod direct-slot-definition-class ((class std-class) initargs)
+(defmethod direct-slot-definition-class ((class std-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'standard-direct-slot-definition))
 
 (defun make-direct-slotd (class initargs)
   (let ((initargs (list* :class class initargs)))
     (apply #'make-instance
-	   (direct-slot-definition-class class initargs)
+	   (apply #'direct-slot-definition-class class initargs)
 	   initargs)))
 
 (defmethod compute-slots ((class std-class))
@@ -893,6 +1010,7 @@
 	      (push (list name slot) name-dslotds-alist)))))
     (mapcar (lambda (direct)
 	      (compute-effective-slot-definition class
+						 (car direct)
 						 (nreverse (cdr direct))))
 	    name-dslotds-alist)))
 
@@ -912,7 +1030,13 @@
 		      (from-class (slot-definition-allocation-class eslotd))
 		      (cell (assq name (class-slot-cells from-class))))
 		 (aver (consp cell))
-		 cell))))
+		 (if (eq +slot-unbound+ (cdr cell))
+		     ;; We may have inherited an initfunction
+		     (let ((initfun (slot-definition-initfunction eslotd)))
+		       (if initfun
+			   (rplacd cell (funcall initfun))
+			   cell))
+		     cell)))))
       (initialize-internal-slot-functions eslotd))))
 
 (defmethod compute-slots ((class funcallable-standard-class))
@@ -966,8 +1090,10 @@
 (defmethod compute-slots ((class structure-class))
   (mapcan (lambda (superclass)
 	    (mapcar (lambda (dslotd)
-		      (compute-effective-slot-definition class
-							 (list dslotd)))
+		      (compute-effective-slot-definition
+		       class
+		       (slot-definition-name dslotd)
+		       (list dslotd)))
 		    (class-direct-slots superclass)))
 	  (reverse (slot-value class 'class-precedence-list))))
 
@@ -976,16 +1102,17 @@
     (mapc #'initialize-internal-slot-functions eslotds)
     eslotds))
 
-(defmethod compute-effective-slot-definition ((class slot-class) dslotds)
+(defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
+  (declare (ignore name))
   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
-	 (class (effective-slot-definition-class class initargs)))
+	 (class (apply #'effective-slot-definition-class class initargs)))
     (apply #'make-instance class initargs)))
 
-(defmethod effective-slot-definition-class ((class std-class) initargs)
+(defmethod effective-slot-definition-class ((class std-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'standard-effective-slot-definition))
 
-(defmethod effective-slot-definition-class ((class structure-class) initargs)
+(defmethod effective-slot-definition-class ((class structure-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'structure-effective-slot-definition))
 
@@ -1170,7 +1297,14 @@
 	(with-pcl-lock
 	  (update-lisp-class-layout class nwrapper)
 	  (setf (slot-value class 'wrapper) nwrapper)
-	  (invalidate-wrapper owrapper :flush nwrapper))))))
+	  ;; Use :OBSOLETE instead of :FLUSH if any superclass has
+	  ;; been obsoleted.
+ 	  (if (find-if (lambda (x) 
+ 			 (and (consp x) (eq :obsolete (car x))))
+ 		       (layout-inherits owrapper) 
+ 		       :key #'layout-invalid)
+ 	      (invalidate-wrapper owrapper :obsolete nwrapper)
+	      (invalidate-wrapper owrapper :flush nwrapper)))))))
 
 (defun flush-cache-trap (owrapper nwrapper instance)
   (declare (ignore owrapper))
@@ -1252,15 +1386,25 @@
 	     (added ())
 	     (discarded ())
 	     (plist ()))
-	;; local  --> local	transfer
-	;; local  --> shared       discard
-	;; local  -->  --	  discard
-	;; shared --> local	transfer
-	;; shared --> shared       discard
-	;; shared -->  --	  discard
-	;;  --    --> local	add
+
+	;; local  --> local	transfer value
+	;; local  --> shared    discard value, discard slot
+	;; local  -->  --	discard slot
+	;; shared --> local	transfer value
+	;; shared --> shared    -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
+	;; shared -->  --	discard value
+	;;  --    --> local	add slot
 	;;  --    --> shared	--
 
+	;; Collect class slots from inherited wrappers. Needed for
+	;; shared -> local transfers of inherited slots.
+	(let ((inherited (layout-inherits owrapper)))
+	  (loop for i from (1- (length inherited)) downto 0
+		for layout = (aref inherited i)
+		when (typep layout 'wrapper)
+		do (dolist (slot (wrapper-class-slots layout))
+		     (pushnew slot oclass-slots :key #'car))))
+
 	;; Go through all the old local slots.
         (let ((opos 0))
           (dolist (name olayout)
@@ -1279,11 +1423,8 @@
 	  (let ((name (car oclass-slot-and-val))
 		(val (cdr oclass-slot-and-val)))
 	    (let ((npos (posq name nlayout)))
-	      (if npos
-		  (setf (clos-slots-ref nslots npos) (cdr oclass-slot-and-val))
-		  (progn (push name discarded)
-			 (unless (eq val +slot-unbound+)
-			   (setf (getf plist name) val)))))))
+	      (when npos
+		(setf (clos-slots-ref nslots npos) val)))))
 
 	;; Go through all the new local slots to compute the added slots.
 	(dolist (nlocal nlayout)