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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (hide annotations)
Wed Nov 5 17:01:18 2003 UTC (10 years, 5 months ago) by gerd
Branch: MAIN
CVS Tags: snapshot-2003-12
Changes since 1.20: +79 -81 lines
	(defclass data () ((name :accessor name)))
	(defmethod name :before ((data data)))

	(name (make-instance 'data))
	 => too few args in a call to a method function

	This is caused by standard-reader/writer methods having a
	fast-function, but that's not the one that we should funcall if
	pcl::*inline-methods-in-emfs* is true.  Use the fast-method-call
	mechanism for such methods instead.

	* src/pcl/combin.lisp (inlinable-method-p): New function.
	(make-direct-calls): Removed.
	(memf-test-converter): Add a local function method-key for
	determining the function generator key.
	(memf-code-converter): Add local functions make-call and
	make-calls.  Generate direct calls if inlinable-method-p returns
	true.
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 gerd 1.21 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/combin.lisp,v 1.21 2003/11/05 17:01:18 gerd Exp $")
29 wlott 1.1
30 gerd 1.14 (in-package "PCL")
31 wlott 1.1
32 gerd 1.14 ;;;
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 ram 1.3
57 gerd 1.14 ;;;
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 wlott 1.1
85 gerd 1.14 (defun standard-compute-effective-method (gf combin applicable-methods)
86 gerd 1.19 (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 gerd 1.20 (declare (special *in-precompute-effective-methods-p*))
97 gerd 1.19 (if *in-precompute-effective-methods-p*
98     (invalid method)
99     (lose method why))))
100 pmai 1.10 (dolist (m applicable-methods)
101     (let ((qualifiers (if (listp m)
102     (early-method-qualifiers m)
103     (method-qualifiers m))))
104 gerd 1.14 (cond ((null qualifiers)
105 gerd 1.19 (primary m))
106 gerd 1.14 ((cdr qualifiers)
107 gerd 1.19 (invalid-method m "has more than one qualifier"))
108 gerd 1.14 ((eq (car qualifiers) :around)
109 gerd 1.19 (around m))
110 gerd 1.14 ((eq (car qualifiers) :before)
111 gerd 1.19 (before m))
112 gerd 1.14 ((eq (car qualifiers) :after)
113 gerd 1.19 (after m))
114 gerd 1.14 (t
115 gerd 1.19 (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 gerd 1.20 ;; arguments, per CLHS 7.6.4, for instance.
133 gerd 1.19 (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 ram 1.5
153 wlott 1.1 (defvar *invalid-method-error*
154 pmai 1.11 (lambda (&rest args)
155     (declare (ignore args))
156     (error
157 gerd 1.14 "~@<~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 wlott 1.1
163     (defvar *method-combination-error*
164 pmai 1.11 (lambda (&rest args)
165     (declare (ignore args))
166     (error
167 gerd 1.14 "~@<~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 wlott 1.1
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 gerd 1.14 (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 gerd 1.16 ;;; call of an effective method of generic function GF with body
289 gerd 1.14 ;;; 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 gerd 1.16 (let* ((name (generic-function-name* gf))
296     (fmc-info (cons nreq applyp))
297 gerd 1.14 (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 gerd 1.16 (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 gerd 1.14
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 gerd 1.16 ;;
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 gerd 1.14 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
438 gerd 1.16 (check-applicable-keywords
439     (when (and applyp (emfs-must-check-applicable-keywords-p gf))
440     '((check-applicable-keywords))))
441 gerd 1.19 (error-p
442     (memq (first body) '(%no-primary-method %invalid-qualifiers)))
443 gerd 1.14 (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 gerd 1.16 ,@check-applicable-keywords
463 gerd 1.14 ,body))))
464     (t
465     `(lambda ,ll
466     (declare (ignore .pv-cell. .next-method-call.))
467 gerd 1.16 ,@check-applicable-keywords
468 gerd 1.14 ,body))))))
469    
470 gerd 1.17 ;;;
471 gerd 1.21 ;;; 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 gerd 1.17 ;;; 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 gerd 1.21 ;;; required emf parameters. REST? true means the method has a &rest
486 gerd 1.17 ;;; 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 gerd 1.21 (loop for call-method-form in (cdr call-method-list)
504     collect (second call-method-form)))
505 gerd 1.17
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 gerd 1.14 (defun memf-test-converter (form gf method-alist-p wrappers-p)
515 gerd 1.21 (flet ((method-key (method)
516     (if (inlinable-method-p method)
517     (method-function-name method)
518     '.fast-call-method.)))
519     (case (car-safe form)
520     ;;
521     (call-method
522     (if (eq (get-method-call-type gf form method-alist-p wrappers-p)
523     'fast-method-call)
524     (method-key (second form))
525     '.call-method.))
526     ;;
527     (call-method-list
528     (if (eq (get-method-list-call-type gf form method-alist-p wrappers-p)
529     'fast-method-call)
530     (mapcar #'method-key (call-method-list-methods form))
531     '.call-method-list.))
532     ;;
533     (check-applicable-keywords
534     'check-applicable-keywords)
535     (t
536     (default-test-converter form)))))
537 gerd 1.14
538 gerd 1.17 ;;;
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 gerd 1.21 (defun memf-code-converter (form gf metatypes rest? method-alist-p
545 gerd 1.14 wrappers-p)
546 gerd 1.21 (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 gerd 1.14
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 gerd 1.16 (check-applicable-keywords
598     '(.keyargs-start. .valid-keys.))
599 gerd 1.14 (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 gerd 1.16 (defvar *applicable-methods*)
655    
656 gerd 1.14 (defun make-callable (gf methods generator method-alist wrappers)
657 gerd 1.16 (let* ((*applicable-methods* methods)
658     (callable (function-funcall generator method-alist wrappers)))
659 gerd 1.17 (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 gerd 1.14
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 gerd 1.16 (gf-name (generic-function-name* gf))
687 gerd 1.14 (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 ram 1.2
714 gerd 1.14 ;;; end of combin.lisp

  ViewVC Help
Powered by ViewVC 1.1.5