0.8alpha.0.23:

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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 2f88079..a653842 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -499,6 +499,9 @@
       (setq direct-default-initargs
            (plist-value class 'direct-default-initargs)))
   (setf (plist-value class 'class-slot-cells)
+       ;; The below initializes shared slots from direct initforms,
+       ;; but one might inherit initforms from superclasses
+       ;; (cf. UPDATE-SHARED-SLOT-VALUES).
        (let (collect)
          (dolist (dslotd direct-slots)
            (when (eq :class (slot-definition-allocation dslotd))
@@ -744,7 +747,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))
 
@@ -826,13 +829,27 @@
     (update-slots class (compute-slots class))
     (update-gfs-of-class class)
     (update-inits class (compute-default-initargs class))
+    (update-shared-slot-values class)
     (update-ctors 'finalize-inheritance :class class))
   (unless finalizep
     (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
 
+(defun update-shared-slot-values (class)
+  (dolist (slot (class-slots class))
+    (when (eq (slot-definition-allocation slot) :class)
+      (let ((cell (assq (slot-definition-name slot) (class-slot-cells class))))
+        (when cell
+          (let ((initfn (slot-definition-initfunction slot)))
+            (when initfn
+              (setf (cdr cell) (funcall initfn)))))))))
+
 (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.
@@ -936,14 +953,14 @@
 \f
 ;;;; 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))
@@ -1050,14 +1067,14 @@
 (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))