1.0.28.74: SHARED-INITIALIZE should initialize unbound :CLASS slots

 * This has been around for a while, but despite the misleading
   comment in the source the spec is clear enough.

diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index 6696bba..62a342f 100644 (file)
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -101,10 +101,10 @@
   (flet ((initialize-slot-from-initarg (class instance slotd)
            (let ((slot-initargs (slot-definition-initargs slotd)))
              (doplist (initarg value) initargs
-                      (when (memq initarg slot-initargs)
-                        (setf (slot-value-using-class class instance slotd)
-                              value)
-                        (return t)))))
+               (when (memq initarg slot-initargs)
+                 (setf (slot-value-using-class class instance slotd)
+                       value)
+                 (return t)))))
          (initialize-slot-from-initfunction (class instance slotd)
            ;; CLHS: If a before method stores something in a slot,
            ;; that slot won't be initialized from its :INITFORM, if any.
@@ -127,12 +127,9 @@
                   unless (initialize-slot-from-initarg class instance slotd)
                   collect slotd)))
       (dolist (slotd initfn-slotds)
-        (unless (eq (slot-definition-allocation slotd) :class)
-          ;; :ALLOCATION :CLASS slots use the :INITFORM when class is defined
-          ;; or redefined, not when instances are allocated.
-          (when (or (eq t slot-names)
-                    (memq (slot-definition-name slotd) slot-names))
-            (initialize-slot-from-initfunction class instance slotd)))))
+        (when (or (eq t slot-names)
+                  (memq (slot-definition-name slotd) slot-names))
+          (initialize-slot-from-initfunction class instance slotd))))
     instance))
 \f
 ;;; If initargs are valid return nil, otherwise signal an error.

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 12a028e..447639e 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1707,5 +1707,16 @@
     (let ((base (slots (make-bug-357-c))))
       (assert (equal base (slots (make-instance 'bug-357-c))))
       (assert (equal base '(nil t2 3.1415927 -44 :ok t 9 -88 nil t 20))))))
+
+(defclass class-slot-shared-initialize ()
+  ((a :allocation :class :initform :ok)))
+(with-test (:name :class-slot-shared-initialize)
+  (let ((x (make-instance 'class-slot-shared-initialize)))
+    (assert (eq :ok (slot-value x 'a)))
+    (slot-makunbound x 'a)
+    (assert (not (slot-boundp x 'a)))
+    (shared-initialize x '(a))
+    (assert (slot-boundp x 'a))
+    (assert (eq :ok (slot-value x 'a)))))
 \f
 ;;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index f650062..d02c667 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.28.73"
+"1.0.28.74"