From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Thu, 13 Jul 2006 10:03:38 +0000 (+0000)
Subject: 0.9.14.12:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a7e7d0b213aa1133cc419421d611e7e2ad36808c;p=sbcl.git

0.9.14.12:
	Fix bug in SB-PCL::COMPUTE-CLASS-SLOTS, exposed by CHANGE-CLASS.
	... test case
	... this bug fix means that we no longer have to walk the
		inherits vector looking for class slots from
		superclasses, hooray.
---

diff --git a/NEWS b/NEWS
index eed5f25..7019aba 100644
--- a/NEWS
+++ b/NEWS
@@ -1,12 +1,16 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-0.9.15 relative to sbcl-0.9.14:
-  * added support for the ucs-2 external format (contributed by Ivan     Boldyrev)
+  * added support for the ucs-2 external format.  (contributed by Ivan
+    Boldyrev)
   * minor incompatible change: pretty printing of objects of type
     (cons symbol) is, in the default pprint-dispatch-table, now
     sensitive to whether the symbol satisfies FBOUNDP.  (thanks to
     Marcus Pearce)
   * fixed bug: FILE-POSITION sometimes returned inconsistent results
-    for multibyte external-format streams (thanks to "vbzoli")
+    for multibyte external-format streams.  (thanks to "vbzoli")
+  * fixed bug: CHANGE-CLASS would fail to preserve the values of slots
+    with :ALLOCATION :CLASS inherited from superclasses of the
+    original class.
 
 changes in sbcl-0.9.14 relative to sbcl-0.9.13:
   * feature: thread support on Solaris/x86, and experimental thread support
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index c3216ba..80f7719 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -917,11 +917,12 @@
 
 (defun compute-class-slots (eslotds)
   (let (collect)
-    (dolist (eslotd eslotds)
-      (push (assoc (slot-definition-name eslotd)
-                   (class-slot-cells (slot-definition-class eslotd)))
-            collect))
-    (nreverse collect)))
+    (dolist (eslotd eslotds (nreverse collect))
+      (let ((cell (assoc (slot-definition-name eslotd)
+                         (class-slot-cells
+                          (slot-definition-allocation-class eslotd)))))
+        (aver cell)
+        (push cell collect)))))
 
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)
@@ -1356,15 +1357,6 @@
         ;;  --    --> 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)
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 46749be..864e0b6 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1290,6 +1290,15 @@
                          (defmethod class-as-specializer-test2 ((x ,(find-class 'class-as-specializer-test)))
                            'bar))))
 (assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test))))
-
+
+;;; CHANGE-CLASS and tricky allocation.
+(defclass foo ()
+  ((a :allocation :class :initform 1)))
+(defclass bar (foo) ())
+(defvar *bar* (make-instance 'bar))
+(defclass baz ()
+  ((a :allocation :instance :initform 2)))
+(change-class *bar* 'baz)
+(assert (= (slot-value *bar* 'a) 1))
 
 ;;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index 9e0d5c3..7d1ce15 100644
--- 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.9.14.11"
+"0.9.14.12"