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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23.6.1 - (hide annotations)
Mon Dec 19 01:10:21 2005 UTC (8 years, 3 months ago) by rtoy
Branch: ppc_gencgc_branch
CVS Tags: ppc_gencgc_snap_2006-01-06, ppc_gencgc_snap_2005-12-17
Changes since 1.23: +5 -2 lines
Merge code from main branch of 2005-12-17 to ppc gencgc branch.  Still
doesn't work of course.
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.23.6.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/combin.lisp,v 1.23.6.1 2005/12/19 01:10:21 rtoy 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 rtoy 1.23.6.1 ;;
182     ;; Hack: The PROGN is here so that RESTART-CASE doesn't see the
183     ;; ERROR. See MUNGE-RESTART-CASE-EXPRESSION in code:error.lisp.
184     `(progn (error "~@<~S used outside of a effective method form.~@:>" 'call-method)))
185 gerd 1.14
186     (defmacro call-method-list (&rest calls)
187     `(progn ,@calls))
188    
189     (defun make-call-methods (methods)
190     `(call-method-list
191     ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
192    
193    
194     ;;; ****************************************************
195     ;;; Translating effective method bodies to Code *******
196     ;;; ****************************************************
197    
198     (defun get-callable (gf form method-alist wrappers)
199     (funcall (callable-generator gf form method-alist wrappers)
200     method-alist wrappers))
201    
202     (defun callable-generator (gf form method-alist-p wrappers-p)
203     (if (eq 'call-method (car-safe form))
204     (callable-generator-for-call-method gf form)
205     (callable-generator-for-emf gf form method-alist-p wrappers-p)))
206    
207     ;;;
208     ;;; If the effective method is just a call to CALL-METHOD, this opens
209     ;;; up the possibility of just using the method function of the method
210     ;;; as the effective method function.
211     ;;;
212     ;;; But we have to be careful. If that method function will ask for
213     ;;; the next methods we have to provide them. We do not look to see
214     ;;; if there are next methods, we look at whether the method function
215     ;;; asks about them. If it does, we must tell it whether there are
216     ;;; or aren't to prevent the leaky next methods bug.
217     ;;;
218     (defun callable-generator-for-call-method (gf form)
219     (let* ((cm-args (cdr form))
220     (fmf-p (and (or (not (eq *boot-state* 'complete))
221     (gf-fast-method-function-p gf))
222     (null (cddr cm-args))))
223     (method (car cm-args))
224     (cm-args1 (cdr cm-args)))
225     (lambda (method-alist wrappers)
226     (callable-for-call-method gf method cm-args1 fmf-p method-alist
227     wrappers))))
228    
229     (defun callable-for-call-method (gf method cm-args fmf-p method-alist wrappers)
230     (cond ((null method)
231     nil)
232     ((if (listp method)
233     (eq (car method) :early-method)
234     (method-p method))
235     (get-method-callable method cm-args gf fmf-p method-alist wrappers))
236     ((eq 'make-method (car-safe method))
237     (get-callable gf (cadr method) method-alist wrappers))
238     (t
239     method)))
240    
241     ;;;
242     ;;; Return a FAST-METHOD-CALL structure, a METHOD-CALL structure, or a
243     ;;; method function for calling METHOD.
244     ;;;
245     (defun get-method-callable (method cm-args gf fmf-p method-alist wrappers)
246     (multiple-value-bind (mf real-mf-p fmf pv-cell)
247     (get-method-function method method-alist wrappers)
248     (cond (fmf
249     (let* ((next-methods (car cm-args))
250     (next (callable-for-call-method gf (car next-methods)
251     (list* (cdr next-methods)
252     (cdr cm-args))
253     fmf-p method-alist wrappers))
254     (arg-info (method-function-get fmf :arg-info)))
255     (make-fast-method-call :function fmf
256     :pv-cell pv-cell
257     :next-method-call next
258     :arg-info arg-info)))
259     (real-mf-p
260     (make-method-call :function mf :call-method-args cm-args))
261     (t mf))))
262    
263     (defun get-method-function (method method-alist wrappers)
264     (let ((fn (cadr (assoc method method-alist))))
265     (if fn
266     (values fn nil nil nil)
267     (multiple-value-bind (mf fmf)
268     (if (listp method)
269     (early-method-function method)
270     (values nil (method-fast-function method)))
271     (let ((pv-table (and fmf (method-function-pv-table fmf))))
272     (if (and fmf
273     (not (and pv-table (pv-table-computing-cache-p pv-table)))
274     (or (null pv-table) wrappers))
275     (let* ((pv-wrappers (when pv-table
276     (pv-wrappers-from-all-wrappers
277     pv-table wrappers)))
278     (pv-cell (when (and pv-table pv-wrappers)
279     (pv-table-lookup pv-table pv-wrappers))))
280     (values mf t fmf pv-cell))
281     (values
282     (or mf (if (listp method)
283     (setf (cadr method)
284     (method-function-from-fast-function fmf))
285     (method-function method)))
286     t nil nil)))))))
287    
288    
289     ;;;
290     ;;; Return a closure returning a FAST-METHOD-CALL instance for the
291 gerd 1.16 ;;; call of an effective method of generic function GF with body
292 gerd 1.14 ;;; BODY.
293     ;;;
294     (defun callable-generator-for-emf (gf body method-alist-p wrappers-p)
295     (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
296     (get-generic-function-info gf)
297     (declare (ignore nkeys arg-info))
298 gerd 1.16 (let* ((name (generic-function-name* gf))
299     (fmc-info (cons nreq applyp))
300 gerd 1.14 (effective-method-lambda (make-effective-method-lambda gf body)))
301     (multiple-value-bind (cfunction constants)
302     (get-function1 effective-method-lambda
303     (lambda (form)
304     (memf-test-converter form gf method-alist-p
305     wrappers-p))
306     (lambda (form)
307     (memf-code-converter form gf metatypes applyp
308     method-alist-p wrappers-p))
309     (lambda (form)
310     (memf-constant-converter form gf)))
311     (lambda (method-alist wrappers)
312 gerd 1.16 (declare (special *applicable-methods*))
313     (multiple-value-bind (valid-keys keyargs-start)
314     (when (memq '.valid-keys. constants)
315     (compute-applicable-keywords gf *applicable-methods*))
316     (flet ((compute-constant (constant)
317     (if (consp constant)
318     (case (car constant)
319     (.meth.
320     (funcall (cdr constant) method-alist wrappers))
321     (.meth-list.
322     (mapcar (lambda (fn)
323     (funcall fn method-alist wrappers))
324     (cdr constant)))
325     (t constant))
326     (case constant
327     (.keyargs-start. keyargs-start)
328     (.valid-keys. valid-keys)
329     (t constant)))))
330     (let ((fn (apply cfunction
331     (mapcar #'compute-constant constants))))
332     (set-function-name fn `(effective-method ,name))
333     (make-fast-method-call :function fn :arg-info fmc-info)))))))))
334    
335     ;;;
336     ;;; Return true if emfs of generic function GF must do keyword
337     ;;; argument checking with CHECK-APPLICABLE-KEYWORDS.
338     ;;;
339     ;;; We currently do this if the generic function type has &KEY, which
340     ;;; should be the case if the gf or any method has &KEY. It would be
341     ;;; possible to avoid the check if it also has &ALLOW-OTHER-KEYS, iff
342     ;;; method functions do checks of their own, which is ugly to do,
343     ;;; so we don't.
344     ;;;
345     (defun emfs-must-check-applicable-keywords-p (gf)
346     (let ((type (info function type (generic-function-name* gf))))
347     (and (kernel::function-type-p type)
348     (kernel::function-type-keyp type))))
349    
350     ;;;
351     ;;; Compute which keyword args are valid in a call of generic function
352     ;;; GF with applicable methods METHODS. See also CLHS 7.6.5.
353     ;;;
354     ;;; First value is either a list of valid keywords or T meaning all
355     ;;; keys are valid. Second value is the number of optional arguments
356     ;;; that GF takes. This number is used as an offset in the supplied
357     ;;; args .DFUN-REST-ARG. in CHECK-APPLICABLE-KEYWORDS.
358     ;;;
359     (defun compute-applicable-keywords (gf methods)
360     (let ((any-keyp nil))
361     (flet ((analyze (lambda-list)
362     (multiple-value-bind (nreq nopt keyp restp allowp keys)
363     (analyze-lambda-list lambda-list)
364     (declare (ignore nreq restp))
365     (when keyp
366     (setq any-keyp t))
367     (values nopt allowp keys))))
368     (multiple-value-bind (nopt allowp keys)
369     (analyze (generic-function-lambda-list gf))
370     (if allowp
371     (setq keys t)
372     (dolist (method methods)
373     (multiple-value-bind (n allowp method-keys)
374     (analyze (method-lambda-list* method))
375     (declare (ignore n))
376     (if allowp
377     (return (setq keys t))
378     (setq keys (union method-keys keys))))))
379     ;;
380     ;; It shouldn't happen thet neither the gf nor any method has
381     ;; &KEY, when this method is called. Let's handle the case
382     ;; anyway, just for generality.
383     (values (if any-keyp keys t) nopt)))))
384    
385     ;;;
386     ;;; Check ARGS for invalid keyword arguments, beginning at position
387     ;;; START in ARGS. VALID-KEYS is a list of valid keywords. VALID-KEYS
388     ;;; being T means all keys are valid.
389     ;;;
390     (defun check-applicable-keywords (args start valid-keys)
391     (let ((allow-other-keys-seen nil)
392     (allow-other-keys nil)
393     (args (nthcdr start args)))
394     (collect ((invalid))
395     (loop
396     (when (null args)
397     (when (and (invalid) (not allow-other-keys))
398     (simple-program-error
399     "~@<Invalid keyword argument~p ~{~s~^, ~}. ~
400     Valid keywords are: ~{~s~^, ~}.~@:>"
401     (length (invalid))
402     (invalid)
403     valid-keys))
404     (return))
405     (let ((key (pop args)))
406     (cond ((not (symbolp key))
407     (invalid-keyword-argument key))
408     ((null args)
409     (odd-number-of-keyword-arguments))
410     ((eq key :allow-other-keys)
411     (unless allow-other-keys-seen
412     (setq allow-other-keys-seen t
413     allow-other-keys (car args))))
414     ((eq t valid-keys))
415     ((not (memq key valid-keys))
416     (invalid key))))
417     (pop args)))))
418    
419     (defun odd-number-of-keyword-arguments ()
420     (simple-program-error "Odd number of keyword arguments."))
421    
422     (defun invalid-keyword-argument (key)
423     (simple-program-error "Invalid keyword argument ~s" key))
424 gerd 1.14
425     ;;;
426     ;;; Return a lambda-form for an effective method of generic function
427     ;;; GF with body BODY.
428     ;;;
429     (defun make-effective-method-lambda (gf body)
430     (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
431     (get-generic-function-info gf)
432     (declare (ignore nreq nkeys arg-info))
433 gerd 1.16 ;;
434     ;; Note that emfs use the same lambda-lists as fast method
435     ;; functions, although they don't need all the arguments that a
436     ;; fast method function needs, because this makes it possible to
437     ;; use fast method functions directly as emfs. This is achieved
438     ;; by returning a single CALL-METHOD form from the method
439     ;; combination.
440 gerd 1.14 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
441 gerd 1.16 (check-applicable-keywords
442     (when (and applyp (emfs-must-check-applicable-keywords-p gf))
443     '((check-applicable-keywords))))
444 gerd 1.19 (error-p
445     (memq (first body) '(%no-primary-method %invalid-qualifiers)))
446 gerd 1.14 (mc-args-p
447     (when (eq *boot-state* 'complete)
448     ;; Otherwise the METHOD-COMBINATION slot is not bound.
449     (let ((combin (generic-function-method-combination gf)))
450     (and (long-method-combination-p combin)
451     (long-method-combination-args-lambda-list combin))))))
452     (cond (error-p
453     `(lambda (.pv-cell. .next-method-call. &rest .args.)
454     (declare (ignore .pv-cell. .next-method-call.))
455     ,body))
456     (mc-args-p
457     (let* ((required (dfun-arg-symbol-list metatypes))
458     (gf-args (if applyp
459     `(list* ,@required .dfun-rest-arg.)
460     `(list ,@required))))
461     `(lambda ,ll
462     (declare (ignore .pv-cell. .next-method-call.))
463     (let ((.gf-args. ,gf-args))
464     (declare (ignorable .gf-args.))
465 gerd 1.16 ,@check-applicable-keywords
466 gerd 1.14 ,body))))
467     (t
468     `(lambda ,ll
469     (declare (ignore .pv-cell. .next-method-call.))
470 gerd 1.16 ,@check-applicable-keywords
471 gerd 1.14 ,body))))))
472    
473 gerd 1.17 ;;;
474 gerd 1.21 ;;; Return true if a fast-method-call to METHOD can be inlined.
475     ;;;
476     ;;; We don't generate funcalls for standard accessor methods because
477     ;;; they have a fast function, but that's not what is actually to be
478     ;;; called. What is called is a closure over MAKE-STD-*-METHOD-FUNCTION.
479     ;;;
480     (defun inlinable-method-p (method)
481     (and (eq *boot-state* 'complete)
482     *inline-methods-in-emfs*
483     (not (standard-accessor-method-p method))))
484    
485     ;;;
486 gerd 1.17 ;;; Return a form for calling METHOD's fast function. METATYPES is a
487     ;;; list of metatypes, whose length is used to figure out the names of
488 gerd 1.21 ;;; required emf parameters. REST? true means the method has a &rest
489 gerd 1.17 ;;; arg. CALLABLE-VAR is the name of a closed-over variable
490     ;;; containing a FAST-METHOD-CALL instance corresponding to the
491     ;;; method invocation.
492     ;;;
493     (defun make-direct-call (method metatypes rest? callable-var)
494     (let* ((fn-name (method-function-name method))
495     (fn `(the function #',fn-name))
496     (cell `(fast-method-call-pv-cell ,callable-var))
497     (next `(fast-method-call-next-method-call ,callable-var))
498     (req (dfun-arg-symbol-list metatypes)))
499     (assert (fboundp fn-name))
500     `(funcall ,fn ,cell ,next ,@req ,@(when rest? `(.dfun-rest-arg.)))))
501    
502     ;;;
503     ;;; Return the list of methods from a CALL-METHOD-LIST form.
504     ;;;
505     (defun call-method-list-methods (call-method-list)
506 gerd 1.21 (loop for call-method-form in (cdr call-method-list)
507     collect (second call-method-form)))
508 gerd 1.17
509     ;;;
510     ;;; Compute a key from FORM. This function is called via the
511     ;;; GET-FUNCTION mechanism on forms of an emf lambda. Values returned
512     ;;; that are not EQ to FORM are considered keys. All keys are
513     ;;; collected and serve GET-FUNCTION as a key in its table of already
514     ;;; computed functions. That is, if two emf lambdas produce the same
515     ;;; key, a previously compiled function can be used.
516     ;;;
517 gerd 1.14 (defun memf-test-converter (form gf method-alist-p wrappers-p)
518 gerd 1.21 (flet ((method-key (method)
519 rtoy 1.22 (cond ((inlinable-method-p method)
520     (method-function-name method))
521     ((eq (get-method-call-type gf form method-alist-p wrappers-p)
522     'fast-method-call)
523     '.fast-call-method.)
524 rtoy 1.23 (t '.call-method.))))
525 gerd 1.21 (case (car-safe form)
526     ;;
527     (call-method
528     (if (eq (get-method-call-type gf form method-alist-p wrappers-p)
529     'fast-method-call)
530     (method-key (second form))
531     '.call-method.))
532     ;;
533     (call-method-list
534 rtoy 1.22 (mapcar #'method-key (call-method-list-methods form)))
535 gerd 1.21 ;;
536     (check-applicable-keywords
537     'check-applicable-keywords)
538     (t
539     (default-test-converter form)))))
540 gerd 1.14
541 gerd 1.17 ;;;
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 gerd 1.21 (defun memf-code-converter (form gf metatypes rest? method-alist-p
548 gerd 1.14 wrappers-p)
549 gerd 1.21 (labels ((make-call (call-type method metatypes rest? callable-var)
550     (if (and (eq call-type 'fast-method-call)
551     (inlinable-method-p method))
552     (make-direct-call method metatypes rest? callable-var)
553     (make-emf-call metatypes rest? callable-var call-type)))
554    
555     (make-calls (call-type methods metatypes rest? list-var)
556     `(let ((.list. ,list-var))
557     (declare (ignorable .list.))
558     ,@(loop for method in methods collect
559     `(let ((.call. (pop .list.)))
560     ,(make-call call-type method metatypes
561     rest? '.call.))))))
562     (case (car-safe form)
563     ;;
564     ;; (CALL-METHOD <method-object> &optional <next-methods>)
565     (call-method
566     (let ((method (cadr form))
567     (callable-var (gensym))
568     (call-type (get-method-call-type gf form method-alist-p
569     wrappers-p)))
570     (values (make-call call-type method metatypes rest? callable-var)
571     (list callable-var))))
572     ;;
573     ;; (CALL-METHOD-LIST <call-method-form>*)
574     ;; where each CALL-METHOD form is (CALL-METHOD <method>)
575     (call-method-list
576     (let ((list-var (gensym))
577     (call-type (get-method-list-call-type gf form method-alist-p
578     wrappers-p))
579     (methods (call-method-list-methods form)))
580     (values (make-calls call-type methods metatypes rest? list-var)
581     (list list-var))))
582     ;;
583     (check-applicable-keywords
584     (values `(check-applicable-keywords .dfun-rest-arg.
585     .keyargs-start. .valid-keys.)
586     '(.keyargs-start. .valid-keys.)))
587     (t
588     (default-code-converter form)))))
589 gerd 1.14
590     (defun memf-constant-converter (form gf)
591     (case (car-safe form)
592     (call-method
593     (list (cons '.meth.
594     (callable-generator-for-call-method gf form))))
595     (call-method-list
596     (list (cons '.meth-list.
597     (mapcar (lambda (form)
598     (callable-generator-for-call-method gf form))
599     (cdr form)))))
600 gerd 1.16 (check-applicable-keywords
601     '(.keyargs-start. .valid-keys.))
602 gerd 1.14 (t
603     (default-constant-converter form))))
604    
605     (defun get-method-list-call-type (gf form method-alist-p wrappers-p)
606     (if (every (lambda (form)
607     (eq 'fast-method-call
608     (get-method-call-type gf form method-alist-p wrappers-p)))
609     (cdr form))
610     'fast-method-call
611     t))
612    
613     (defun get-method-call-type (gf form method-alist-p wrappers-p)
614     (if (eq 'call-method (car-safe form))
615     (destructuring-bind (method &rest cm-args) (cdr form)
616     (declare (ignore cm-args))
617     (when method
618     (if (if (listp method)
619     (eq (car method) :early-method)
620     (method-p method))
621     (if method-alist-p
622     t
623     (multiple-value-bind (mf fmf)
624     (if (listp method)
625     (early-method-function method)
626     (values nil (method-fast-function method)))
627     (declare (ignore mf))
628     (let ((pv-table (and fmf (method-function-pv-table fmf))))
629     (if (and fmf (or (null pv-table) wrappers-p))
630     'fast-method-call
631     'method-call))))
632     (if (eq 'make-method (car-safe method))
633     (get-method-call-type gf (cadr method) method-alist-p
634     wrappers-p)
635     (type-of method)))))
636     'fast-method-call))
637    
638    
639     ;;; **************************************
640     ;;; Generating Callables for EMFs *******
641     ;;; **************************************
642    
643     ;;;
644     ;;; Turned off until problems with method tracing caused by it are
645     ;;; solved (reason unknown). Will be needed once inlining of methods
646     ;;; in effective methods and inlining of effective method in callers
647     ;;; gets accute.
648     ;;;
649     (defvar *named-emfs-p* nil)
650    
651     ;;;
652     ;;; Return a callable object for an emf of generic function GF, with
653     ;;; applicable methods METHODS. GENERATOR is a function returned from
654     ;;; CALLABLE-GENERATOR. Call it with two args METHOD-ALIST and
655     ;;; WRAPPERS to obtain the actual callable.
656     ;;;
657 gerd 1.16 (defvar *applicable-methods*)
658    
659 gerd 1.14 (defun make-callable (gf methods generator method-alist wrappers)
660 gerd 1.16 (let* ((*applicable-methods* methods)
661     (callable (function-funcall generator method-alist wrappers)))
662 gerd 1.17 (when *named-emfs-p*
663     (let ((fn (etypecase callable
664     (fast-method-call (fast-method-call-function callable))
665     (method-call (method-call-function callable))
666     (function callable))))
667     (setf (fdefinition (make-emf-name gf methods)) fn)))
668     callable))
669 gerd 1.14
670     ;;;
671     ;;; Return a name for an effective method of generic function GF,
672     ;;; composed of applicable methods METHODS.
673     ;;;
674     ;;; In general, the name cannot be based on the methods alone, because
675     ;;; that doesn't take method combination arguments into account.
676     ;;;
677     ;;; It is possible to do better for the standard method combination,
678     ;;; though. The current name format is
679     ;;;
680     ;;; (EFFECTIVE-METHOD gf-name around-methods before-methods
681     ;;; primary-method after-methods)
682     ;;;
683     ;;; where each method is a list (METHOD qualifiers specializers).
684     ;;;
685     (defvar *emf-name-table* (make-hash-table :test 'equal))
686    
687     (defun make-emf-name (gf methods)
688     (let* ((early-p (early-gf-p gf))
689 gerd 1.16 (gf-name (generic-function-name* gf))
690 gerd 1.14 (emf-name
691     (if (or early-p
692     (eq (generic-function-method-combination gf)
693     *standard-method-combination*))
694     (let (primary around before after)
695     (dolist (m methods)
696     (let ((qual (if early-p
697     (early-method-qualifiers m)
698     (method-qualifiers m)))
699     (specl (if early-p
700     (early-method-specializers m)
701     (unparse-specializers
702     (method-specializers m)))))
703     (case (car-safe qual)
704     (:around (push `(method :around ,specl) around))
705     (:before (push `(method :before ,specl) before))
706     (:after (push `(method :after ,specl) after))
707     (t (push `(method ,specl) primary)))))
708     `(effective-method ,gf-name
709     ,@(nreverse around)
710     ,@(nreverse before)
711     ,@(list (last primary))
712     ,@after))
713     `(effective-method ,gf-name ,(gensym)))))
714     (or (gethash emf-name *emf-name-table*)
715     (setf (gethash emf-name *emf-name-table*) emf-name))))
716 ram 1.2
717 gerd 1.14 ;;; end of combin.lisp

  ViewVC Help
Powered by ViewVC 1.1.5