From 46671dfbe4298ca3db72760f9d4fc63e21ffe357 Mon Sep 17 00:00:00 2001
From: Alexander Gavrilov <angavrilov@gmail.com>
Date: Mon, 2 Nov 2009 20:58:42 +0300
Subject: [PATCH] Fix propagation of class finalization.

Instead of calling reinitialize-instance, directly
invoke finalize on the subclasses. Also remove subclass
links from parents when the superclass list is changed.
---
 src/clos/change.lsp   | 18 ++++++++++++------
 src/clos/standard.lsp | 10 ++++++----
 2 files changed, 18 insertions(+), 10 deletions(-)

diff --git a/src/clos/change.lsp b/src/clos/change.lsp
index 3d1bb83cf..8eed2ab25 100644
--- a/src/clos/change.lsp
+++ b/src/clos/change.lsp
@@ -165,7 +165,8 @@
 			 :lambda-list '(class &rest initargs))
 
 (defmethod reinitialize-instance ((class class) &rest initargs
-				  &key direct-superclasses (direct-slots nil direct-slots-p))
+				  &key (direct-superclasses () direct-superclasses-p)
+				       (direct-slots nil direct-slots-p))
   (let ((name (class-name class)))
     (when (member name '(CLASS BUILT-IN-CLASS) :test #'eq)
       (error "The kernel CLOS class ~S cannot be changed." name)))
@@ -183,14 +184,19 @@
 		collect (canonical-slot-to-direct-slot class s))))
 
   ;; set up inheritance checking that it makes sense
-  (dolist (l (setf (class-direct-superclasses class)
-		   (check-direct-superclasses class direct-superclasses)))
-    (add-direct-subclass l class))
+  (when direct-superclasses-p
+    (setf direct-superclasses 
+          (check-direct-superclasses class direct-superclasses))
+    (dolist (l (class-direct-superclasses class))
+      (unless (member l direct-superclasses)
+        (remove-direct-subclass l class)))
+    (dolist (l (setf (class-direct-superclasses class)
+		     direct-superclasses))
+      (add-direct-subclass l class)))
 
   ;; if there are no forward references, we can just finalize the class here
   (setf (class-finalized-p class) nil)
-  (unless (find-if #'forward-referenced-class-p (class-direct-superclasses class))
-    (finalize-inheritance class))
+  (finalize-unless-forward class)
 
   class)
 
diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp
index ce0aa002e..f954136f8 100644
--- a/src/clos/standard.lsp
+++ b/src/clos/standard.lsp
@@ -143,6 +143,10 @@
 (defmethod effective-slot-definition-class ((class T) &rest canonicalized-slot)
   (find-class 'standard-effective-slot-definition nil))
 
+(defun finalize-unless-forward (class)
+  (unless (find-if #'forward-referenced-class-p (class-direct-superclasses class))
+    (finalize-inheritance class)))
+
 (defmethod initialize-instance ((class class) &rest initargs
 				&key sealedp direct-superclasses direct-slots)
   ;; convert the slots from lists to direct slots
@@ -162,8 +166,7 @@
   (dolist (l (setf direct-superclasses (class-direct-superclasses class)))
     (add-direct-subclass l class))
 
-  (unless (find-if #'forward-referenced-class-p direct-superclasses)
-      (finalize-inheritance class))
+  (finalize-unless-forward class)
 
   class)
 
@@ -293,8 +296,7 @@ because it contains a reference to the undefined class~%  ~A"
   ;; invoking FINALIZE-INHERITANCE on all of its children. Obviously,
   ;; this only makes sense when the class has been defined.
   (dolist (subclass (reverse (class-direct-subclasses class)))
-    (reinitialize-instance subclass
-			   :direct-superclasses (class-direct-superclasses subclass)))
+    (finalize-unless-forward subclass))
   )
 
 (defun std-create-slots-table (class)