From: Nikodemus Siivola <nikodemus@sb-studio.net>
Date: Fri, 29 Jul 2011 10:16:26 +0000 (+0300)
Subject: obsolete instance protocol and class-slots
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=2deecbd428dee535b5830e0686ad130f64110fb9;p=sbcl.git

obsolete instance protocol and class-slots

  UPDATE-INSTANCE-FOR-REDEFINED-CLASS needs to be called when
  the set of class-slots changes.

  ...we /tried/ to do that, but embarrasingly

   (LOOP FOR X IN LIST1
         FOR Y IN LIST2
         ALWAYS ...)

  returns T if either list has elements missing from the other in the
  tail as the iteration terminates when list runs out. Oops.
---

diff --git a/NEWS b/NEWS
index 2d22de9..5ec457b 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,8 @@ changes relative to sbcl-1.0.50:
     (reported by Jan Moringen; lp#815155)
   * bug fix: a compiler error during typecheck generation, reported by Eric
     Marsden.
+  * bug fix: obsolete instance protocol fires when shared slots are added
+    or removed.
 
 changes in sbcl-1.0.50 relative to sbcl-1.0.49:
   * enhancement: errors from FD handlers now provide a restart to remove
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index ab7cb21..a07cf93 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -968,9 +968,8 @@
             (cond ((null owrapper)
                    (make-wrapper nslots class))
                   ((and (equal nlayout olayout)
-                        (loop for o in owrapper-class-slots
-                              for n in nwrapper-class-slots
-                              always (eq (car o) (car n)))
+                        (equal (mapcar #'car owrapper-class-slots)
+                               (mapcar #'car nwrapper-class-slots))
                         (slotd-classes-eq (slot-value class 'slots) eslotds))
                    owrapper)
                   (t
diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index 96904b8..6015c66 100644
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -645,5 +645,37 @@
            ((foo :initarg :foo :reader foofoo :function car))
            (:metaclass func-slot-class)))
     (assert (eq x (foofoo o)))))
+
+(defclass class-slot-removal-test ()
+  ((instance :initform 1)
+   (class :allocation :class :initform :ok)))
+
+(defmethod update-instance-for-redefined-class ((x class-slot-removal-test) added removed plist &rest inits)
+  (throw 'update-instance
+    (list added removed plist inits)))
+
+(with-test (:name :class-redefinition-removes-class-slot)
+  (let ((o (make-instance 'class-slot-removal-test)))
+    (assert (equal '(nil nil nil nil)
+                   (catch 'update-instance
+                     (eval `(defclass class-slot-removal-test ()
+                              ((instance :initform 2))))
+                     (slot-value o 'instance))))))
+
+(defclass class-slot-add-test ()
+  ((instance :initform 1)))
+
+(defmethod update-instance-for-redefined-class ((x class-slot-add-test) added removed plist &rest inits)
+  (throw 'update-instance
+    (list added removed plist inits)))
+
+(with-test (:name :class-redefinition-adds-class-slot)
+  (let ((o (make-instance 'class-slot-add-test)))
+    (assert (equal '(nil nil nil nil)
+                   (catch 'update-instance
+                     (eval `(defclass class-slot-add-test ()
+                              ((instance :initform 2)
+                               (class :allocation :class :initform :ok))))
+                     (slot-value o 'instance))))))
 
 ;;;; success