96
98
,@(and class-declarations `((declare ,@class-declarations)))
100
(applyp nil) ; flag indicating whether or not the
101
; method takes &mumble arguments. If
102
; it does, it means call-next-method
103
; without arguments must be APPLY'd
104
; to original-args. If this gets set
105
; true, save-original-args is set so
107
101
(aux-bindings ()) ; Suffice to say that &aux is one of
108
102
; damndest things to have put in a
111
(multiple-value-bind (walked-lambda call-next-method-p
112
save-original-args next-method-p-p)
105
(multiple-value-bind (call-next-method-p next-method-p-p in-closure-p)
113
106
(walk-method-lambda method-lambda required-parameters env)
115
;; Scan the lambda list to determine whether this method
116
;; takes &mumble arguments. If it does, we set applyp and
117
;; save-original-args true.
119
;; This is also the place where we construct the original
120
;; arguments lambda list if there has to be one.
121
(dolist (p lambda-list)
122
(if (member p '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX)
123
:test #'eq) ; cant use lambda-list-keywords
126
(setq aux-bindings (cdr (member '&AUX lambda-list
131
save-original-args t)
132
(push '&REST original-args)
133
(push (make-symbol "AMPERSAND-ARGS") original-args)
135
(push (make-symbol (symbol-name p)) original-args)))
136
(setq original-args (when save-original-args
137
(nreverse original-args)))
139
(multiple-value-bind (walked-declarations walked-lambda-body)
140
(sys::find-declarations (cdddr walked-lambda) t)
141
(declare (ignore ignore))
143
(when (or next-method-p-p call-next-method-p)
144
(setq plist (list* :needs-next-methods-p 'T plist)))
147
(let ((walked-lambda `(ext::lambda-block ,(second walked-lambda)
149
,@walked-declarations
150
,.walked-lambda-body)))
151
(if (or call-next-method-p next-method-p-p)
152
`(function ,(add-lexical-functions-to-method-lambda
155
generic-function-name
164
`(function ,walked-lambda)))
108
(when (or call-next-method-p next-method-p-p)
109
(setf plist '(:needs-next-method-p t)))
112
(setf plist '(:needs-next-method-p FUNCTION))
114
`((let* ((.combined-method-args.
115
(if (listp .combined-method-args.)
116
.combined-method-args.
117
(apply #'list .combined-method-args.)))
118
(.next-methods. *next-methods*))
119
(flet ((call-next-method (&rest args)
120
(unless .next-methods.
121
(error "No next method"))
122
(funcall (car .next-methods.)
123
(or args .combined-method-args.)
124
(rest .next-methods.)))
129
`(ext::lambda-block ,generic-function-name
131
,@(and class-declarations `((declare ,@class-declarations)))
136
(defun environment-contains-closure (env)
138
;; As explained in compiler.d (make_lambda()), we use a symbol with name
139
;; "FUNCTION" to mark the beginning of a function. If we find that symbol
140
;; twice, it is quite likely that this form will end up in a closure.
142
(flet ((function-boundary (s)
144
(symbolp (setf s (first s)))
145
(null (symbol-package s))
146
(equal (symbol-name s) "FUNCTION"))))
147
(> (count-if #'function-boundary (car env)) 1)))
168
149
(defun walk-method-lambda (method-lambda required-parameters env)
169
150
(declare (si::c-local))
170
151
(let ((call-next-method-p nil)
171
152
(next-method-p-p nil)
172
(save-original-args-p nil))
173
154
(flet ((code-walker (form env)
174
155
(unless (atom form)
175
156
(let ((name (first form)))
177
158
(CALL-NEXT-METHOD
178
159
(setf call-next-method-p
179
(or call-next-method-p T))
181
(setf save-original-args-p t)))
160
(or call-next-method-p T)
162
(or in-closure-p (environment-contains-closure env))))
183
(setf next-method-p-p t))
164
(setf next-method-p-p t
165
in-closure-p (or in-closure-p (environment-contains-closure env))))
185
167
(when (eq (second form) 'CALL-NEXT-METHOD)
186
(setf save-original-args-p t
187
169
call-next-method-p 'FUNCTION))
188
170
(when (eq (second form) 'NEXT-METHOD-P)
189
(setf next-method-p-p 'FUNCTION))))))
171
(setf next-method-p-p 'FUNCTION
191
174
(let ((si::*code-walker* #'code-walker))
192
175
(coerce method-lambda 'function)))
193
(values method-lambda call-next-method-p
197
(defun add-lexical-functions-to-method-lambda (walked-declarations
199
generic-function-name
208
(declare (si::c-local))
210
;; WARNING: these &rest/apply combinations produce useless garbage. Beppe
212
(cond ((and (null save-original-args)
215
;; We don't have to save the original arguments. In addition,
216
;; this method doesn't take any &mumble arguments (this means
217
;; that there is no way the lexical functions can be used inside
218
;; of the default value form for an &mumble argument).
220
;; We can expand this into a simple lambda expression with an
221
;; FLET to define the lexical functions.
223
`(ext::lambda-block ,generic-function-name ,lambda-list
224
,@walked-declarations
225
(declare (special *next-methods*))
226
(let* ((.next-method. (car *next-methods*))
227
(*next-methods* (cdr *next-methods*)))
228
(declare (special *next-methods*))
229
(flet (,@(and call-next-method-p
230
'((CALL-NEXT-METHOD (&REST CNM-ARGS)
231
;; (declare (static-extent cnm-args))
233
(APPLY .NEXT-METHOD. CNM-ARGS)
234
(ERROR "No next method.")))))
235
,@(and next-method-p-p
237
(NOT (NULL .NEXT-METHOD.))))))
238
,@walked-lambda-body)))
239
;; Assuming that we can determine statically which is the next method,
240
;; we could use this solution. Compute-effective-method can set
241
;; the value of .next-method. within each closure at the appropriate
242
;; value. Same thing for next case. Beppe
243
;; `(let (.next-method.)
244
;; (lambda ,lambda-list
245
;; ,@walked-declarations
246
;; (flet (,@(and call-next-method-p
247
;; '((CALL-NEXT-METHOD (&REST CNM-ARGS)
248
;; ;; (declare (static-extent cnm-args))
250
;; (APPLY .NEXT-METHOD. CNM-ARGS)
251
;; (ERROR "No next method.")))))
252
;; ,@(and next-method-p-p
253
;; '((NEXT-METHOD-P ()
254
;; (NOT (NULL .NEXT-METHOD.))))))
255
;; ,@walked-lambda-body)))
259
;; This method doesn't accept any &mumble arguments. But we
260
;; do have to save the original arguments (this is because
261
;; call-next-method is being called with no arguments).
262
;; Have to be careful though, there may be multiple calls to
263
;; call-next-method, all we know is that at least one of them
264
;; is with no arguments.
266
`(ext::lambda-block ,generic-function-name ,original-args
267
(declare (special *next-methods*))
268
(let* ((.next-method. (car *next-methods*))
269
(*next-methods* (cdr *next-methods*)))
270
(declare (special *next-methods*))
271
(flet (,@(and call-next-method-p
272
`((call-next-method (&rest cnm-args)
273
;; (declare (static-extent cnm-args))
276
(apply .next-method. cnm-args)
277
(funcall .next-method. ,@original-args))
278
(error "No next method.")))))
279
,@(and next-method-p-p
281
(NOT (NULL .NEXT-METHOD.))))))
282
(let* (,@(mapcar #'list
283
(subseq lambda-list 0
284
(position '&AUX lambda-list))
287
,@walked-declarations
288
,@walked-lambda-body)))))
291
;; This is the fully general case.
292
;; We must allow for the lexical functions being used inside
293
;; the default value forms of &mumble arguments, and if must
294
;; allow for call-next-method being called with no arguments.
296
`(lambda ,original-args
297
(declare (special *next-methods*))
298
(let* ((.next-method. (car *next-methods*))
299
(*next-methods* (cdr *next-methods*)))
300
(declare (special *next-methods*))
301
(flet (,@(and call-next-method-p
302
`((call-next-method (&rest cnm-args)
303
;; (declare (static-extent cnm-args))
306
(apply .next-method. cnm-args)
308
,@(remove '&REST original-args)))
309
(error "No next method.")))))
310
,@(and next-method-p-p
312
(NOT (NULL .NEXT-METHOD.))))))
313
(apply (function ,walked-lambda)
314
,@(remove '&REST original-args))))))))
176
(values call-next-method-p
317
180
;;; ----------------------------------------------------------------------
added
removed
src/clos/method.lsp
