-
Notifications
You must be signed in to change notification settings - Fork 19
/
Copy pathcloser-scl.lisp
56 lines (45 loc) · 2.45 KB
/
closer-scl.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
(in-package :closer-mop)
(defgeneric add-direct-method (specializer method)
(:method ((specializer standard-object) (method method))))
(defgeneric remove-direct-method (specializer method)
(:method ((specializer standard-object) (method method))))
(defvar *dependents* (make-hash-table :test #'eq))
(defgeneric add-dependent (metaobject dependent)
(:method ((metaobject standard-class) dependent)
(pushnew dependent (gethash metaobject *dependents*)))
(:method ((metaobject funcallable-standard-class) dependent)
(pushnew dependent (gethash metaobject *dependents*)))
(:method ((metaobject standard-generic-function) dependent)
(pushnew dependent (gethash metaobject *dependents*))))
(defgeneric remove-dependent (metaobject dependent)
(:method ((metaobject standard-class) dependent)
(setf (gethash metaobject *dependents*)
(delete metaobject (gethash metaobject *dependents*))))
(:method ((metaobject funcallable-standard-class) dependent)
(setf (gethash metaobject *dependents*)
(delete metaobject (gethash metaobject *dependents*))))
(:method ((metaobject standard-generic-function) dependent)
(setf (gethash metaobject *dependents*)
(delete metaobject (gethash metaobject *dependents*)))))
(defgeneric map-dependents (metaobject function)
(:method ((metaobject standard-class) function)
(mapc function (gethash metaobject *dependents*)))
(:method ((metaobject funcallable-standard-class) function)
(mapc function (gethash metaobject *dependents*)))
(:method ((metaobject standard-generic-function) function)
(mapc function (gethash metaobject *dependents*))))
(defgeneric update-dependent (metaobject dependent &rest initargs))
(defmethod reinitialize-instance :after ((metaobject metaobject) &rest initargs)
(map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))
(defmethod add-method :after
((gf standard-generic-function) method)
(loop for specializer in (method-specializers method)
do (add-direct-method specializer method))
(map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method))))
(defmethod remove-method :after
((gf standard-generic-function) method)
(loop for specializer in (method-specializers method)
do (remove-direct-method specializer method))
(map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))