mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-15 05:43:19 -08:00
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.
This commit is contained in:
parent
94454151a8
commit
2dd79e9c78
3 changed files with 35 additions and 44 deletions
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue