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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Fri May 30 09:14:34 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: dynamic-extent-base, sparc_gencgc_merge, sparc_gencgc
Branch point for: sparc_gencgc_branch, dynamic-extent
Changes since 1.17: +3 -14 lines
	A generic function can have more than one name, via
	(SETF FDEFINITION), and it's possible to define methods with both
	names.  Method functions are named with the name specified in
	DEFMETHODS.  Methods metaobjects are unnamed.  Taking this all
	together means that we must always use METHOD-FUNCTION-GET :NAME
	to find out the name of a method function if we want to use it.

	This showed up in gray-streams.lisp.  Found by Paul Werkowski.

	* src/pcl/boot.lisp (method-function-name): Moved here from
	combin.lisp; use method-function-get :name.

	* src/pcl/combin.lisp (method-function-name): Move to boot.lisp.
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.18 2003/05/30 09:14:34 gerd 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 (declare (ignore combin))
87 (let ((before ())
88 (primary ())
89 (after ())
90 (around ()))
91 (flet ((lose (method why)
92 (invalid-method-error
93 method
94 "~@<The method ~S ~A. ~
95 Standard method combination requires all methods to have one ~
96 of the single qualifiers ~s, ~s and ~s or to have no qualifier ~
97 at all.~@:>"
98 method why :around :before :after)))
99 (dolist (m applicable-methods)
100 (let ((qualifiers (if (listp m)
101 (early-method-qualifiers m)
102 (method-qualifiers m))))
103 (cond ((null qualifiers)
104 (push m primary))
105 ((cdr qualifiers)
106 (lose m "has more than one qualifier"))
107 ((eq (car qualifiers) :around)
108 (push m around))
109 ((eq (car qualifiers) :before)
110 (push m before))
111 ((eq (car qualifiers) :after)
112 (push m after))
113 (t
114 (lose m "has an illegal qualifier"))))))
115 (setq before (reverse before)
116 after (reverse after)
117 primary (reverse primary)
118 around (reverse around))
119 (cond ((null primary)
120 `(%no-primary-method ',gf .args.))
121 ((and (null before) (null after) (null around))
122 ;;
123 ;; By returning a single CALL-METHOD form here, we enable
124 ;; an important implementation-specific optimization, which
125 ;; uses fast-method functions directly for effective method
126 ;; functions. (Which is also the reason emfs have a
127 ;; lambda-list like fast method functionts.)
128 ;;
129 ;; This cannot be done if the gf requires keyword argument
130 ;; checking as in CLHS 7.6.5 because we can't tell in
131 ;; method functions if they are used as emfs only. If they
132 ;; are not used as emfs only, they should accept any keyword
133 ;; argumests, per CLHS 7.6.4, for instance.
134 (let ((call-method `(call-method ,(first primary) ,(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 (eq (first body) '%no-primary-method))
442 (mc-args-p
443 (when (eq *boot-state* 'complete)
444 ;; Otherwise the METHOD-COMBINATION slot is not bound.
445 (let ((combin (generic-function-method-combination gf)))
446 (and (long-method-combination-p combin)
447 (long-method-combination-args-lambda-list combin))))))
448 (cond (error-p
449 `(lambda (.pv-cell. .next-method-call. &rest .args.)
450 (declare (ignore .pv-cell. .next-method-call.))
451 ,body))
452 (mc-args-p
453 (let* ((required (dfun-arg-symbol-list metatypes))
454 (gf-args (if applyp
455 `(list* ,@required .dfun-rest-arg.)
456 `(list ,@required))))
457 `(lambda ,ll
458 (declare (ignore .pv-cell. .next-method-call.))
459 (let ((.gf-args. ,gf-args))
460 (declare (ignorable .gf-args.))
461 ,@check-applicable-keywords
462 ,body))))
463 (t
464 `(lambda ,ll
465 (declare (ignore .pv-cell. .next-method-call.))
466 ,@check-applicable-keywords
467 ,body))))))
468
469 ;;;
470 ;;; Return a form for calling METHOD's fast function. METATYPES is a
471 ;;; list of metatypes, whose length is used to figure out the names of
472 ;;; required emf parameters. APPLY? true means the method has a &rest
473 ;;; arg. CALLABLE-VAR is the name of a closed-over variable
474 ;;; containing a FAST-METHOD-CALL instance corresponding to the
475 ;;; method invocation.
476 ;;;
477 (defun make-direct-call (method metatypes rest? callable-var)
478 (let* ((fn-name (method-function-name method))
479 (fn `(the function #',fn-name))
480 (cell `(fast-method-call-pv-cell ,callable-var))
481 (next `(fast-method-call-next-method-call ,callable-var))
482 (req (dfun-arg-symbol-list metatypes)))
483 (assert (fboundp fn-name))
484 `(funcall ,fn ,cell ,next ,@req ,@(when rest? `(.dfun-rest-arg.)))))
485
486 ;;;
487 ;;; Return a form for successive calls to the fast functions of
488 ;;; the methods in METHODS. LIST-VAR is the name of a
489 ;;; variable containing a list of FAST-METHOD-CALL structures
490 ;;; corresponding to the method function calls.
491 ;;;
492 (defun make-direct-calls (methods metatypes rest? list-var)
493 (collect ((calls))
494 (dolist (method methods)
495 (calls `(let ((.call. (pop .list.)))
496 ,(make-direct-call method metatypes rest? '.call.))))
497 `(let ((.list. ,list-var))
498 (declare (ignorable .list.))
499 ,@(calls))))
500
501 ;;;
502 ;;; Return the list of methods from a CALL-METHOD-LIST form.
503 ;;;
504 (defun call-method-list-methods (call-method-list)
505 (mapcar (lambda (call-method) (cadr call-method))
506 (cdr call-method-list)))
507
508 ;;;
509 ;;; Compute a key from FORM. This function is called via the
510 ;;; GET-FUNCTION mechanism on forms of an emf lambda. Values returned
511 ;;; that are not EQ to FORM are considered keys. All keys are
512 ;;; collected and serve GET-FUNCTION as a key in its table of already
513 ;;; computed functions. That is, if two emf lambdas produce the same
514 ;;; key, a previously compiled function can be used.
515 ;;;
516 (defun memf-test-converter (form gf method-alist-p wrappers-p)
517 (case (car-safe form)
518 ;;
519 (call-method
520 (case (get-method-call-type gf form method-alist-p wrappers-p)
521 (fast-method-call
522 (let ((method (cadr form)))
523 (if (and (eq *boot-state* 'complete) *inline-methods-in-emfs*)
524 (method-function-name method)
525 '.fast-call-method.)))
526 (t '.call-method.)))
527 ;;
528 (call-method-list
529 (case (get-method-list-call-type gf form method-alist-p wrappers-p)
530 (fast-method-call
531 (if (and (eq *boot-state* 'complete) *inline-methods-in-emfs*)
532 (mapcar #'method-function-name (call-method-list-methods form))
533 '.fast-call-method-list.))
534 (t '.call-method-list.)))
535 ;;
536 (check-applicable-keywords
537 'check-applicable-keywords)
538 (t
539 (default-test-converter form))))
540
541 ;;;
542 ;;; This function is called via the GET-FUNCTION mechanism on forms of
543 ;;; an emf lambda. First value returned replaces FORM in the emf
544 ;;; lambda. Second value is a list of variable names that become
545 ;;; closure variables.
546 ;;;
547 (defun memf-code-converter (form gf metatypes applyp method-alist-p
548 wrappers-p)
549 (case (car-safe form)
550 ;;
551 ;; (CALL-METHOD <method-object> &optional <next-methods>)
552 (call-method
553 (let ((method (cadr form))
554 (callable-var (gensym))
555 (call-type (get-method-call-type gf form method-alist-p
556 wrappers-p)))
557 (if (and (eq call-type 'fast-method-call)
558 (eq *boot-state* 'complete)
559 *inline-methods-in-emfs*)
560 (values (make-direct-call method metatypes applyp callable-var)
561 (list callable-var))
562 (values (make-emf-call metatypes applyp callable-var call-type)
563 (list callable-var)))))
564 ;;
565 ;; (CALL-METHOD-LIST <call-method-form>*)
566 ;; where each CALL-METHOD form is (CALL-METHOD <method>)
567 (call-method-list
568 (let ((list-var (gensym))
569 (call-type (get-method-list-call-type gf form method-alist-p
570 wrappers-p)))
571 (if (and (eq call-type 'fast-method-call)
572 (eq *boot-state* 'complete)
573 *inline-methods-in-emfs*)
574 (let ((methods (call-method-list-methods form)))
575 (values (make-direct-calls methods metatypes applyp list-var)
576 (list list-var)))
577 (values `(dolist (.tem. ,list-var)
578 ,(make-emf-call metatypes applyp '.tem. call-type))
579 (list list-var)))))
580 ;;
581 (check-applicable-keywords
582 (values `(check-applicable-keywords .dfun-rest-arg.
583 .keyargs-start. .valid-keys.)
584 '(.keyargs-start. .valid-keys.)))
585 (t
586 (default-code-converter form))))
587
588 (defun memf-constant-converter (form gf)
589 (case (car-safe form)
590 (call-method
591 (list (cons '.meth.
592 (callable-generator-for-call-method gf form))))
593 (call-method-list
594 (list (cons '.meth-list.
595 (mapcar (lambda (form)
596 (callable-generator-for-call-method gf form))
597 (cdr form)))))
598 (check-applicable-keywords
599 '(.keyargs-start. .valid-keys.))
600 (t
601 (default-constant-converter form))))
602
603 (defun get-method-list-call-type (gf form method-alist-p wrappers-p)
604 (if (every (lambda (form)
605 (eq 'fast-method-call
606 (get-method-call-type gf form method-alist-p wrappers-p)))
607 (cdr form))
608 'fast-method-call
609 t))
610
611 (defun get-method-call-type (gf form method-alist-p wrappers-p)
612 (if (eq 'call-method (car-safe form))
613 (destructuring-bind (method &rest cm-args) (cdr form)
614 (declare (ignore cm-args))
615 (when method
616 (if (if (listp method)
617 (eq (car method) :early-method)
618 (method-p method))
619 (if method-alist-p
620 t
621 (multiple-value-bind (mf fmf)
622 (if (listp method)
623 (early-method-function method)
624 (values nil (method-fast-function method)))
625 (declare (ignore mf))
626 (let ((pv-table (and fmf (method-function-pv-table fmf))))
627 (if (and fmf (or (null pv-table) wrappers-p))
628 'fast-method-call
629 'method-call))))
630 (if (eq 'make-method (car-safe method))
631 (get-method-call-type gf (cadr method) method-alist-p
632 wrappers-p)
633 (type-of method)))))
634 'fast-method-call))
635
636
637 ;;; **************************************
638 ;;; Generating Callables for EMFs *******
639 ;;; **************************************
640
641 ;;;
642 ;;; Turned off until problems with method tracing caused by it are
643 ;;; solved (reason unknown). Will be needed once inlining of methods
644 ;;; in effective methods and inlining of effective method in callers
645 ;;; gets accute.
646 ;;;
647 (defvar *named-emfs-p* nil)
648
649 ;;;
650 ;;; Return a callable object for an emf of generic function GF, with
651 ;;; applicable methods METHODS. GENERATOR is a function returned from
652 ;;; CALLABLE-GENERATOR. Call it with two args METHOD-ALIST and
653 ;;; WRAPPERS to obtain the actual callable.
654 ;;;
655 (defvar *applicable-methods*)
656
657 (defun make-callable (gf methods generator method-alist wrappers)
658 (let* ((*applicable-methods* methods)
659 (callable (function-funcall generator method-alist wrappers)))
660 (when *named-emfs-p*
661 (let ((fn (etypecase callable
662 (fast-method-call (fast-method-call-function callable))
663 (method-call (method-call-function callable))
664 (function callable))))
665 (setf (fdefinition (make-emf-name gf methods)) fn)))
666 callable))
667
668 ;;;
669 ;;; Return a name for an effective method of generic function GF,
670 ;;; composed of applicable methods METHODS.
671 ;;;
672 ;;; In general, the name cannot be based on the methods alone, because
673 ;;; that doesn't take method combination arguments into account.
674 ;;;
675 ;;; It is possible to do better for the standard method combination,
676 ;;; though. The current name format is
677 ;;;
678 ;;; (EFFECTIVE-METHOD gf-name around-methods before-methods
679 ;;; primary-method after-methods)
680 ;;;
681 ;;; where each method is a list (METHOD qualifiers specializers).
682 ;;;
683 (defvar *emf-name-table* (make-hash-table :test 'equal))
684
685 (defun make-emf-name (gf methods)
686 (let* ((early-p (early-gf-p gf))
687 (gf-name (generic-function-name* gf))
688 (emf-name
689 (if (or early-p
690 (eq (generic-function-method-combination gf)
691 *standard-method-combination*))
692 (let (primary around before after)
693 (dolist (m methods)
694 (let ((qual (if early-p
695 (early-method-qualifiers m)
696 (method-qualifiers m)))
697 (specl (if early-p
698 (early-method-specializers m)
699 (unparse-specializers
700 (method-specializers m)))))
701 (case (car-safe qual)
702 (:around (push `(method :around ,specl) around))
703 (:before (push `(method :before ,specl) before))
704 (:after (push `(method :after ,specl) after))
705 (t (push `(method ,specl) primary)))))
706 `(effective-method ,gf-name
707 ,@(nreverse around)
708 ,@(nreverse before)
709 ,@(list (last primary))
710 ,@after))
711 `(effective-method ,gf-name ,(gensym)))))
712 (or (gethash emf-name *emf-name-table*)
713 (setf (gethash emf-name *emf-name-table*) emf-name))))
714
715 ;;; end of combin.lisp

  ViewVC Help
Powered by ViewVC 1.1.5