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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

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

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

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

  ViewVC Help
Powered by ViewVC 1.1.5