X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=a07cf93ce01126627894663fefe778f28bf89305;hb=f17e3d27d7ff599f9443d011d17017a2a858c81a;hp=4e2604f4baef6fb7afff871a7355057f5ff671e8;hpb=0223f43d5f199914ebceff12b6f4c60448369edd;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 4e2604f..a07cf93 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -915,6 +915,32 @@
 (defun class-can-precede-p (class1 class2)
   (member class2 (class-can-precede-list class1) :test #'eq))
 
+;;; This is called from %UPDATE-SLOTS when layout doesn't seem to change.
+;;; SLOT-INFO structures from old slotds may have been cached in permutation
+;;; vectors, but new slotds have had new ones allocated to them.
+;;;
+;;; This is non-problematic for standard slotds, because we know the structure
+;;; is compatible, but if a slot definition class changes, this can change the
+;;; way SLOT-VALUE-USING-CLASS should dispatch.
+;;;
+;;; So, compare all slotd classes, and return T if all remain the same.
+(defun slotd-classes-eq (oslotds nslotds)
+  (labels ((pop-nslotd (name)
+             (aver nslotds)
+             ;; Most of the time the first slot is right, but because the
+             ;; order of instance and non-instance slots can change without
+             ;; layout changing we cannot rely on that.
+             (let ((n (pop nslotds)))
+               (if (eq name (slot-definition-name n))
+                   n
+                   (prog1
+                       (pop-nslotd name)
+                     (push n nslotds))))))
+    (loop while oslotds
+          for o = (pop oslotds)
+          for n = (pop-nslotd (slot-definition-name o))
+          always (eq (class-of o) (class-of n)))))
+
 (defun %update-slots (class eslotds)
   (let ((instance-slots ())
         (class-slots    ()))
@@ -942,10 +968,9 @@
             (cond ((null owrapper)
                    (make-wrapper nslots class))
                   ((and (equal nlayout olayout)
-                        (not
-                         (loop for o in owrapper-class-slots
-                               for n in nwrapper-class-slots
-                               do (unless (eq (car o) (car n)) (return t)))))
+                        (equal (mapcar #'car owrapper-class-slots)
+                               (mapcar #'car nwrapper-class-slots))
+                        (slotd-classes-eq (slot-value class 'slots) eslotds))
                    owrapper)
                   (t
                    ;; This will initialize the new wrapper to have the