-
Notifications
You must be signed in to change notification settings - Fork 19
/
closer-clozure.lisp
175 lines (150 loc) · 8.13 KB
/
closer-clozure.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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
(in-package :closer-mop)
(defclass standard-class (cl:standard-class) ())
(define-validate-superclass-method standard-class cl:standard-class)
(cl:defmethod reinitialize-instance :after ((class standard-class) &key)
(finalize-inheritance class))
;;; New generic functions.
;; Store the method function somewhere else, to circumvent
;; the native check for congruent lambda lists.
(defparameter *stub-method-functions* (make-hash-table :test #'equal))
(defun get-stub-method-function (lambda-list)
(or (gethash lambda-list *stub-method-functions*)
(let ((ignore-list (loop for arg in lambda-list
unless (member arg lambda-list-keywords)
collect (etypecase arg
(symbol arg)
(cons (etypecase (car arg)
(symbol (car arg))
(cons (assert (cdr arg))
(cadr arg))))))))
(setf (gethash lambda-list *stub-method-functions*)
(compile nil `(lambda ,lambda-list
(declare (ignore ,@ignore-list))
(error "This method function must not be called.")))))))
(cl:defmethod initialize-instance :around
((method standard-method) &rest initargs &key lambda-list function closer-patch)
(if closer-patch
(apply #'call-next-method method
:real-function function
:function (get-stub-method-function lambda-list)
initargs)
(apply #'call-next-method method
:real-function function
initargs)))
;; Adapt argument-precedence-order whenever the lambda list changes.
(cl:defmethod reinitialize-instance :around
((gf standard-generic-function) &rest initargs &key
(lambda-list '() lambda-list-p)
(argument-precedence-order '() argument-precedence-order-p))
(declare (ignore argument-precedence-order))
(if (and lambda-list-p (not argument-precedence-order-p))
(apply #'call-next-method gf
:argument-precedence-order (required-args lambda-list)
initargs)
(call-next-method)))
;; Ensure that the discriminating function is computed and installed
;; at the moments in time as stated in the CLOS MOP specification.
(cl:defmethod add-method :after ((gf standard-generic-function) method)
(declare (ignore method))
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
(cl:defmethod remove-method :after ((gf standard-generic-function) method)
(declare (ignore method))
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
(cl:defmethod initialize-instance :after ((gf standard-generic-function) &key)
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
(cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &key)
(set-funcallable-instance-function gf (compute-discriminating-function gf)))
;; Define compute-effective-method correctly.
(cl:defmethod compute-effective-method ((gf standard-generic-function)
(combination ccl:standard-method-combination)
methods)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(loop for method in methods
for qualifiers = (method-qualifiers method)
if (equal qualifiers '()) collect method into primary
else if (equal qualifiers '(:before)) collect method into before
else if (equal qualifiers '(:after)) collect method into after
else if (equal qualifiers '(:around)) collect method into around
else do (invalid-method-error method "Invalid method qualifiers ~S." qualifiers)
finally
(unless primary (method-combination-error "No primary method."))
(let ((form (if (or before after (rest primary))
`(multiple-value-prog1
(progn ,@(loop for method in before collect `(call-method ,method))
(call-method ,(first primary) ,(rest primary)))
,@(loop for method in (reverse after) collect `(call-method ,method)))
`(call-method ,(first primary)))))
(return
(if around
`(call-method ,(first around) (,@(rest around) (make-method ,form)))
form)))))
(cl:defmethod compute-effective-method ((gf standard-generic-function)
(combination ccl:short-method-combination)
methods)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(loop with primary-qualifiers = (list (ccl::method-combination-name combination))
for method in methods
for qualifiers = (method-qualifiers method)
if (equal qualifiers primary-qualifiers) collect method into primary
else if (equal qualifiers '(:around)) collect method into around
else do (invalid-method-error method "Invalid method qualifiers ~S." qualifiers)
finally
(unless primary (method-combination-error "No primary method."))
(when (eq (car (ccl::method-combination-options combination))
:most-specific-last)
(setq primary (nreverse primary)))
(let ((form (if (and (ccl::method-combination-identity-with-one-argument combination)
(null (rest primary)))
`(call-method ,(first primary))
`(,(ccl::method-combination-operator combination)
,@(loop for method in primary collect `(call-method ,method))))))
(return
(if around
`(call-method ,(first around) (,@(rest around) (make-method ,form)))
form)))))
(cl:defmethod compute-effective-method ((gf standard-generic-function)
(combination ccl:long-method-combination)
methods)
(declare (optimize (speed 3) (space 0) (compilation-speed 0)))
(destructuring-bind ((args-var . gf-name) . expander)
(ccl::method-combination-expander combination)
(declare (ignore args-var gf-name))
(funcall expander gf methods (ccl::method-combination-options combination))))
;; "Native" make-method-lambda.
(cl:defmethod make-method-lambda ((gf generic-function) (method method) lambda-expression environment)
(declare (ignore environment) (optimize (speed 3) (space 0) (compilation-speed 0)))
(multiple-value-bind (documentation declarations body)
(parse-method-body (cddr lambda-expression) lambda-expression)
(let ((methvar (gensym)))
(values
`(lambda (ccl::&method ,methvar ,@(cadr lambda-expression))
,@(when documentation `(,documentation))
,@(when declarations `((declare ,@declarations)))
(flet ((call-next-method (&rest args)
(if args
(apply #'ccl::%call-next-method-with-args ,methvar args)
(ccl::%call-next-method ,methvar)))
(next-method-p () (ccl::%next-method-p ,methvar)))
(declare (inline call-next-method next-method-p))
,@body))
(when documentation
(list :documentation documentation))))))
;; "Native" compute-discriminating-function.
(cl:defmethod compute-discriminating-function ((gf generic-function))
(let ((non-dt-dcode (ccl::non-dt-dcode-function gf)))
(if non-dt-dcode
non-dt-dcode
(let* ((std-dfun (ccl::%gf-dcode gf))
(dt (ccl::%gf-dispatch-table gf))
(proto (cdr (assoc std-dfun ccl::dcode-proto-alist))))
(if (or (eq proto #'ccl::gag-one-arg)
(eq proto #'ccl::gag-two-arg))
(lambda (&rest args)
(apply std-dfun dt args))
(lambda (&rest args)
(funcall std-dfun dt args)))))))
;; The following ensures that slot definitions have a documentation.
(cl:defmethod documentation ((slot slot-definition) (type (eql 't)))
(ccl:slot-definition-documentation slot))
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :closer-mop *features*))