From 2dd79e9c78422d1d2d2079fedd7444691c08df99 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@users.sourceforge.net>
Date: Sat, 21 Apr 2012 21:55:49 +0200
Subject: [PATCH] Simplify the use of UPDATE-DEPENDENT, incorporating it into
 the core methods, instead of using :AFTER. This eliminates problems with
 non-compliant code redefining SHARED-INITIALIZE and friends.

---
 src/clos/fixup.lsp    | 73 +++++++++++++++++--------------------------
 src/clos/generic.lsp  |  1 +
 src/clos/standard.lsp |  5 +++
 3 files changed, 35 insertions(+), 44 deletions(-)

diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp
index 1180b5335..1a4d54bb5 100644
--- a/src/clos/fixup.lsp
+++ b/src/clos/fixup.lsp
@@ -77,36 +77,6 @@
   (declare (ignore class direct-slot initargs))
   (find-class 'standard-writer-method))
 
-;;; ----------------------------------------------------------------------
-;;; DEPENDENT MAINTENANCE PROTOCOL
-;;;
-
-(defmethod add-dependent ((c class) dep)
-  (pushnew dep (class-dependents c)))
-
-(defmethod add-dependent ((c generic-function) dependent)
-  (pushnew dependent (generic-function-dependents c)))
-
-(defmethod remove-dependent ((c class) dep)
-  (setf (class-dependents c)
-        (remove dep (class-dependents c))))
-
-(defmethod remove-dependent ((c standard-generic-function) dep)
-  (setf (generic-function-dependents c)
-        (remove dep (generic-function-dependents c))))
-
-(defmethod map-dependents ((c class) function)
-  (dolist (d (class-dependents c))
-    (funcall function c)))
-
-(defmethod map-dependents ((c standard-generic-function) function)
-  (dolist (d (generic-function-dependents c))
-    (funcall function c)))
-
-(defmethod update-dependent ((object t) (dependents t) &rest initargs)
-  ;; By default UPDATE-DEPENDENT does nothing
-  )
-
 ;;; ----------------------------------------------------------------------
 ;;; Fixup
 
@@ -230,6 +200,8 @@ their lambda lists ~A and ~A are not congruent."
   ;;  the same one, we just update the spec-how list of the generic function.
   (compute-g-f-spec-list gf)
   (set-generic-function-dispatch gf)
+  ;;  iv) Update dependents.
+  (update-dependents gf (list 'add-method method))
   ;;
   gf)
 
@@ -247,6 +219,7 @@ their lambda lists ~A and ~A are not congruent."
 	(delete method (generic-function-methods gf))
 	(method-generic-function method) nil)
   (si:clear-gfun-hash gf)
+  (update-dependents gf (list 'remove-method method))
   gf)
 
 (function-to-method 'add-method '((gf standard-generic-function)
@@ -319,21 +292,36 @@ their lambda lists ~A and ~A are not congruent."
   new-value)
 )
 
-(defun update-dependents-with-initargs (object initargs)
-  (declare (si::c-local))
-  (map-dependents object #'(lambda (dep) (apply #'update-dependent object dep initargs))))
+;;; ----------------------------------------------------------------------
+;;; DEPENDENT MAINTENANCE PROTOCOL
+;;;
 
-(defmethod reinitialize-instance :after ((object class) &rest initargs)
-  (update-dependents-with-initargs object initargs))
+(defmethod add-dependent ((c class) dep)
+  (pushnew dep (class-dependents c)))
 
-(defmethod reinitialize-instance :after ((object standard-generic-function) &rest initargs)
-  (update-dependents-with-initargs object initargs))
+(defmethod add-dependent ((c generic-function) dependent)
+  (pushnew dependent (generic-function-dependents c)))
 
-(defmethod add-method :after ((gf standard-generic-function) method)
-  (update-dependents-with-initargs gf (list 'add-method method)))
+(defmethod remove-dependent ((c class) dep)
+  (setf (class-dependents c)
+        (remove dep (class-dependents c))))
 
-(defmethod remove-method :after ((gf standard-generic-function) method)
-  (update-dependents-with-initargs gf (list 'remove-method method)))
+(defmethod remove-dependent ((c standard-generic-function) dep)
+  (setf (generic-function-dependents c)
+        (remove dep (generic-function-dependents c))))
+
+(defmethod map-dependents ((c class) function)
+  (dolist (d (class-dependents c))
+    (funcall function d)))
+
+(defmethod map-dependents ((c standard-generic-function) function)
+  (dolist (d (generic-function-dependents c))
+    (funcall function d)))
+
+(defgeneric update-dependent (object dependent &rest initargs))
+
+;; After this, update-dependents will work
+(setf *clos-booted* 'map-dependents)
 
 (defclass initargs-updater ()
   ())
@@ -351,6 +339,3 @@ their lambda lists ~A and ~A are not congruent."
   (add-dependent #'shared-initialize x)
   (add-dependent #'initialize-instance x)
   (add-dependent #'allocate-instance x))
-
-(setf *clos-booted* 'map-dependents)
-
diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp
index 505d1c4d4..9b0681410 100644
--- a/src/clos/generic.lsp
+++ b/src/clos/generic.lsp
@@ -177,6 +177,7 @@
   (declare (ignore initargs slot-names))
   (call-next-method)
   (compute-g-f-spec-list gfun)
+  (update-dependents gfun initargs)
   gfun)
 
 (defun associate-methods-to-gfun (gfun &rest methods)
diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp
index 706c8eef1..23df6ab97 100644
--- a/src/clos/standard.lsp
+++ b/src/clos/standard.lsp
@@ -194,6 +194,10 @@
            return t
            append k)))
 
+(defun update-dependents (object initargs)
+  (when *clos-booted*
+    (map-dependents object #'(lambda (dep) (apply #'update-dependent object dep initargs)))))
+
 (defmethod shared-initialize ((class std-class) slot-names &rest initargs &key
                               (optimize-slot-access (list *optimize-slot-access*))
                               sealedp)
@@ -201,6 +205,7 @@
   (setf (slot-value class 'optimize-slot-access) (first optimize-slot-access)
 	(slot-value class 'sealedp) (and sealedp t))
   (setf class (call-next-method))
+  (update-dependents class initargs)
   class)
 
 (defmethod add-direct-subclass ((parent class) child)