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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25.36.1 - (show annotations)
Thu Feb 25 20:34:56 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.25: +2 -1 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

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

  ViewVC Help
Powered by ViewVC 1.1.5