0.8.10.32:

[sbcl.git] / src / pcl / std-class.lisp

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index d03f94e..a6cec9d 100644 (file)
--- 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))
 \f
 (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))
@@ -1380,6 +1386,7 @@
             (added ())
             (discarded ())
             (plist ()))
+
        ;; local  --> local     transfer value
        ;; local  --> shared    discard value, discard slot
        ;; local  -->  --       discard slot
@@ -1389,6 +1396,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)