diff --git a/src/CHANGELOG b/src/CHANGELOG index 667d4b3b2..933d2cfbe 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -9,6 +9,8 @@ ECL 12.2.2: - :CDECL was not accepted as an FFI declaration due to a typo. + - REMOVE-METHOD was not a generic function. + * Visible changes: - DIRECTORY no longer complains when it finds an inexistent directory @@ -33,6 +35,10 @@ ECL 12.2.2: - Implemented and used in the core: VALIDATE-SUPERCLASSES + - UPDATE-DEPENDENT, MAP-DEPENDENTS and related functions have been fixed. They + are now invoked by REMOVE-METHOD and REINITIALIZE-INSTANCE, when acting on + generic functions, standard classes, etc. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/clos/change.lsp b/src/clos/change.lsp index a9a9b231c..8fb7f7b5b 100644 --- a/src/clos/change.lsp +++ b/src/clos/change.lsp @@ -198,10 +198,6 @@ (setf (class-finalized-p class) nil) (finalize-unless-forward class) - ;; Now we can call the dependents - (map-dependents class #'(lambda (dep) - (apply #'update-dependent class dep initargs))) - class) (defmethod make-instances-obsolete ((class class)) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index ccef23788..1180b5335 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -77,6 +77,36 @@ (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 @@ -201,9 +231,6 @@ their lambda lists ~A and ~A are not congruent." (compute-g-f-spec-list gf) (set-generic-function-dispatch gf) ;; - ;; Finally update the dependent objects - (map-dependents gf #'(lambda (dep) (update-dependents gf dep 'add-method method))) - ;; gf) (defun function-to-method (name signature) @@ -215,17 +242,18 @@ their lambda lists ~A and ~A are not congruent." (setf (generic-function-name generic-function) name) (fmakunbound aux-name))) -(function-to-method 'add-method '((gf standard-generic-function) - (method standard-method))) - (defun remove-method (gf method) (setf (generic-function-methods gf) (delete method (generic-function-methods gf)) (method-generic-function method) nil) (si:clear-gfun-hash gf) - (map-dependents gf #'(lambda (dep) (update-dependents gf dep 'remove-method method))) gf) +(function-to-method 'add-method '((gf standard-generic-function) + (method standard-method))) +(function-to-method 'remove-method '((gf standard-generic-function) + (method standard-method))) + ;;; COMPUTE-APPLICABLE-METHODS is used by the core in various places, ;;; including instance initialization. This means we cannot just redefine it. ;;; Instead, we create an auxiliary function and move definitions from one to @@ -268,6 +296,8 @@ their lambda lists ~A and ~A are not congruent." (error "In method ~A~%No next method given arguments ~A" method args)) (defun no-primary-method (gf &rest args) + (print gf) + (print args) (error "Generic function: ~A. No primary method given arguments: ~S" (generic-function-name gf) args)) @@ -289,30 +319,21 @@ their lambda lists ~A and ~A are not congruent." new-value) ) -;;; ---------------------------------------------------------------------- -;;; DEPENDENT MAINTENANCE PROTOCOL -;;; +(defun update-dependents-with-initargs (object initargs) + (declare (si::c-local)) + (map-dependents object #'(lambda (dep) (apply #'update-dependent object dep initargs)))) -(function-to-method 'map-dependents '((c standard-generic-function) function)) +(defmethod reinitialize-instance :after ((object class) &rest initargs) + (update-dependents-with-initargs object initargs)) -(defmethod map-dependents ((c class) function) - (dolist (d (class-dependents c)) - (funcall function c))) +(defmethod reinitialize-instance :after ((object standard-generic-function) &rest initargs) + (update-dependents-with-initargs object initargs)) -(function-to-method 'add-dependent '((c standard-generic-function) function)) +(defmethod add-method :after ((gf standard-generic-function) method) + (update-dependents-with-initargs gf (list 'add-method method))) -(defmethod add-dependent ((c class) dep) - (pushnew dep (class-dependents c))) - -(defmethod remove-dependent ((c standard-generic-function) dep) - (setf (generic-function-dependents c) - (remove dep (generic-function-dependents c)))) - -(defmethod remove-dependent ((c class) dep) - (setf (class-dependents c) - (remove dep (class-dependents c)))) - -(defgeneric update-dependents (object dependents &rest initargs)) +(defmethod remove-method :after ((gf standard-generic-function) method) + (update-dependents-with-initargs gf (list 'remove-method method))) (defclass initargs-updater () ()) @@ -321,14 +342,15 @@ their lambda lists ~A and ~A are not congruent." (slot-makunbound a-class 'valid-initargs) (mapc #'recursively-update-classes (class-direct-subclasses a-class))) -(defmethod update-dependents ((object generic-function) (dep initargs-updater) - &rest initargs) +(defmethod update-dependent ((object generic-function) (dep initargs-updater) + &rest initargs) (declare (ignore dep initargs object)) (recursively-update-classes +the-class+)) -(setf *clos-booted* 'built-in-class) - (let ((x (make-instance 'initargs-updater))) (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/kernel.lsp b/src/clos/kernel.lsp index 9fd67cc8a..86cef6967 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -212,17 +212,6 @@ ;;; ---------------------------------------------------------------------- ;;; early versions -(defun map-dependents (c function) - (dolist (d (if (classp c) - (class-dependents c) - (generic-function-dependents c))) - (funcall function d))) - -(defun add-dependent (c d) - (if (classp c) - (pushnew d (class-dependents c)) - (pushnew d (generic-function-dependents c)))) - ;;; early version used during bootstrap (defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p)) (if (and (fboundp name) (si::instancep (fdefinition name))) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 9a234b478..314943a44 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -324,8 +324,6 @@ have disappeared." (rest (si::process-lambda-list (method-lambda-list method) t)))) (compute-g-f-spec-list gf) (set-generic-function-dispatch gf) - (dolist (d (generic-function-dependents gf)) - (update-dependent gf d 'add-method method)) method)) (defun find-method (gf qualifiers specializers &optional (errorp t))