1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
26 (defun get-method-function (method &optional method-alist wrappers)
27 (let ((fn (cadr (assoc method method-alist))))
29 (values fn nil nil nil)
30 (multiple-value-bind (mf fmf)
32 (early-method-function method)
33 (values nil (method-fast-function method)))
34 (let* ((pv-table (and fmf (method-function-pv-table fmf))))
35 (if (and fmf (or (null pv-table) wrappers))
36 (let* ((pv-wrappers (when pv-table
37 (pv-wrappers-from-all-wrappers
39 (pv-cell (when (and pv-table pv-wrappers)
40 (pv-table-lookup pv-table pv-wrappers))))
41 (values mf t fmf pv-cell))
43 (or mf (if (listp method)
45 (method-function-from-fast-function fmf))
46 (method-function method)))
49 (defun make-effective-method-function (generic-function form &optional
50 method-alist wrappers)
51 (funcall (make-effective-method-function1 generic-function form
52 (not (null method-alist))
53 (not (null wrappers)))
54 method-alist wrappers))
56 (defun make-effective-method-function1 (generic-function form
57 method-alist-p wrappers-p)
59 (eq (car form) 'call-method))
60 (make-effective-method-function-simple generic-function form)
61 ;; We have some sort of `real' effective method. Go off and get a
62 ;; compiled function for it. Most of the real hair here is done by
63 ;; the GET-FUN mechanism.
64 (make-effective-method-function-internal generic-function form
65 method-alist-p wrappers-p)))
67 (defun make-effective-method-fun-type (generic-function
72 (eq (car form) 'call-method))
73 (let* ((cm-args (cdr form))
74 (method (car cm-args)))
76 (if (if (listp method)
77 (eq (car method) :early-method)
81 (multiple-value-bind (mf fmf)
83 (early-method-function method)
84 (values nil (method-fast-function method)))
86 (let* ((pv-table (and fmf (method-function-pv-table fmf))))
87 (if (and fmf (or (null pv-table) wrappers-p))
90 (if (and (consp method) (eq (car method) 'make-method))
91 (make-effective-method-fun-type
92 generic-function (cadr method) method-alist-p wrappers-p)
96 (defun make-effective-method-function-simple
97 (generic-function form &optional no-fmf-p)
98 ;; The effective method is just a call to CALL-METHOD. This opens up
99 ;; the possibility of just using the method function of the method as
100 ;; the effective method function.
102 ;; But we have to be careful. If that method function will ask for
103 ;; the next methods we have to provide them. We do not look to see
104 ;; if there are next methods, we look at whether the method function
105 ;; asks about them. If it does, we must tell it whether there are
106 ;; or aren't to prevent the leaky next methods bug.
107 (let* ((cm-args (cdr form))
108 (fmf-p (and (null no-fmf-p)
109 (or (not (eq *boot-state* 'complete))
110 (gf-fast-method-function-p generic-function))
111 (null (cddr cm-args))))
112 (method (car cm-args))
113 (cm-args1 (cdr cm-args)))
114 (lambda (method-alist wrappers)
115 (make-effective-method-function-simple1 generic-function
122 (defun make-emf-from-method
123 (method cm-args &optional gf fmf-p method-alist wrappers)
124 (multiple-value-bind (mf real-mf-p fmf pv-cell)
125 (get-method-function method method-alist wrappers)
127 (let* ((next-methods (car cm-args))
128 (next (make-effective-method-function-simple1
129 gf (car next-methods)
130 (list* (cdr next-methods) (cdr cm-args))
131 fmf-p method-alist wrappers))
132 (arg-info (method-function-get fmf :arg-info)))
133 (make-fast-method-call :function fmf
135 :next-method-call next
138 (make-method-call :function mf
139 :call-method-args cm-args)
142 (defun make-effective-method-function-simple1
143 (gf method cm-args fmf-p &optional method-alist wrappers)
145 (if (if (listp method)
146 (eq (car method) :early-method)
148 (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
149 (if (and (consp method) (eq (car method) 'make-method))
150 (make-effective-method-function gf
152 method-alist wrappers)
155 (defvar *global-effective-method-gensyms* ())
156 (defvar *rebound-effective-method-gensyms*)
158 (defun get-effective-method-gensym ()
159 (or (pop *rebound-effective-method-gensyms*)
160 (let ((new (intern (format nil
161 "EFFECTIVE-METHOD-GENSYM-~D"
162 (length *global-effective-method-gensyms*))
164 (setq *global-effective-method-gensyms*
165 (append *global-effective-method-gensyms* (list new)))
168 (let ((*rebound-effective-method-gensyms* ()))
169 (dotimes-fixnum (i 10) (get-effective-method-gensym)))
171 (defun expand-effective-method-function (gf effective-method &optional env)
172 (declare (ignore env))
173 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
174 (get-generic-fun-info gf)
175 (declare (ignore nreq nkeys arg-info))
176 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
177 (check-applicable-keywords
178 (when (and applyp (gf-requires-emf-keyword-checks gf))
179 '((check-applicable-keywords))))
180 (error-p (or (eq (first effective-method) '%no-primary-method)
181 (eq (first effective-method) '%invalid-qualifiers)))
183 (when (eq *boot-state* 'complete)
184 ;; Otherwise the METHOD-COMBINATION slot is not bound.
185 (let ((combin (generic-function-method-combination gf)))
186 (and (long-method-combination-p combin)
187 (long-method-combination-args-lambda-list combin))))))
190 `(lambda (.pv-cell. .next-method-call. &rest .args.)
191 (declare (ignore .pv-cell. .next-method-call.))
192 (declare (ignorable .args.))
193 (flet ((%no-primary-method (gf args)
194 (apply #'no-primary-method gf args))
195 (%invalid-qualifiers (gf combin method)
196 (invalid-qualifiers gf combin method)))
197 (declare (ignorable #'%no-primary-method #'%invalid-qualifiers))
201 ;; FIXME: Ick. Shared idiom, too, with stuff in cache.lisp
203 (dotimes (i (length metatypes) (nreverse req))
204 (push (dfun-arg-symbol i) req))))
206 `(list* ,@required .dfun-rest-arg.)
207 `(list ,@required))))
209 (declare (ignore .pv-cell. .next-method-call.))
210 (let ((.gf-args. ,gf-args))
211 (declare (ignorable .gf-args.))
212 ,@check-applicable-keywords
213 ,effective-method))))
216 (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
217 ,@check-applicable-keywords
218 ,effective-method))))))
220 (defun expand-emf-call-method (gf form metatypes applyp env)
221 (declare (ignore gf metatypes applyp env))
222 `(call-method ,(cdr form)))
224 (defmacro call-method (&rest args)
225 (declare (ignore args))
226 `(error "~S outside of a effective method form" 'call-method))
228 (defun make-effective-method-list-fun-type
229 (generic-function form method-alist-p wrappers-p)
230 (if (every (lambda (form)
231 (eq 'fast-method-call
232 (make-effective-method-fun-type
233 generic-function form method-alist-p wrappers-p)))
238 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
239 (case (and (consp form) (car form))
241 (case (make-effective-method-fun-type
242 generic-function form method-alist-p wrappers-p)
243 (fast-method-call '.fast-call-method.)
246 (case (make-effective-method-list-fun-type
247 generic-function form method-alist-p wrappers-p)
248 (fast-method-call '.fast-call-method-list.)
249 (t '.call-method-list.)))
250 (check-applicable-keywords 'check-applicable-keywords)
251 (t (default-test-converter form))))
253 ;;; CMUCL comment (2003-10-15):
255 ;;; This function is called via the GET-FUNCTION mechanism on forms
256 ;;; of an emf lambda. First value returned replaces FORM in the emf
257 ;;; lambda. Second value is a list of variable names that become
258 ;;; closure variables.
259 (defun memf-code-converter
260 (form generic-function metatypes applyp method-alist-p wrappers-p)
261 (case (and (consp form) (car form))
263 (let ((gensym (get-effective-method-gensym)))
264 (values (make-emf-call
265 metatypes applyp gensym
266 (make-effective-method-fun-type
267 generic-function form method-alist-p wrappers-p))
270 (let ((gensym (get-effective-method-gensym))
271 (type (make-effective-method-list-fun-type
272 generic-function form method-alist-p wrappers-p)))
273 (values `(dolist (emf ,gensym nil)
274 ,(make-emf-call metatypes applyp 'emf type))
276 (check-applicable-keywords
277 (values `(check-applicable-keywords
278 .dfun-rest-arg. .keyargs-start. .valid-keys.)
279 '(.keyargs-start. .valid-keys.)))
282 (default-code-converter form))))
284 (defun memf-constant-converter (form generic-function)
285 (case (and (consp form) (car form))
288 (make-effective-method-function-simple
289 generic-function form))))
291 (list (cons '.meth-list.
292 (mapcar (lambda (form)
293 (make-effective-method-function-simple
294 generic-function form))
296 (check-applicable-keywords
297 '(.keyargs-start. .valid-keys.))
299 (default-constant-converter form))))
301 (defvar *applicable-methods*)
302 (defun make-effective-method-function-internal
303 (generic-function effective-method method-alist-p wrappers-p)
304 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
305 (get-generic-fun-info generic-function)
306 (declare (ignore nkeys arg-info))
307 (let* ((*rebound-effective-method-gensyms*
308 *global-effective-method-gensyms*)
309 (name (if (early-gf-p generic-function)
310 (!early-gf-name generic-function)
311 (generic-function-name generic-function)))
312 (arg-info (cons nreq applyp))
313 (effective-method-lambda (expand-effective-method-function
314 generic-function effective-method)))
315 (multiple-value-bind (cfunction constants)
316 (get-fun1 effective-method-lambda
318 (memf-test-converter form generic-function
319 method-alist-p wrappers-p))
321 (memf-code-converter form generic-function
323 method-alist-p wrappers-p))
325 (memf-constant-converter form generic-function)))
326 (lambda (method-alist wrappers)
327 (multiple-value-bind (valid-keys keyargs-start)
328 (when (memq '.valid-keys. constants)
329 (compute-applicable-keywords
330 generic-function *applicable-methods*))
331 (flet ((compute-constant (constant)
335 (funcall (cdr constant) method-alist wrappers))
338 (funcall fn method-alist wrappers))
342 (.keyargs-start. keyargs-start)
343 (.valid-keys. valid-keys)
345 (let ((fun (apply cfunction
346 (mapcar #'compute-constant constants))))
347 (set-fun-name fun `(combined-method ,name))
348 (make-fast-method-call :function fun
349 :arg-info arg-info)))))))))
351 (defmacro call-method-list (&rest calls)
354 (defun make-call-methods (methods)
356 ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
358 (defun gf-requires-emf-keyword-checks (generic-function)
359 (member '&key (gf-lambda-list generic-function)))
361 (defun standard-compute-effective-method
362 (generic-function combin applicable-methods)
363 (collect ((before) (primary) (after) (around))
364 (flet ((invalid (gf combin m)
365 (if *in-precompute-effective-methods-p*
366 (return-from standard-compute-effective-method
367 `(%invalid-qualifiers ',gf ',combin ',m))
368 (invalid-qualifiers gf combin m))))
369 (dolist (m applicable-methods)
370 (let ((qualifiers (if (listp m)
371 (early-method-qualifiers m)
372 (method-qualifiers m))))
374 ((null qualifiers) (primary m))
375 ((cdr qualifiers) (invalid generic-function combin m))
376 ((eq (car qualifiers) :around) (around m))
377 ((eq (car qualifiers) :before) (before m))
378 ((eq (car qualifiers) :after) (after m))
379 (t (invalid generic-function combin m))))))
380 (cond ((null (primary))
381 `(%no-primary-method ',generic-function .args.))
382 ((and (null (before)) (null (after)) (null (around)))
383 ;; By returning a single call-method `form' here we enable
384 ;; an important implementation-specific optimization; that
385 ;; is, we can use the fast method function directly as the
386 ;; effective method function.
388 ;; However, the requirement by ANSI (CLHS 7.6.5) on generic
389 ;; function argument checking inhibits this, as we don't
390 ;; perform this checking in fast-method-functions given
391 ;; that they are not solely used for effective method
392 ;; functions, but also in combination, when they should not
393 ;; perform argument checks.
395 `(call-method ,(first (primary)) ,(rest (primary)))))
396 (if (gf-requires-emf-keyword-checks generic-function)
397 ;; the PROGN inhibits the above optimization
398 `(progn ,call-method)
401 (let ((main-effective-method
402 (if (or (before) (after))
403 `(multiple-value-prog1
405 ,(make-call-methods (before))
406 (call-method ,(first (primary))
408 ,(make-call-methods (reverse (after))))
409 `(call-method ,(first (primary)) ,(rest (primary))))))
411 `(call-method ,(first (around))
413 (make-method ,main-effective-method)))
414 main-effective-method))))))
416 ;;; helper code for checking keywords in generic function calls.
417 (defun compute-applicable-keywords (gf methods)
418 (let ((any-keyp nil))
419 (flet ((analyze (lambda-list)
420 (multiple-value-bind (nreq nopt keyp restp allowp keys)
421 (analyze-lambda-list lambda-list)
422 (declare (ignore nreq restp))
425 (values nopt allowp keys))))
426 (multiple-value-bind (nopt allowp keys)
427 (analyze (generic-function-lambda-list gf))
428 (dolist (method methods)
429 (let ((ll (if (consp method)
430 (early-method-lambda-list method)
431 (method-lambda-list method))))
432 (multiple-value-bind (n allowp method-keys)
436 (return-from compute-applicable-keywords (values t nopt)))
437 (setq keys (union method-keys keys)))))
439 (values (if allowp t keys) nopt)))))
441 (defun check-applicable-keywords (args start valid-keys)
442 (let ((allow-other-keys-seen nil)
443 (allow-other-keys nil)
444 (args (nthcdr start args)))
448 (when (and (invalid) (not allow-other-keys))
449 (error 'simple-program-error
450 :format-control "~@<invalid keyword argument~P: ~
451 ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
452 :format-arguments (list (length (invalid)) (invalid) valid-keys)))
454 (let ((key (pop args)))
457 (error 'simple-program-error
458 :format-control "~@<keyword argument not a symbol: ~S.~@:>"
459 :format-arguments (list key)))
460 ((null args) (sb-c::%odd-key-args-error))
461 ((eq key :allow-other-keys)
462 ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
463 (unless allow-other-keys-seen
464 (setq allow-other-keys-seen t
465 allow-other-keys (car args))))
467 ((not (memq key valid-keys)) (invalid key))))
470 ;;;; the STANDARD method combination type. This is coded by hand
471 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
472 ;;;; and efficiency reasons. Note that the definition of the
473 ;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
474 ;;;; defcombin.lisp. This is because EQL methods can't appear in the
477 ;;;; The DEFCLASS for the METHOD-COMBINATION and
478 ;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this
479 ;;;; reason. This code must conform to the code in the file
480 ;;;; defcombin.lisp, look there for more details.
482 (defun compute-effective-method (generic-function combin applicable-methods)
483 (standard-compute-effective-method generic-function
487 (defun invalid-method-error (method format-control &rest format-arguments)
488 (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
489 (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
494 (defun method-combination-error (format-control &rest format-arguments)
495 (let ((sb-debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame))))
496 (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"