/[cmucl]/src/pcl/combin.lisp
ViewVC logotype

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Fri Apr 2 15:24:02 2004 UTC (10 years ago) by rtoy
Branch: MAIN
CVS Tags: release-19b-pre1, snapshot-2004-10, snapshot-2004-08, snapshot-2004-09, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, mod-arith-base, snapshot-2004-12, snapshot-2004-11, amd64-merge-start, prm-before-macosx-merge-tag, release-19a-base, release-19a-pre1, release-19a-pre3, release-19a-pre2, release-19a, snapshot-2005-03, release-19b-base, snapshot-2004-04, snapshot-2005-01, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02
Branch point for: release-19b-branch, mod-arith-branch, ppc_gencgc_branch, release-19a-branch
Changes since 1.22: +2 -2 lines
Fix typo.  Need a quote on .call-method.
1 ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26
27 (file-comment
28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/combin.lisp,v 1.23 2004/04/02 15:24:02 rtoy Exp $")
29
30 (in-package "PCL")
31
32 ;;;
33 ;;; In the following:
34 ;;;
35 ;;; Something "callable" is either a function, a FAST-METHOD-CALL or
36 ;;; a METHOD-CALL instance, which can all be "invoked" by PCL.
37 ;;;
38 ;;; A generator for a "callable" is a function (closure) taking two
39 ;;; arguments METHOD-ALIST and WRAPPERS and returning a callable.
40 ;;;
41
42
43 ;;; *********************************************
44 ;;; The STANDARD method combination type *******
45 ;;; *********************************************
46 ;;;
47 ;;; This is coded by hand (rather than with DEFINE-METHOD-COMBINATION)
48 ;;; for bootstrapping and efficiency reasons. Note that the
49 ;;; definition of the find-method-combination-method appears in the
50 ;;; file defcombin.lisp, this is because EQL methods can't appear in
51 ;;; the bootstrap.
52 ;;;
53 ;;; This code must conform to the code in the file defcombin, look
54 ;;; there for more details.
55 ;;;
56
57 ;;;
58 ;;; When adding a method to COMPUTE-EFFECTIVE-METHOD for the standard
59 ;;; method combination, COMPUTE-EFFECTIVE-METHOD is called for
60 ;;; determining the effective method of COMPUTE-EFFECTIVE-METHOD.
61 ;;; That's a chicken and egg problem. It's solved in dfun.lisp by
62 ;;; always calling STANDARD-COMPUTE-EFFECTIVE-METHOD for the case of
63 ;;; COMPUTE-EFFECTIVE-METHOD.
64 ;;;
65 ;;; A similar problem occurs with all generic functions used to compute
66 ;;; an effective method. For example, if a method for METHOD-QUALIFIERS
67 ;;; is performed, the generic function METHOD-QUALIFIERS will be called,
68 ;;; and it's not ready for use.
69 ;;;
70 ;;; That's actually the well-known meta-circularity of PCL.
71 ;;;
72 ;;; Can we use an existing definition in the compiling PCL, if any,
73 ;;; until the effective method is ready?
74 ;;;
75 #+loadable-pcl
76 (defmethod compute-effective-method ((gf generic-function)
77 (combin standard-method-combination)
78 applicable-methods)
79 (standard-compute-effective-method gf combin applicable-methods))
80
81 #-loadable-pcl
82 (defun compute-effective-method (gf combin applicable-methods)
83 (standard-compute-effective-method gf combin applicable-methods))
84
85 (defun standard-compute-effective-method (gf combin applicable-methods)
86 (collect ((before) (primary) (after) (around) (invalid))
87 (labels ((lose (method why)
88 (invalid-method-error
89 method
90 "~@<The method ~S ~A. ~
91 Standard method combination requires all methods to have ~
92 one of the single qualifiers ~s, ~s and ~s or to have ~
93 no qualifier at all.~@:>"
94 method why :around :before :after))
95 (invalid-method (method why)
96 (declare (special *in-precompute-effective-methods-p*))
97 (if *in-precompute-effective-methods-p*
98 (invalid method)
99 (lose method why))))
100 (dolist (m applicable-methods)
101 (let ((qualifiers (if (listp m)
102 (early-method-qualifiers m)
103 (method-qualifiers m))))
104 (cond ((null qualifiers)
105 (primary m))
106 ((cdr qualifiers)
107 (invalid-method m "has more than one qualifier"))
108 ((eq (car qualifiers) :around)
109 (around m))
110 ((eq (car qualifiers) :before)
111 (before m))
112 ((eq (car qualifiers) :after)
113 (after m))
114 (t
115 (invalid-method m "has an invalid qualifier")))))
116 (cond ((invalid)
117 `(%invalid-qualifiers ',gf ',combin .args. ',(invalid)))
118 ((null (primary))
119 `(%no-primary-method ',gf .args.))
120 ((and (null (before)) (null (after)) (null (around)))
121 ;;
122 ;; By returning a single CALL-METHOD form here, we enable
123 ;; an important implementation-specific optimization, which
124 ;; uses fast-method functions directly for effective method
125 ;; functions. (Which is also the reason emfs have a
126 ;; lambda-list like fast method functionts.)
127 ;;
128 ;; This cannot be done if the gf requires keyword argument
129 ;; checking as in CLHS 7.6.5 because we can't tell in
130 ;; method functions if they are used as emfs only. If they
131 ;; are not used as emfs only, they should accept any keyword
132 ;; arguments, per CLHS 7.6.4, for instance.
133 (let ((call-method `(call-method ,(first (primary))
134 ,(rest (primary)))))
135 (if (emfs-must-check-applicable-keywords-p gf)
136 `(progn ,call-method)
137 call-method)))
138 (t
139 (let ((main-effective-method
140 (if (or (before) (after))
141 `(multiple-value-prog1
142 (progn
143 ,(make-call-methods (before))
144 (call-method ,(first (primary)) ,(rest (primary))))
145 ,(make-call-methods (reverse (after))))
146 `(call-method ,(first (primary)) ,(rest (primary))))))
147 (if (around)
148 `(call-method ,(first (around))
149 (,@(rest (around))
150 (make-method ,main-effective-method)))
151 main-effective-method)))))))
152
153 (defvar *invalid-method-error*
154 (lambda (&rest args)
155 (declare (ignore args))
156 (error
157 "~@<~s was called outside the dynamic scope ~
158 of a method combination function (inside the body of ~
159 ~s or a method on the generic function ~s).~@:>"
160 'invalid-method-error 'define-method-combination
161 'compute-effective-method)))
162
163 (defvar *method-combination-error*
164 (lambda (&rest args)
165 (declare (ignore args))
166 (error
167 "~@<~s was called outside the dynamic scope ~
168 of a method combination function (inside the body of ~
169 ~s or a method on the generic function ~s).~@:>"
170 'method-combination-error 'define-method-combination
171 'compute-effective-method)))
172
173 (defun invalid-method-error (&rest args)
174 (apply *invalid-method-error* args))
175
176 (defun method-combination-error (&rest args)
177 (apply *method-combination-error* args))
178
179 (defmacro call-method (&rest args)
180 (declare (ignore args))
181 `(error "~@<~S used outsize of a effective method form.~@:>" 'call-method))
182
183 (defmacro call-method-list (&rest calls)
184 `(progn ,@calls))
185
186 (defun make-call-methods (methods)
187 `(call-method-list
188 ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
189
190
191 ;;; ****************************************************
192 ;;; Translating effective method bodies to Code *******
193 ;;; ****************************************************
194
195 (defun get-callable (gf form method-alist wrappers)
196 (funcall (callable-generator gf form method-alist wrappers)
197 method-alist wrappers))
198
199 (defun callable-generator (gf form method-alist-p wrappers-p)
200 (if (eq 'call-method (car-safe form))
201 (callable-generator-for-call-method gf form)
202 (callable-generator-for-emf gf form method-alist-p wrappers-p)))
203
204 ;;;
205 ;;; If the effective method is just a call to CALL-METHOD, this opens
206 ;;; up the possibility of just using the method function of the method
207 ;;; as the effective method function.
208 ;;;
209 ;;; But we have to be careful. If that method function will ask for
210 ;;; the next methods we have to provide them. We do not look to see
211 ;;; if there are next methods, we look at whether the method function
212 ;;; asks about them. If it does, we must tell it whether there are
213 ;;; or aren't to prevent the leaky next methods bug.
214 ;;;
215 (defun callable-generator-for-call-method (gf form)
216 (let* ((cm-args (cdr form))
217 (fmf-p (and (or (not (eq *boot-state* 'complete))
218 (gf-fast-method-function-p gf))
219 (null (cddr cm-args))))
220 (method (car cm-args))
221 (cm-args1 (cdr cm-args)))
222 (lambda (method-alist wrappers)
223 (callable-for-call-method gf method cm-args1 fmf-p method-alist
224 wrappers))))
225
226 (defun callable-for-call-method (gf method cm-args fmf-p method-alist wrappers)
227 (cond ((null method)
228 nil)
229 ((if (listp method)
230 (eq (car method) :early-method)
231 (method-p method))
232 (get-method-callable method cm-args gf fmf-p method-alist wrappers))
233 ((eq 'make-method (car-safe method))
234 (get-callable gf (cadr method) method-alist wrappers))
235 (t
236 method)))
237
238 ;;;
239 ;;; Return a FAST-METHOD-CALL structure, a METHOD-CALL structure, or a
240 ;;; method function for calling METHOD.
241 ;;;
242 (defun get-method-callable (method cm-args gf fmf-p method-alist wrappers)
243 (multiple-value-bind (mf real-mf-p fmf pv-cell)
244 (get-method-function method method-alist wrappers)
245 (cond (fmf
246 (let* ((next-methods (car cm-args))
247 (next (callable-for-call-method gf (car next-methods)
248 (list* (cdr next-methods)
249 (cdr cm-args))
250 fmf-p method-alist wrappers))
251 (arg-info (method-function-get fmf :arg-info)))
252 (make-fast-method-call :function fmf
253 :pv-cell pv-cell
254 :next-method-call next
255 :arg-info arg-info)))
256 (real-mf-p
257 (make-method-call :function mf :call-method-args cm-args))
258 (t mf))))
259
260 (defun get-method-function (method method-alist wrappers)
261 (let ((fn (cadr (assoc method method-alist))))
262 (if fn
263 (values fn nil nil nil)
264 (multiple-value-bind (mf fmf)
265 (if (listp method)
266 (early-method-function method)
267 (values nil (method-fast-function method)))
268 (let ((pv-table (and fmf (method-function-pv-table fmf))))
269 (if (and fmf
270 (not (and pv-table (pv-table-computing-cache-p pv-table)))
271 (or (null pv-table) wrappers))
272 (let* ((pv-wrappers (when pv-table
273 (pv-wrappers-from-all-wrappers
274 pv-table wrappers)))
275 (pv-cell (when (and pv-table pv-wrappers)
276 (pv-table-lookup pv-table pv-wrappers))))
277 (values mf t fmf pv-cell))
278 (values
279 (or mf (if (listp method)
280 (setf (cadr method)
281 (method-function-from-fast-function fmf))
282 (method-function method)))
283 t nil nil)))))))
284
285
286 ;;;
287 ;;; Return a closure returning a FAST-METHOD-CALL instance for the
288 ;;; call of an effective method of generic function GF with body
289 ;;; BODY.
290 ;;;
291 (defun callable-generator-for-emf (gf body method-alist-p wrappers-p)
292 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
293 (get-generic-function-info gf)
294 (declare (ignore nkeys arg-info))
295 (let* ((name (generic-function-name* gf))
296 (fmc-info (cons nreq applyp))
297 (effective-method-lambda (make-effective-method-lambda gf body)))
298 (multiple-value-bind (cfunction constants)
299 (get-function1 effective-method-lambda
300 (lambda (form)
301 (memf-test-converter form gf method-alist-p
302 wrappers-p))
303 (lambda (form)
304 (memf-code-converter form gf metatypes applyp
305 method-alist-p wrappers-p))
306 (lambda (form)
307 (memf-constant-converter form gf)))
308 (lambda (method-alist wrappers)
309 (declare (special *applicable-methods*))
310 (multiple-value-bind (valid-keys keyargs-start)
311 (when (memq '.valid-keys. constants)
312 (compute-applicable-keywords gf *applicable-methods*))
313 (flet ((compute-constant (constant)
314 (if (consp constant)
315 (case (car constant)
316 (.meth.
317 (funcall (cdr constant) method-alist wrappers))
318 (.meth-list.
319 (mapcar (lambda (fn)
320 (funcall fn method-alist wrappers))
321 (cdr constant)))
322 (t constant))
323 (case constant
324 (.keyargs-start. keyargs-start)
325 (.valid-keys. valid-keys)
326 (t constant)))))
327 (let ((fn (apply cfunction
328 (mapcar #'compute-constant constants))))
329 (set-function-name fn `(effective-method ,name))
330 (make-fast-method-call :function fn :arg-info fmc-info)))))))))
331
332 ;;;
333 ;;; Return true if emfs of generic function GF must do keyword
334 ;;; argument checking with CHECK-APPLICABLE-KEYWORDS.
335 ;;;
336 ;;; We currently do this if the generic function type has &KEY, which
337 ;;; should be the case if the gf or any method has &KEY. It would be
338 ;;; possible to avoid the check if it also has &ALLOW-OTHER-KEYS, iff
339 ;;; method functions do checks of their own, which is ugly to do,
340 ;;; so we don't.
341 ;;;
342 (defun emfs-must-check-applicable-keywords-p (gf)
343 (let ((type (info function type (generic-function-name* gf))))
344 (and (kernel::function-type-p type)
345 (kernel::function-type-keyp type))))
346
347 ;;;
348 ;;; Compute which keyword args are valid in a call of generic function
349 ;;; GF with applicable methods METHODS. See also CLHS 7.6.5.
350 ;;;
351 ;;; First value is either a list of valid keywords or T meaning all
352 ;;; keys are valid. Second value is the number of optional arguments
353 ;;; that GF takes. This number is used as an offset in the supplied
354 ;;; args .DFUN-REST-ARG. in CHECK-APPLICABLE-KEYWORDS.
355 ;;;
356 (defun compute-applicable-keywords (gf methods)
357 (let ((any-keyp nil))
358 (flet ((analyze (lambda-list)
359 (multiple-value-bind (nreq nopt keyp restp allowp keys)
360 (analyze-lambda-list lambda-list)
361 (declare (ignore nreq restp))
362 (when keyp
363 (setq any-keyp t))
364 (values nopt allowp keys))))
365 (multiple-value-bind (nopt allowp keys)
366 (analyze (generic-function-lambda-list gf))
367 (if allowp
368 (setq keys t)
369 (dolist (method methods)
370 (multiple-value-bind (n allowp method-keys)
371 (analyze (method-lambda-list* method))
372 (declare (ignore n))
373 (if allowp
374 (return (setq keys t))
375 (setq keys (union method-keys keys))))))
376 ;;
377 ;; It shouldn't happen thet neither the gf nor any method has
378 ;; &KEY, when this method is called. Let's handle the case
379 ;; anyway, just for generality.
380 (values (if any-keyp keys t) nopt)))))
381
382 ;;;
383 ;;; Check ARGS for invalid keyword arguments, beginning at position
384 ;;; START in ARGS. VALID-KEYS is a list of valid keywords. VALID-KEYS
385 ;;; being T means all keys are valid.
386 ;;;
387 (defun check-applicable-keywords (args start valid-keys)
388 (let ((allow-other-keys-seen nil)
389 (allow-other-keys nil)
390 (args (nthcdr start args)))
391 (collect ((invalid))
392 (loop
393 (when (null args)
394 (when (and (invalid) (not allow-other-keys))
395 (simple-program-error
396 "~@<Invalid keyword argument~p ~{~s~^, ~}. ~
397 Valid keywords are: ~{~s~^, ~}.~@:>"
398 (length (invalid))
399 (invalid)
400 valid-keys))
401 (return))
402 (let ((key (pop args)))
403 (cond ((not (symbolp key))
404 (invalid-keyword-argument key))
405 ((null args)
406 (odd-number-of-keyword-arguments))
407 ((eq key :allow-other-keys)
408 (unless allow-other-keys-seen
409 (setq allow-other-keys-seen t
410 allow-other-keys (car args))))
411 ((eq t valid-keys))
412 ((not (memq key valid-keys))
413 (invalid key))))
414 (pop args)))))
415
416 (defun odd-number-of-keyword-arguments ()
417 (simple-program-error "Odd number of keyword arguments."))
418
419 (defun invalid-keyword-argument (key)
420 (simple-program-error "Invalid keyword argument ~s" key))
421
422 ;;;
423 ;;; Return a lambda-form for an effective method of generic function
424 ;;; GF with body BODY.
425 ;;;
426 (defun make-effective-method-lambda (gf body)
427 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
428 (get-generic-function-info gf)
429 (declare (ignore nreq nkeys arg-info))
430 ;;
431 ;; Note that emfs use the same lambda-lists as fast method
432 ;; functions, although they don't need all the arguments that a
433 ;; fast method function needs, because this makes it possible to
434 ;; use fast method functions directly as emfs. This is achieved
435 ;; by returning a single CALL-METHOD form from the method
436 ;; combination.
437 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
438 (check-applicable-keywords
439 (when (and applyp (emfs-must-check-applicable-keywords-p gf))
440 '((check-applicable-keywords))))
441 (error-p
442 (memq (first body) '(%no-primary-method %invalid-qualifiers)))
443 (mc-args-p
444 (when (eq *boot-state* 'complete)
445 ;; Otherwise the METHOD-COMBINATION slot is not bound.
446 (let ((combin (generic-function-method-combination gf)))
447 (and (long-method-combination-p combin)
448 (long-method-combination-args-lambda-list combin))))))
449 (cond (error-p
450 `(lambda (.pv-cell. .next-method-call. &rest .args.)
451 (declare (ignore .pv-cell. .next-method-call.))
452 ,body))
453 (mc-args-p
454 (let* ((required (dfun-arg-symbol-list metatypes))
455 (gf-args (if applyp
456 `(list* ,@required .dfun-rest-arg.)
457 `(list ,@required))))
458 `(lambda ,ll
459 (declare (ignore .pv-cell. .next-method-call.))
460 (let ((.gf-args. ,gf-args))
461 (declare (ignorable .gf-args.))
462 ,@check-applicable-keywords
463 ,body))))
464 (t
465 `(lambda ,ll
466 (declare (ignore .pv-cell. .next-method-call.))
467 ,@check-applicable-keywords
468 ,body))))))
469
470 ;;;
471 ;;; Return true if a fast-method-call to METHOD can be inlined.
472 ;;;
473 ;;; We don't generate funcalls for standard accessor methods because
474 ;;; they have a fast function, but that's not what is actually to be
475 ;;; called. What is called is a closure over MAKE-STD-*-METHOD-FUNCTION.
476 ;;;
477 (defun inlinable-method-p (method)
478 (and (eq *boot-state* 'complete)
479 *inline-methods-in-emfs*
480 (not (standard-accessor-method-p method))))
481
482 ;;;
483 ;;; Return a form for calling METHOD's fast function. METATYPES is a
484 ;;; list of metatypes, whose length is used to figure out the names of
485 ;;; required emf parameters. REST? true means the method has a &rest
486 ;;; arg. CALLABLE-VAR is the name of a closed-over variable
487 ;;; containing a FAST-METHOD-CALL instance corresponding to the
488 ;;; method invocation.
489 ;;;
490 (defun make-direct-call (method metatypes rest? callable-var)
491 (let* ((fn-name (method-function-name method))
492 (fn `(the function #',fn-name))
493 (cell `(fast-method-call-pv-cell ,callable-var))
494 (next `(fast-method-call-next-method-call ,callable-var))
495 (req (dfun-arg-symbol-list metatypes)))
496 (assert (fboundp fn-name))
497 `(funcall ,fn ,cell ,next ,@req ,@(when rest? `(.dfun-rest-arg.)))))
498
499 ;;;
500 ;;; Return the list of methods from a CALL-METHOD-LIST form.
501 ;;;
502 (defun call-method-list-methods (call-method-list)
503 (loop for call-method-form in (cdr call-method-list)
504 collect (second call-method-form)))
505
506 ;;;
507 ;;; Compute a key from FORM. This function is called via the
508 ;;; GET-FUNCTION mechanism on forms of an emf lambda. Values returned
509 ;;; that are not EQ to FORM are considered keys. All keys are
510 ;;; collected and serve GET-FUNCTION as a key in its table of already
511 ;;; computed functions. That is, if two emf lambdas produce the same
512 ;;; key, a previously compiled function can be used.
513 ;;;
514 (defun memf-test-converter (form gf method-alist-p wrappers-p)
515 (flet ((method-key (method)
516 (cond ((inlinable-method-p method)
517 (method-function-name method))
518 ((eq (get-method-call-type gf form method-alist-p wrappers-p)
519 'fast-method-call)
520 '.fast-call-method.)
521 (t '.call-method.))))
522 (case (car-safe form)
523 ;;
524 (call-method
525 (if (eq (get-method-call-type gf form method-alist-p wrappers-p)
526 'fast-method-call)
527 (method-key (second form))
528 '.call-method.))
529 ;;
530 (call-method-list
531 (mapcar #'method-key (call-method-list-methods form)))
532 ;;
533 (check-applicable-keywords
534 'check-applicable-keywords)
535 (t
536 (default-test-converter form)))))
537
538 ;;;
539 ;;; This function is called via the GET-FUNCTION mechanism on forms of
540 ;;; an emf lambda. First value returned replaces FORM in the emf
541 ;;; lambda. Second value is a list of variable names that become
542 ;;; closure variables.
543 ;;;
544 (defun memf-code-converter (form gf metatypes rest? method-alist-p
545 wrappers-p)
546 (labels ((make-call (call-type method metatypes rest? callable-var)
547 (if (and (eq call-type 'fast-method-call)
548 (inlinable-method-p method))
549 (make-direct-call method metatypes rest? callable-var)
550 (make-emf-call metatypes rest? callable-var call-type)))
551
552 (make-calls (call-type methods metatypes rest? list-var)
553 `(let ((.list. ,list-var))
554 (declare (ignorable .list.))
555 ,@(loop for method in methods collect
556 `(let ((.call. (pop .list.)))
557 ,(make-call call-type method metatypes
558 rest? '.call.))))))
559 (case (car-safe form)
560 ;;
561 ;; (CALL-METHOD <method-object> &optional <next-methods>)
562 (call-method
563 (let ((method (cadr form))
564 (callable-var (gensym))
565 (call-type (get-method-call-type gf form method-alist-p
566 wrappers-p)))
567 (values (make-call call-type method metatypes rest? callable-var)
568 (list callable-var))))
569 ;;
570 ;; (CALL-METHOD-LIST <call-method-form>*)
571 ;; where each CALL-METHOD form is (CALL-METHOD <method>)
572 (call-method-list
573 (let ((list-var (gensym))
574 (call-type (get-method-list-call-type gf form method-alist-p
575 wrappers-p))
576 (methods (call-method-list-methods form)))
577 (values (make-calls call-type methods metatypes rest? list-var)
578 (list list-var))))
579 ;;
580 (check-applicable-keywords
581 (values `(check-applicable-keywords .dfun-rest-arg.
582 .keyargs-start. .valid-keys.)
583 '(.keyargs-start. .valid-keys.)))
584 (t
585 (default-code-converter form)))))
586
587 (defun memf-constant-converter (form gf)
588 (case (car-safe form)
589 (call-method
590 (list (cons '.meth.
591 (callable-generator-for-call-method gf form))))
592 (call-method-list
593 (list (cons '.meth-list.
594 (mapcar (lambda (form)
595 (callable-generator-for-call-method gf form))
596 (cdr form)))))
597 (check-applicable-keywords
598 '(.keyargs-start. .valid-keys.))
599 (t
600 (default-constant-converter form))))
601
602 (defun get-method-list-call-type (gf form method-alist-p wrappers-p)
603 (if (every (lambda (form)
604 (eq 'fast-method-call
605 (get-method-call-type gf form method-alist-p wrappers-p)))
606 (cdr form))
607 'fast-method-call
608 t))
609
610 (defun get-method-call-type (gf form method-alist-p wrappers-p)
611 (if (eq 'call-method (car-safe form))
612 (destructuring-bind (method &rest cm-args) (cdr form)
613 (declare (ignore cm-args))
614 (when method
615 (if (if (listp method)
616 (eq (car method) :early-method)
617 (method-p method))
618 (if method-alist-p
619 t
620 (multiple-value-bind (mf fmf)
621 (if (listp method)
622 (early-method-function method)
623 (values nil (method-fast-function method)))
624 (declare (ignore mf))
625 (let ((pv-table (and fmf (method-function-pv-table fmf))))
626 (if (and fmf (or (null pv-table) wrappers-p))
627 'fast-method-call
628 'method-call))))
629 (if (eq 'make-method (car-safe method))
630 (get-method-call-type gf (cadr method) method-alist-p
631 wrappers-p)
632 (type-of method)))))
633 'fast-method-call))
634
635
636 ;;; **************************************
637 ;;; Generating Callables for EMFs *******
638 ;;; **************************************
639
640 ;;;
641 ;;; Turned off until problems with method tracing caused by it are
642 ;;; solved (reason unknown). Will be needed once inlining of methods
643 ;;; in effective methods and inlining of effective method in callers
644 ;;; gets accute.
645 ;;;
646 (defvar *named-emfs-p* nil)
647
648 ;;;
649 ;;; Return a callable object for an emf of generic function GF, with
650 ;;; applicable methods METHODS. GENERATOR is a function returned from
651 ;;; CALLABLE-GENERATOR. Call it with two args METHOD-ALIST and
652 ;;; WRAPPERS to obtain the actual callable.
653 ;;;
654 (defvar *applicable-methods*)
655
656 (defun make-callable (gf methods generator method-alist wrappers)
657 (let* ((*applicable-methods* methods)
658 (callable (function-funcall generator method-alist wrappers)))
659 (when *named-emfs-p*
660 (let ((fn (etypecase callable
661 (fast-method-call (fast-method-call-function callable))
662 (method-call (method-call-function callable))
663 (function callable))))
664 (setf (fdefinition (make-emf-name gf methods)) fn)))
665 callable))
666
667 ;;;
668 ;;; Return a name for an effective method of generic function GF,
669 ;;; composed of applicable methods METHODS.
670 ;;;
671 ;;; In general, the name cannot be based on the methods alone, because
672 ;;; that doesn't take method combination arguments into account.
673 ;;;
674 ;;; It is possible to do better for the standard method combination,
675 ;;; though. The current name format is
676 ;;;
677 ;;; (EFFECTIVE-METHOD gf-name around-methods before-methods
678 ;;; primary-method after-methods)
679 ;;;
680 ;;; where each method is a list (METHOD qualifiers specializers).
681 ;;;
682 (defvar *emf-name-table* (make-hash-table :test 'equal))
683
684 (defun make-emf-name (gf methods)
685 (let* ((early-p (early-gf-p gf))
686 (gf-name (generic-function-name* gf))
687 (emf-name
688 (if (or early-p
689 (eq (generic-function-method-combination gf)
690 *standard-method-combination*))
691 (let (primary around before after)
692 (dolist (m methods)
693 (let ((qual (if early-p
694 (early-method-qualifiers m)
695 (method-qualifiers m)))
696 (specl (if early-p
697 (early-method-specializers m)
698 (unparse-specializers
699 (method-specializers m)))))
700 (case (car-safe qual)
701 (:around (push `(method :around ,specl) around))
702 (:before (push `(method :before ,specl) before))
703 (:after (push `(method :after ,specl) after))
704 (t (push `(method ,specl) primary)))))
705 `(effective-method ,gf-name
706 ,@(nreverse around)
707 ,@(nreverse before)
708 ,@(list (last primary))
709 ,@after))
710 `(effective-method ,gf-name ,(gensym)))))
711 (or (gethash emf-name *emf-name-table*)
712 (setf (gethash emf-name *emf-name-table*) emf-name))))
713
714 ;;; end of combin.lisp

  ViewVC Help
Powered by ViewVC 1.1.5