/[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 - (hide 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 wlott 1.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 pw 1.9
27 gerd 1.15 (file-comment
28 rtoy 1.25.36.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/combin.lisp,v 1.25.36.1 2010/02/25 20:34:56 rtoy Exp $")
29 wlott 1.1
30 gerd 1.14 (in-package "PCL")
31 rtoy 1.25.36.1 (intl:textdomain "cmucl")
32 wlott 1.1
33 gerd 1.14 ;;;
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 ram 1.3
58 gerd 1.14 ;;;
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 wlott 1.1
86 gerd 1.14 (defun standard-compute-effective-method (gf combin applicable-methods)
87 gerd 1.19 (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 gerd 1.20 (declare (special *in-precompute-effective-methods-p*))
98 gerd 1.19 (if *in-precompute-effective-methods-p*
99     (invalid method)
100     (lose method why))))
101 pmai 1.10 (dolist (m applicable-methods)
102     (let ((qualifiers (if (listp m)
103     (early-method-qualifiers m)
104     (method-qualifiers m))))
105 gerd 1.14 (cond ((null qualifiers)
106 gerd 1.19 (primary m))
107 gerd 1.14 ((cdr qualifiers)
108 gerd 1.19 (invalid-method m "has more than one qualifier"))
109 gerd 1.14 ((eq (car qualifiers) :around)
110 gerd 1.19 (around m))
111 gerd 1.14 ((eq (car qualifiers) :before)
112 gerd 1.19 (before m))
113 gerd 1.14 ((eq (car qualifiers) :after)
114 gerd 1.19 (after m))
115 gerd 1.14 (t
116 gerd 1.19 (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 gerd 1.20 ;; arguments, per CLHS 7.6.4, for instance.
134 gerd 1.19 (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 ram 1.5
154 wlott 1.1 (defvar *invalid-method-error*
155 pmai 1.11 (lambda (&rest args)
156     (declare (ignore args))
157     (error
158 gerd 1.14 "~@<~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 wlott 1.1
164     (defvar *method-combination-error*
165 pmai 1.11 (lambda (&rest args)
166     (declare (ignore args))
167     (error
168 gerd 1.14 "~@<~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 wlott 1.1
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 gerd 1.14 (defmacro call-method (&rest args)
181     (declare (ignore args))
182 rtoy 1.24 ;;
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 rtoy 1.25 `(progn (error "~@<~S used outside of a effective method form.~@:>" 'call-method)))
186 gerd 1.14
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 gerd 1.16 ;;; call of an effective method of generic function GF with body
293 gerd 1.14 ;;; 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 gerd 1.16 (let* ((name (generic-function-name* gf))
300     (fmc-info (cons nreq applyp))
301 gerd 1.14 (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 gerd 1.16 (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 gerd 1.14
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 gerd 1.16 ;;
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 gerd 1.14 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
442 gerd 1.16 (check-applicable-keywords
443     (when (and applyp (emfs-must-check-applicable-keywords-p gf))
444     '((check-applicable-keywords))))
445 gerd 1.19 (error-p
446     (memq (first body) '(%no-primary-method %invalid-qualifiers)))
447 gerd 1.14 (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 gerd 1.16 ,@check-applicable-keywords
467 gerd 1.14 ,body))))
468     (t
469     `(lambda ,ll
470     (declare (ignore .pv-cell. .next-method-call.))
471 gerd 1.16 ,@check-applicable-keywords
472 gerd 1.14 ,body))))))
473    
474 gerd 1.17 ;;;
475 gerd 1.21 ;;; 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 gerd 1.17 ;;; 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 gerd 1.21 ;;; required emf parameters. REST? true means the method has a &rest
490 gerd 1.17 ;;; 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 gerd 1.21 (loop for call-method-form in (cdr call-method-list)
508     collect (second call-method-form)))
509 gerd 1.17
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 gerd 1.14 (defun memf-test-converter (form gf method-alist-p wrappers-p)
519 gerd 1.21 (flet ((method-key (method)
520 rtoy 1.22 (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 rtoy 1.23 (t '.call-method.))))
526 gerd 1.21 (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 rtoy 1.22 (mapcar #'method-key (call-method-list-methods form)))
536 gerd 1.21 ;;
537     (check-applicable-keywords
538     'check-applicable-keywords)
539     (t
540     (default-test-converter form)))))
541 gerd 1.14
542 gerd 1.17 ;;;
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 gerd 1.21 (defun memf-code-converter (form gf metatypes rest? method-alist-p
549 gerd 1.14 wrappers-p)
550 gerd 1.21 (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 gerd 1.14
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 gerd 1.16 (check-applicable-keywords
602     '(.keyargs-start. .valid-keys.))
603 gerd 1.14 (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 gerd 1.16 (defvar *applicable-methods*)
659    
660 gerd 1.14 (defun make-callable (gf methods generator method-alist wrappers)
661 gerd 1.16 (let* ((*applicable-methods* methods)
662     (callable (function-funcall generator method-alist wrappers)))
663 gerd 1.17 (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 gerd 1.14
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 gerd 1.16 (gf-name (generic-function-name* gf))
691 gerd 1.14 (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 ram 1.2
718 gerd 1.14 ;;; end of combin.lisp

  ViewVC Help
Powered by ViewVC 1.1.5