From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 19 Nov 2004 16:28:58 +0000 (+0000)
Subject: 0.8.16.44: direct-subclass update protocol bugfix
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=760349abe9068fe4e5e3c03013f3533b64602a93;p=sbcl.git

0.8.16.44: direct-subclass update protocol bugfix
            * Fixes the issue noted by David Morse of superclasses
               direct-subclass lists not being correctly updated.
---

diff --git a/NEWS b/NEWS
index a583d35..3d66399 100644
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,9 @@ changes in sbcl-0.8.17 relative to sbcl-0.8.16:
     types.
   * fixed bug #308: non-graphic characters now all have names, as
     required.  (reported by Bruno Haible)
+  * bug fix: redefining a class with different superclasses now correctly
+    removes it from the direct-subclasses of its previous superclasses.
+    (reported by David Morse)
   * bug fix: (SETF FIND-CLASS) using a FORWARD-REFERENCED-CLASS as the
     new value now works. (reported by Bruno Haible)
   * bug fix: correct canonicalization of multiple non-standard slot
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index d60c04c..3a6b3b9 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -501,8 +501,9 @@
   (setf (slot-value class 'class-eq-specializer)
 	(make-instance 'class-eq-specializer :class class)))
 
-(defmethod reinitialize-instance :before ((class slot-class) &key)
-  (remove-direct-subclasses class (class-direct-superclasses class))
+(defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses)
+  (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses))
+    (remove-direct-subclass old-super class))
   (remove-slot-accessors    class (class-direct-slots class)))
 
 (defmethod reinitialize-instance :after ((class slot-class)
@@ -769,11 +770,6 @@
     (unless (memq class (class-direct-subclasses class))
       (add-direct-subclass super class))))
 
-(defun remove-direct-subclasses (class supers)
-  (let ((old (class-direct-superclasses class)))
-    (dolist (o (set-difference old supers))
-      (remove-direct-subclass o class))))
-
 (defmethod finalize-inheritance ((class std-class))
   (update-class class t))
 
@@ -942,10 +938,10 @@
   (find-class 'standard-direct-slot-definition))
 
 (defun make-direct-slotd (class initargs)
-  (let ((initargs (list* :class class initargs)))
-    (apply #'make-instance
-	   (apply #'direct-slot-definition-class class initargs)
-	   initargs)))
+  (apply #'make-instance
+         (apply #'direct-slot-definition-class class initargs)
+         :class class
+         initargs))
 
 (defmethod compute-slots ((class std-class))
   ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index ddc2e9b..0cdefc6 100644
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -369,6 +369,13 @@
       (assert (null value))
       (assert (typep error 'error)))))
 
+;;; bug reported by David Morse: direct-subclass update protocol was broken
+(defclass vegetable () ())
+(defclass tomato (vegetable) ())
+(assert (equal (list (find-class 'tomato)) (sb-mop:class-direct-subclasses (find-class 'vegetable))))
+(defclass tomato () ())
+(assert (null (sb-mop:class-direct-subclasses (find-class 'vegetable))))
+
 
 ;;;; success
 (sb-ext:quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index b592228..504ebc1 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.8.16.43"
+"0.8.16.44"