0.8alpha.0.34:

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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index d943fb8..5ac2608 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))
@@ -675,6 +678,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
@@ -709,22 +725,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))
@@ -826,13 +844,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.