From de10a710deb105abc2a4c36f4f7b3b6f18bb0966 Mon Sep 17 00:00:00 2001
From: Juanjo Garcia-Ripoll <jjgarcia@users.sourcerforge.net>
Date: Wed, 25 Apr 2012 16:40:07 +0200
Subject: [PATCH] Remove a class from its former superclasses when
 reinitializing it

---
 src/CHANGELOG         |  3 +++
 src/clos/standard.lsp | 34 ++++++++++++++++++----------------
 2 files changed, 21 insertions(+), 16 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index ee88d13fb..9c011365f 100755
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -71,6 +71,9 @@ ECL 12.2.2:
    method. Elsewhere, ECL relies on the internal equivalent of
    COMPUTE-APPLICABLE-METHODS, which _always_ memoizes results.
 
+ - When reinitializing a class instance, ECL would not remove the class from
+   its former superclasses.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***
diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp
index 034f7a31a..aed05c0e9 100644
--- a/src/clos/standard.lsp
+++ b/src/clos/standard.lsp
@@ -155,28 +155,30 @@
   (unless (find-if #'has-forward-referenced-parents (class-direct-superclasses class))
     (finalize-inheritance class)))
 
-(defmethod initialize-instance ((class class) &rest initargs
-				&key sealedp direct-superclasses direct-slots)
+(defmethod initialize-instance ((class class) &rest initargs &key direct-slots)
   (declare (ignore sealedp))
   ;; convert the slots from lists to direct slots
-  (setf direct-slots (loop for s in direct-slots
-                        collect (canonical-slot-to-direct-slot class s)))
+  (apply #'call-next-method class
+         :direct-slots
+	 (loop for s in direct-slots
+	    collect (canonical-slot-to-direct-slot class s))
+         initargs)
+  (finalize-unless-forward class)
+  class)
 
+(defmethod shared-initialize ((class class) slot-names &rest initargs &key direct-superclasses)
   ;; verify that the inheritance list makes sense
   (setf direct-superclasses
         (check-direct-superclasses class direct-superclasses))
-
-  (apply #'call-next-method class
-         :direct-slots direct-slots
-         :direct-superclasses direct-superclasses
-         initargs)
-
-  ;; record the inheritance in parents
-  (dolist (l (setf direct-superclasses (class-direct-superclasses class)))
-    (add-direct-subclass l class))
-
-  (finalize-unless-forward class)
-
+  (when (slot-boundp class 'direct-superclasses)
+    (loop for c in (class-direct-superclasses class)
+       unless (member c direct-superclasses :test #'eq)
+       do (remove-direct-subclass c class)))
+  (setf class (apply #'call-next-method class slot-names
+		     :direct-superclasses direct-superclasses
+		     initargs))
+  (loop for c in (class-direct-superclasses class)
+     do (add-direct-subclass c class))
   class)
 
 (defun precompute-valid-initarg-keywords (class)