X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=ca020b4e7dcebc05eea290858c48a174e6a838d2;hb=3a618201c9f2370bb8784217a866d000371769e5;hp=b9c034e042091e9a53ff07575f8e39d0dafa7633;hpb=88746ab4e00faaccb148e9603181df62bc1060d3;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index b9c034e..ca020b4 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -869,7 +869,7 @@
     ;; (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))))
@@ -975,7 +975,7 @@
 		   (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))
@@ -1030,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))
@@ -1291,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))
@@ -1315,7 +1328,9 @@
 	class)))
 
 (defmethod make-instances-obsolete ((class symbol))
-  (make-instances-obsolete (find-class class)))
+  (make-instances-obsolete (find-class class))
+  ;; ANSI wants the class name when called with a symbol.
+  class)
 
 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
 ;;; see an obsolete instance. The times when it is called are:
@@ -1373,6 +1388,7 @@
 	     (added ())
 	     (discarded ())
 	     (plist ()))
+
 	;; local  --> local	transfer value
 	;; local  --> shared    discard value, discard slot
 	;; local  -->  --	discard slot
@@ -1382,6 +1398,15 @@
 	;;  --    --> 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)