0.8.9.50:

	Fix the first of Bruno Haible's test failures, more-or-less as
	per Nikodemus Siivola sbcl-devel 2004-04-16
	... also fix behaviour of OBSOLETE-INSTANCE-TRAP as hinted by NS

diff --git a/NEWS b/NEWS
index 3a2ccc4..a90f447 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2386,6 +2386,8 @@ changes in sbcl-0.8.10 relative to sbcl-0.8.9:
     values.  (thanks to Zach Beane)
   * bug fix: streams with element-type (SIGNED-BYTE <N>) for <N>
     greater than 32 handle EOF correctly.
+  * bug fix: class slots in redefined classes preserve their old
+    values.  (thanks to Bruno Haible and Nikodemus Siivola)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** READ-SEQUENCE now works on ECHO-STREAMs.
     ** RATIONALIZE works more according to its specification.  (thanks

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index b03b1f1..b9c034e 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -431,7 +431,6 @@
                 (direct-slots nil direct-slots-p)
                 (direct-default-initargs nil direct-default-initargs-p)
                 (predicate-name nil predicate-name-p))
-  (declare (ignore slot-names))
   (cond (direct-superclasses-p
         (setq direct-superclasses
               (or direct-superclasses
@@ -461,18 +460,22 @@
       (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)
+       (let ((old-class-slot-cells (plist-value class 'class-slot-cells))
+             (collect '()))
          (dolist (dslotd direct-slots)
            (when (eq :class (slot-definition-allocation dslotd))
-             (let ((initfunction (slot-definition-initfunction dslotd)))
-               (push (cons (slot-definition-name dslotd)
-                              (if initfunction
-                                  (funcall initfunction)
-                                  +slot-unbound+))
-                      collect))))
+             ;; see CLHS 4.3.6
+             (let* ((name (slot-definition-name dslotd))
+                    (old (assoc name old-class-slot-cells)))
+               (if (or (not old)
+                       (eq t slot-names)
+                       (member name slot-names))
+                   (let* ((initfunction (slot-definition-initfunction dslotd))
+                          (value (if initfunction
+                                     (funcall initfunction)
+                                     +slot-unbound+)))
+                     (push (cons name value) collect))
+                   (push old collect)))))
           (nreverse collect)))
   (setq predicate-name (if predicate-name-p
                           (setf (slot-value class 'predicate-name)
@@ -867,20 +870,10 @@
     (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 (and (equal (class-precedence-list class) cpl)
@@ -1380,13 +1373,13 @@
             (added ())
             (discarded ())
             (plist ()))
-       ;; local  --> local     transfer
-       ;; local  --> shared       discard
-       ;; local  -->  --         discard
-       ;; shared --> local     transfer
-       ;; shared --> shared       discard
-       ;; shared -->  --         discard
-       ;;  --    --> local     add
+       ;; local  --> local     transfer value
+       ;; local  --> shared    discard value, discard slot
+       ;; local  -->  --       discard slot
+       ;; shared --> local     transfer value
+       ;; shared --> shared    -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
+       ;; shared -->  --       discard value
+       ;;  --    --> local     add slot
        ;;  --    --> shared    --
 
        ;; Go through all the old local slots.
@@ -1407,11 +1400,8 @@
          (let ((name (car oclass-slot-and-val))
                (val (cdr oclass-slot-and-val)))
            (let ((npos (posq name nlayout)))
-             (if npos
-                 (setf (clos-slots-ref nslots npos) (cdr oclass-slot-and-val))
-                 (progn (push name discarded)
-                        (unless (eq val +slot-unbound+)
-                          (setf (getf plist name) val)))))))
+             (when npos
+               (setf (clos-slots-ref nslots npos) val)))))
 
        ;; Go through all the new local slots to compute the added slots.
        (dolist (nlocal nlayout)

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index b183624..7a5a0fb 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -732,5 +732,13 @@
         (defclass accessoroid-class () ((slot :accessor accessoroid)))
         program-error))
 
+;;; reported by Bruno Haible sbcl-devel 2004-04-15
+(defclass shared-slot-and-redefinition ()
+  ((size :initarg :size :initform 1 :allocation :class)))
+(let ((i (make-instance 'shared-slot-and-redefinition)))
+  (defclass shared-slot-and-redefinition ()
+    ((size :initarg :size :initform 2 :allocation :class)))
+  (assert (= (slot-value i 'size) 1)))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index e68bfed..65c6dd8 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".)
-"0.8.9.49"
+"0.8.9.50"