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
(safe-method-fast-function method
)))
34 (let* ((pv-table (and fmf
(method-plist-value method
:pv-table
))))
35 (if (and fmf
(or (null pv-table
) wrappers
))
36 (let* ((pv-wrappers (when pv-table
37 (pv-wrappers-from-all-wrappers
39 (pv (when (and pv-table pv-wrappers
)
40 (pv-table-lookup pv-table pv-wrappers
))))
43 (or mf
(if (listp method
)
44 (bug "early method with no method-function")
45 (method-function method
)))
48 (defun make-effective-method-function (generic-function form
&optional
49 method-alist wrappers
)
50 (funcall (make-effective-method-function1 generic-function form
51 (not (null method-alist
))
52 (not (null wrappers
)))
53 method-alist wrappers
))
55 (defun make-effective-method-function1 (generic-function form
56 method-alist-p wrappers-p
)
58 (eq (car form
) 'call-method
))
59 (make-effective-method-function-simple generic-function form
)
60 ;; We have some sort of `real' effective method. Go off and get a
61 ;; compiled function for it. Most of the real hair here is done by
62 ;; the GET-FUN mechanism.
63 (make-effective-method-function-internal generic-function form
64 method-alist-p wrappers-p
)))
66 (defun make-effective-method-fun-type (generic-function
71 (eq (car form
) 'call-method
))
72 (let* ((cm-args (cdr form
))
73 (method (car cm-args
)))
75 (if (if (listp method
)
76 (eq (car method
) :early-method
)
80 (multiple-value-bind (mf fmf
)
82 (early-method-function method
)
83 (values nil
(safe-method-fast-function method
)))
85 (let* ((pv-table (and fmf
(method-plist-value method
:pv-table
))))
86 (if (and fmf
(or (null pv-table
) wrappers-p
))
89 (if (and (consp method
) (eq (car method
) 'make-method
))
90 (make-effective-method-fun-type
91 generic-function
(cadr method
) method-alist-p wrappers-p
)
95 (defun make-effective-method-function-simple
96 (generic-function form
&optional no-fmf-p
)
97 ;; The effective method is just a call to CALL-METHOD. This opens up
98 ;; the possibility of just using the method function of the method as
99 ;; the effective method function.
101 ;; But we have to be careful. If that method function will ask for
102 ;; the next methods we have to provide them. We do not look to see
103 ;; if there are next methods, we look at whether the method function
104 ;; asks about them. If it does, we must tell it whether there are
105 ;; or aren't to prevent the leaky next methods bug.
106 (let* ((cm-args (cdr form
))
107 (fmf-p (and (null no-fmf-p
)
108 (or (not (eq **boot-state
** 'complete
))
109 (gf-fast-method-function-p generic-function
))
110 (null (cddr cm-args
))))
111 (method (car cm-args
))
112 (cm-args1 (cdr cm-args
)))
113 (lambda (method-alist wrappers
)
114 (make-effective-method-function-simple1 generic-function
121 (defun make-emf-from-method
122 (method cm-args
&optional gf fmf-p method-alist wrappers
)
123 ;; Avoid style-warning about compiler-macro being unavailable.
124 (declare (notinline make-instance
))
125 (multiple-value-bind (mf real-mf-p fmf pv
)
126 (get-method-function method method-alist wrappers
)
128 (let* ((next-methods (car cm-args
))
129 (next (make-effective-method-function-simple1
130 gf
(car next-methods
)
131 (list* (cdr next-methods
) (cdr cm-args
))
132 fmf-p method-alist wrappers
))
133 (arg-info (method-plist-value method
:arg-info
))
134 (default (cons nil nil
))
135 (value (method-plist-value method
:constant-value default
)))
136 (if (eq value default
)
137 (make-fast-method-call :function fmf
:pv pv
138 :next-method-call next
:arg-info arg-info
)
139 (make-constant-fast-method-call
140 :function fmf
:pv pv
:next-method-call next
141 :arg-info arg-info
:value value
)))
143 (flet ((frob-cm-arg (arg)
145 (eq (car arg
) :early-method
)
148 (if (and (consp arg
) (eq (car arg
) 'make-method
))
149 (let ((emf (make-effective-method-function
150 gf
(cadr arg
) method-alist wrappers
)))
153 (make-instance 'standard-method
154 :specializers nil
; XXX
155 :qualifiers nil
; XXX
156 :function
(method-call-function emf
)))
158 (let* ((fmf (fast-method-call-function emf
))
159 (fun (method-function-from-fast-method-call emf
))
160 (mf (%make-method-function fmf
)))
161 (set-funcallable-instance-function mf fun
)
162 (make-instance 'standard-method
163 :specializers nil
; XXX
167 (let* ((default (cons nil nil
))
169 (method-plist-value method
:constant-value default
))
170 ;; FIXME: this is wrong. Very wrong. It assumes
171 ;; that the only place that can have make-method
172 ;; calls is in the list structure of the second
173 ;; argument to CALL-METHOD, but AMOP says that
174 ;; CALL-METHOD can be more complicated if
175 ;; COMPUTE-EFFECTIVE-METHOD (and presumably
176 ;; MAKE-METHOD-LAMBDA) is adjusted to match.
178 ;; On the other hand, it's a start, because
179 ;; without this calls to MAKE-METHOD in method
180 ;; combination where one of the methods is of a
181 ;; user-defined class don't work at all. -- CSR,
183 (args (cons (mapcar #'frob-cm-arg
(car cm-args
))
185 (if (eq value default
)
186 (make-method-call :function mf
:call-method-args args
)
187 (make-constant-method-call :function mf
:value value
188 :call-method-args args
))))
191 (defun make-effective-method-function-simple1
192 (gf method cm-args fmf-p
&optional method-alist wrappers
)
194 (if (if (listp method
)
195 (eq (car method
) :early-method
)
197 (make-emf-from-method method cm-args gf fmf-p method-alist wrappers
)
198 (if (and (consp method
) (eq (car method
) 'make-method
))
199 (make-effective-method-function gf
201 method-alist wrappers
)
204 (defvar *global-effective-method-gensyms
* ())
205 (defvar *rebound-effective-method-gensyms
*)
207 (defun get-effective-method-gensym ()
208 (or (pop *rebound-effective-method-gensyms
*)
209 (let ((new (format-symbol *pcl-package
*
210 "EFFECTIVE-METHOD-GENSYM-~D"
211 (length *global-effective-method-gensyms
*))))
212 (setq *global-effective-method-gensyms
*
213 (append *global-effective-method-gensyms
* (list new
)))
216 (let ((*rebound-effective-method-gensyms
* ()))
217 (dotimes-fixnum (i 10) (get-effective-method-gensym)))
219 (defun expand-effective-method-function (gf effective-method
&optional env
)
220 (declare (ignore env
))
221 (declare (muffle-conditions code-deletion-note
))
222 (multiple-value-bind (nreq applyp
)
223 (get-generic-fun-info gf
)
224 (let ((ll (make-fast-method-call-lambda-list nreq applyp
))
225 (check-applicable-keywords
226 (when (and applyp
(gf-requires-emf-keyword-checks gf
))
227 '((check-applicable-keywords))))
228 (error-p (or (eq (first effective-method
) '%no-primary-method
)
229 (eq (first effective-method
) '%invalid-qualifiers
)))
231 (when (eq **boot-state
** 'complete
)
232 ;; Otherwise the METHOD-COMBINATION slot is not bound.
233 (let ((combin (generic-function-method-combination gf
)))
234 (and (long-method-combination-p combin
)
235 (long-method-combination-args-lambda-list combin
)))))
236 (name `(emf ,(generic-function-name gf
))))
239 `(named-lambda ,name
(.pv. .next-method-call.
&rest .args.
)
240 (declare (ignore .pv. .next-method-call.
))
241 (declare (ignorable .args.
))
242 (flet ((%no-primary-method
(gf args
)
243 (call-no-primary-method gf args
))
244 (%invalid-qualifiers
(gf combin method
)
245 (invalid-qualifiers gf combin method
)))
246 (declare (ignorable #'%no-primary-method
#'%invalid-qualifiers
))
249 (let* ((required (make-dfun-required-args nreq
))
252 (sb-c::%listify-rest-args
254 (the (and unsigned-byte fixnum
)
256 `(list ,@required
))))
257 `(named-lambda ,name
,ll
258 (declare (ignore .pv. .next-method-call.
))
259 (let ((.gf-args.
,gf-args
))
260 (declare (ignorable .gf-args.
))
261 ,@check-applicable-keywords
262 ,effective-method
))))
264 `(named-lambda ,name
,ll
265 (declare (ignore ,@(if error-p ll
'(.pv. .next-method-call.
))))
266 ,@check-applicable-keywords
267 ,effective-method
))))))
269 (defun expand-emf-call-method (gf form metatypes applyp env
)
270 (declare (ignore gf metatypes applyp env
))
271 `(call-method ,(cdr form
)))
273 (defmacro call-method
(&rest args
)
274 (declare (ignore args
))
275 ;; the PROGN is here to defend against premature macroexpansion by
277 `(progn (error "~S outside of a effective method form" 'call-method
)))
279 (defun make-effective-method-list-fun-type
280 (generic-function form method-alist-p wrappers-p
)
281 (if (every (lambda (form)
282 (eq 'fast-method-call
283 (make-effective-method-fun-type
284 generic-function form method-alist-p wrappers-p
)))
289 (defun memf-test-converter (form generic-function method-alist-p wrappers-p
)
290 (case (and (consp form
) (car form
))
292 (case (make-effective-method-fun-type
293 generic-function form method-alist-p wrappers-p
)
294 (fast-method-call '.fast-call-method.
)
297 (case (make-effective-method-list-fun-type
298 generic-function form method-alist-p wrappers-p
)
299 (fast-method-call '.fast-call-method-list.
)
300 (t '.call-method-list.
)))
301 (check-applicable-keywords 'check-applicable-keywords
)
302 (t (default-test-converter form
))))
304 ;;; CMUCL comment (2003-10-15):
306 ;;; This function is called via the GET-FUNCTION mechanism on forms
307 ;;; of an emf lambda. First value returned replaces FORM in the emf
308 ;;; lambda. Second value is a list of variable names that become
309 ;;; closure variables.
310 (defun memf-code-converter
311 (form generic-function metatypes applyp method-alist-p wrappers-p
)
312 (case (and (consp form
) (car form
))
314 (let ((gensym (get-effective-method-gensym)))
315 (values (make-emf-call
316 (length metatypes
) applyp gensym
317 (make-effective-method-fun-type
318 generic-function form method-alist-p wrappers-p
))
321 (let ((gensym (get-effective-method-gensym))
322 (type (make-effective-method-list-fun-type
323 generic-function form method-alist-p wrappers-p
)))
324 (values `(dolist (emf ,gensym nil
)
325 ,(make-emf-call (length metatypes
) applyp
'emf type
))
327 (check-applicable-keywords
328 (values `(check-applicable-keywords .keyargs-start.
332 '(.keyargs-start. .valid-keys.
)))
334 (default-code-converter form
))))
336 (defun memf-constant-converter (form generic-function
)
337 (case (and (consp form
) (car form
))
340 (make-effective-method-function-simple
341 generic-function form
))))
343 (list (cons '.meth-list.
344 (mapcar (lambda (form)
345 (make-effective-method-function-simple
346 generic-function form
))
348 (check-applicable-keywords
349 '(.keyargs-start. .valid-keys.
))
351 (default-constant-converter form
))))
353 (defvar *applicable-methods
*)
354 (defun make-effective-method-function-internal
355 (generic-function effective-method method-alist-p wrappers-p
)
356 (multiple-value-bind (nreq applyp metatypes nkeys arg-info
)
357 (get-generic-fun-info generic-function
)
358 (declare (ignore nkeys arg-info
))
359 (let* ((*rebound-effective-method-gensyms
*
360 *global-effective-method-gensyms
*)
361 (name (if (early-gf-p generic-function
)
362 (!early-gf-name generic-function
)
363 (generic-function-name generic-function
)))
364 (arg-info (cons nreq applyp
))
365 (effective-method-lambda (expand-effective-method-function
366 generic-function effective-method
)))
367 (multiple-value-bind (cfunction constants
)
368 (get-fun1 effective-method-lambda
370 (memf-test-converter form generic-function
371 method-alist-p wrappers-p
))
373 (memf-code-converter form generic-function
375 method-alist-p wrappers-p
))
377 (memf-constant-converter form generic-function
)))
378 (lambda (method-alist wrappers
)
379 (multiple-value-bind (valid-keys keyargs-start
)
380 (when (memq '.valid-keys. constants
)
381 (compute-applicable-keywords
382 generic-function
*applicable-methods
*))
383 (flet ((compute-constant (constant)
387 (funcall (cdr constant
) method-alist wrappers
))
390 (funcall fn method-alist wrappers
))
394 (.keyargs-start. keyargs-start
)
395 (.valid-keys. valid-keys
)
397 (let ((fun (apply cfunction
398 (mapcar #'compute-constant constants
))))
399 (set-fun-name fun
`(combined-method ,name
))
400 (make-fast-method-call :function fun
401 :arg-info arg-info
)))))))))
403 (defmacro call-method-list
(&rest calls
)
406 (defun make-call-methods (methods)
408 ,@(mapcar (lambda (method) `(call-method ,method
())) methods
)))
410 (defun gf-requires-emf-keyword-checks (generic-function)
411 (member '&key
(gf-lambda-list generic-function
)))
413 (defconstant-eqx +standard-method-combination-qualifiers
+
414 '(:around
:before
:after
) #'equal
)
416 (defun standard-method-combination-qualifier-p (qualifier)
417 (member qualifier
+standard-method-combination-qualifiers
+))
419 (defun standard-compute-effective-method
420 (generic-function combin applicable-methods
)
421 (collect ((before) (primary) (after) (around))
422 (flet ((invalid (gf combin m
) (invalid-qualifiers gf combin m
)))
423 (dolist (m applicable-methods
)
424 (let ((qualifiers (if (listp m
)
425 (early-method-qualifiers m
)
426 (safe-method-qualifiers m
))))
428 ((null qualifiers
) (primary m
))
429 ((cdr qualifiers
) (invalid generic-function combin m
))
430 ((eq (car qualifiers
) :around
) (around m
))
431 ((eq (car qualifiers
) :before
) (before m
))
432 ((eq (car qualifiers
) :after
) (after m
))
433 (t (invalid generic-function combin m
))))))
434 (cond ((null (primary))
435 `(%no-primary-method
',generic-function .args.
))
436 ((and (null (before)) (null (after)) (null (around)))
437 ;; By returning a single call-method `form' here we enable
438 ;; an important implementation-specific optimization; that
439 ;; is, we can use the fast method function directly as the
440 ;; effective method function.
442 ;; However, the requirement by ANSI (CLHS 7.6.5) on generic
443 ;; function argument checking inhibits this, as we don't
444 ;; perform this checking in fast-method-functions given
445 ;; that they are not solely used for effective method
446 ;; functions, but also in combination, when they should not
447 ;; perform argument checks.
449 `(call-method ,(first (primary)) ,(rest (primary)))))
450 (if (gf-requires-emf-keyword-checks generic-function
)
451 ;; the PROGN inhibits the above optimization
452 `(progn ,call-method
)
455 (let ((main-effective-method
456 (if (or (before) (after))
457 `(multiple-value-prog1
459 ,(make-call-methods (before))
460 (call-method ,(first (primary))
462 ,(make-call-methods (reverse (after))))
463 `(call-method ,(first (primary)) ,(rest (primary))))))
465 `(call-method ,(first (around))
467 (make-method ,main-effective-method
)))
468 main-effective-method
))))))
470 (defun short-method-combination-qualifiers (type-name)
471 (list type-name
:around
))
473 (defun short-method-combination-qualifier-p (type-name qualifier
)
474 (or (eq qualifier type-name
) (eq qualifier
:around
)))
476 (defun short-compute-effective-method
477 (generic-function combin applicable-methods
)
478 (let ((type-name (method-combination-type-name combin
))
479 (operator (short-combination-operator combin
))
480 (ioa (short-combination-identity-with-one-argument combin
))
481 (order (car (method-combination-options combin
)))
484 (flet ((invalid (gf combin m
)
485 (return-from short-compute-effective-method
486 `(%invalid-qualifiers
',gf
',combin
',m
))))
487 (dolist (m applicable-methods
)
488 (let ((qualifiers (method-qualifiers m
)))
489 (cond ((null qualifiers
) (invalid generic-function combin m
))
490 ((cdr qualifiers
) (invalid generic-function combin m
))
491 ((eq (car qualifiers
) :around
)
493 ((eq (car qualifiers
) type-name
)
495 (t (invalid generic-function combin m
))))))
496 (setq around
(nreverse around
))
498 (:most-specific-last
) ; nothing to be done, already in correct order
499 (:most-specific-first
500 (setq primary
(nreverse primary
))))
502 (if (and (null (cdr primary
))
504 `(call-method ,(car primary
) ())
505 `(,operator
,@(mapcar (lambda (m) `(call-method ,m
()))
507 (cond ((null primary
)
508 ;; As of sbcl-0.8.0.80 we don't seem to need to do
509 ;; anything messy like
510 ;; `(APPLY (FUNCTION (IF AROUND
511 ;; 'NO-PRIMARY-METHOD
512 ;; 'NO-APPLICABLE-METHOD)
513 ;; ',GENERIC-FUNCTION
515 ;; here because (for reasons I don't understand at the
516 ;; moment -- WHN) control will never reach here if there
517 ;; are no applicable methods, but instead end up
518 ;; in NO-APPLICABLE-METHODS first.
520 ;; FIXME: The way that we arrange for .ARGS. to be bound
521 ;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION
522 ;; recognizing any form whose operator is %NO-PRIMARY-METHOD
523 ;; as magical, and carefully surrounding it with a
524 ;; LAMBDA form which binds .ARGS. But...
525 ;; 1. That seems fragile, because the magicalness of
526 ;; %NO-PRIMARY-METHOD forms is scattered around
527 ;; the system. So it could easily be broken by
528 ;; locally-plausible maintenance changes like,
529 ;; e.g., using the APPLY expression above.
530 ;; 2. That seems buggy w.r.t. to MOPpish tricks in
532 ;; (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...)
533 ;; `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*)))
534 `(%no-primary-method
',generic-function .args.
))
535 ((null around
) main-method
)
537 `(call-method ,(car around
)
538 (,@(cdr around
) (make-method ,main-method
))))))))
540 ;;; helper code for checking keywords in generic function calls.
541 (defun compute-applicable-keywords (gf methods
)
542 (let ((any-keyp nil
))
543 (flet ((analyze (lambda-list)
544 (multiple-value-bind (llks nreq nopt keys
)
545 (analyze-lambda-list lambda-list
)
546 (declare (ignore nreq
))
547 (when (ll-kwds-keyp llks
)
549 (values nopt
(ll-kwds-allowp llks
) keys
))))
550 (multiple-value-bind (nopt allowp keys
)
551 (analyze (generic-function-lambda-list gf
))
552 (dolist (method methods
)
553 (let ((ll (if (consp method
)
554 (early-method-lambda-list method
)
555 (method-lambda-list method
))))
556 (multiple-value-bind (n allowp method-keys
)
560 (return-from compute-applicable-keywords
(values t nopt
)))
561 (setq keys
(union method-keys keys
)))))
563 (values (if allowp t keys
) nopt
)))))
565 (defun check-applicable-keywords (start valid-keys more-context more-count
)
566 (let ((allow-other-keys-seen nil
)
567 (allow-other-keys nil
)
569 (declare (type index i more-count
)
571 (flet ((current-value ()
572 (sb-c::%more-arg more-context i
)))
573 (declare (inline current-value
))
576 (when (>= i more-count
)
577 (when (and (invalid) (not allow-other-keys
))
578 (error 'simple-program-error
579 :format-control
"~@<invalid keyword argument~P: ~
580 ~{~S~^, ~} (valid keys are ~{~S~^, ~}).~@:>"
581 :format-arguments
(list (length (invalid)) (invalid) valid-keys
)))
583 (let ((key (current-value)))
587 (error 'simple-program-error
588 :format-control
"~@<keyword argument not a symbol: ~S.~@:>"
589 :format-arguments
(list key
)))
591 (sb-c::%odd-key-args-error
))
592 ((eq key
:allow-other-keys
)
593 ;; only the leftmost :ALLOW-OTHER-KEYS has any effect
594 (unless allow-other-keys-seen
595 (setq allow-other-keys-seen t
596 allow-other-keys
(current-value))))
598 ((not (memq key valid-keys
)) (invalid key
))))
601 ;;;; the STANDARD method combination type. This is coded by hand
602 ;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
603 ;;;; and efficiency reasons. Note that the definition of the
604 ;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
605 ;;;; defcombin.lisp. This is because EQL methods can't appear in the
608 ;;;; The DEFCLASS for the METHOD-COMBINATION and
609 ;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this
610 ;;;; reason. This code must conform to the code in the file
611 ;;;; defcombin.lisp, look there for more details.
613 (defun compute-effective-method (generic-function combin applicable-methods
)
614 (standard-compute-effective-method generic-function
618 (defun invalid-method-error (method format-control
&rest format-arguments
)
619 (let ((sb-debug:*stack-top-hint
* (find-caller-frame)))
620 (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
625 (defun method-combination-error (format-control &rest format-arguments
)
626 (let ((sb-debug:*stack-top-hint
* (find-caller-frame)))
627 (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"