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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (hide annotations)
Sun May 25 14:33:50 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.15: +156 -28 lines
	CLHS 7.6.5 keyword argument checking for calls to generic
	functions.  Found by Paul Dietz, of course.  This also includes
	some minor code cleanup and a fix for a bug caused by a typo.

	* src-gf/pcl/std-class.lisp
	(compute-effective-slot-definition-initargs):
	Reformatted to make it readable on a tty.

	* src-gf/pcl/methods.lisp (set-condition-svuc-method): Fix a typo.

	* src-gf/pcl/low.lisp (parse-lambda-list): Add an ignore
	declaration.

	* src-gf/pcl/init.lisp (valid-initargs): Use method-lambda-list*.

	* src-gf/pcl/dfun.lisp (use-caching-dfun-p): Use
	generic-function-methods*.
	(use-constant-value-dfun-p): Ditto.
	(use-dispatch-dfun-p): Don't use dispatching dfuns when we must
	check keyword arguments according to CLHS 7.6.5, because this
	computes emfs for sets methods that aren't applicable together in
	the usual sense; this screws up emf keyword argument checking, of
	course.
	(make-initial-dfun): Use gf-arg-info*.
	(update-dfun): Use generic-function-name*.
	(final-accessor-dfun-type, make-accessor-table)
	(compute-applicable-methods-using-types)
	(compute-applicable-methods-using-types): Likewise.

	* src-gf/pcl/combin.lisp (standard-compute-effective-method):
	Don't use the single-call-method optimization if we must
	check keyword arguments according to CLHS 7.6.5.
	(callable-generator-for-emf): Rewritten to add a keyword
	argument check to the emf.
	(emfs-must-check-applicable-keywords-p)
	(compute-applicable-keywords, check-applicable-keywords):
	New functions.
	(odd-number-of-keyword-arguments, invalid-keyword-argument):
	Moved here from boot.lisp.
	(make-effective-method-lambda): Add a check-applicable-keywords
	form to the emf, if appropriate.
	(memf-test-converter, memf-code-converter)
	(memf-constant-converter): Deal with check-applicable-keywords.
	(*applicable-methods*): New variable.
	(make-callable): Bind it.
	(make-emf-name): Use generic-function-name*.

	* src/pcl/braid.lisp (ensure-non-standard-class): Remove
	an used branch.

	* src/pcl/boot.lisp (*make-method-lambda-gf-name*): Removed.
	(expand-defmethod): Don't bind it.
	(make-method-lambda-internal): Don't add &key to the method
	function's lambda-list if the gf has &key.
	(bind-args): Rewritten.  Don't do keyword checking as this is
	done in emfs now.
	(get-key-arg, get-key-arg1): Simplified; do less checking.
	(generic-function-name*, generic-function-methods*)
	(gf-arg-info*, method-lambda-list*): New functions.
	(check-method-arg-info): Use them.
	(gf-lambda-list-from-method): New function.
	(gf-lambda-list): Use it.  Don't add &allow-other-keys to a
	gf's lambda-list if a method has &key.
	(get-generic-function-info): Use gf-arg-info*.
	(parse-specialized-lambda-list): Add an ignore declaration.
	(odd-number-of-keyword-arguments, invalid-keyword-argument):
	Moved to combin.lisp.
	(check-generic-function-lambda-list): Remove &more stuff
	because that's checked elsewhere now (and Python can even
	tell it is).

	* src-gf/pcl/ctor.lisp (install-optimized-constructor): Remove
	an unmatched ).
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.16 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/combin.lisp,v 1.16 2003/05/25 14:33:50 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     (defun memf-test-converter (form gf method-alist-p wrappers-p)
470     (case (car-safe form)
471     (call-method
472     (case (get-method-call-type gf form method-alist-p wrappers-p)
473     (fast-method-call '.fast-call-method.)
474     (t '.call-method.)))
475     (call-method-list
476     (case (get-method-list-call-type gf form method-alist-p wrappers-p)
477     (fast-method-call '.fast-call-method-list.)
478     (t '.call-method-list.)))
479 gerd 1.16 (check-applicable-keywords
480     'check-applicable-keywords)
481 gerd 1.14 (t
482     (default-test-converter form))))
483    
484     (defun memf-code-converter (form gf metatypes applyp method-alist-p
485     wrappers-p)
486     (case (car-safe form)
487     (call-method
488     (let ((gensym (gensym "MEMF")))
489     (values (make-emf-call metatypes applyp gensym
490     (get-method-call-type gf form method-alist-p
491     wrappers-p))
492     (list gensym))))
493     (call-method-list
494     (let ((gensym (gensym "MEMF"))
495     (type (get-method-list-call-type gf form method-alist-p
496     wrappers-p)))
497     (values `(dolist (emf ,gensym nil)
498     ,(make-emf-call metatypes applyp 'emf type))
499     (list gensym))))
500 gerd 1.16 (check-applicable-keywords
501     (values `(check-applicable-keywords .dfun-rest-arg.
502     .keyargs-start. .valid-keys.)
503     '(.keyargs-start. .valid-keys.)))
504 gerd 1.14 (t
505     (default-code-converter form))))
506    
507     (defun memf-constant-converter (form gf)
508     (case (car-safe form)
509     (call-method
510     (list (cons '.meth.
511     (callable-generator-for-call-method gf form))))
512     (call-method-list
513     (list (cons '.meth-list.
514     (mapcar (lambda (form)
515     (callable-generator-for-call-method gf form))
516     (cdr form)))))
517 gerd 1.16 (check-applicable-keywords
518     '(.keyargs-start. .valid-keys.))
519 gerd 1.14 (t
520     (default-constant-converter form))))
521    
522     (defun get-method-list-call-type (gf form method-alist-p wrappers-p)
523     (if (every (lambda (form)
524     (eq 'fast-method-call
525     (get-method-call-type gf form method-alist-p wrappers-p)))
526     (cdr form))
527     'fast-method-call
528     t))
529    
530     (defun get-method-call-type (gf form method-alist-p wrappers-p)
531     (if (eq 'call-method (car-safe form))
532     (destructuring-bind (method &rest cm-args) (cdr form)
533     (declare (ignore cm-args))
534     (when method
535     (if (if (listp method)
536     (eq (car method) :early-method)
537     (method-p method))
538     (if method-alist-p
539     t
540     (multiple-value-bind (mf fmf)
541     (if (listp method)
542     (early-method-function method)
543     (values nil (method-fast-function method)))
544     (declare (ignore mf))
545     (let ((pv-table (and fmf (method-function-pv-table fmf))))
546     (if (and fmf (or (null pv-table) wrappers-p))
547     'fast-method-call
548     'method-call))))
549     (if (eq 'make-method (car-safe method))
550     (get-method-call-type gf (cadr method) method-alist-p
551     wrappers-p)
552     (type-of method)))))
553     'fast-method-call))
554    
555    
556     ;;; **************************************
557     ;;; Generating Callables for EMFs *******
558     ;;; **************************************
559    
560     ;;;
561     ;;; Turned off until problems with method tracing caused by it are
562     ;;; solved (reason unknown). Will be needed once inlining of methods
563     ;;; in effective methods and inlining of effective method in callers
564     ;;; gets accute.
565     ;;;
566     (defvar *named-emfs-p* nil)
567    
568     ;;;
569     ;;; Return a callable object for an emf of generic function GF, with
570     ;;; applicable methods METHODS. GENERATOR is a function returned from
571     ;;; CALLABLE-GENERATOR. Call it with two args METHOD-ALIST and
572     ;;; WRAPPERS to obtain the actual callable.
573     ;;;
574 gerd 1.16 (defvar *applicable-methods*)
575    
576 gerd 1.14 (defun make-callable (gf methods generator method-alist wrappers)
577 gerd 1.16 (let* ((*applicable-methods* methods)
578     (callable (function-funcall generator method-alist wrappers)))
579 gerd 1.14 (set-emf-name gf methods callable)))
580    
581     ;;;
582     ;;; When *NAME-EMFS-P* is true, give the effective method represented
583     ;;; by CALLABLE a suitable global name of the form (EFFECTIVE-METHOD
584     ;;; ...). GF is the generic function the effective method is for, and
585     ;;; METHODS is the list of applicable methods.
586     ;;;
587     (defun set-emf-name (gf methods callable)
588     (when *named-emfs-p*
589     (let ((function (typecase callable
590     (fast-method-call (fast-method-call-function callable))
591     (method-call (method-call-function callable))
592     (t callable)))
593     (name (make-emf-name gf methods)))
594     (setf (fdefinition name) function)
595     (set-function-name function name)))
596     callable)
597    
598     ;;;
599     ;;; Return a name for an effective method of generic function GF,
600     ;;; composed of applicable methods METHODS.
601     ;;;
602     ;;; In general, the name cannot be based on the methods alone, because
603     ;;; that doesn't take method combination arguments into account.
604     ;;;
605     ;;; It is possible to do better for the standard method combination,
606     ;;; though. The current name format is
607     ;;;
608     ;;; (EFFECTIVE-METHOD gf-name around-methods before-methods
609     ;;; primary-method after-methods)
610     ;;;
611     ;;; where each method is a list (METHOD qualifiers specializers).
612     ;;;
613     (defvar *emf-name-table* (make-hash-table :test 'equal))
614    
615     (defun make-emf-name (gf methods)
616     (let* ((early-p (early-gf-p gf))
617 gerd 1.16 (gf-name (generic-function-name* gf))
618 gerd 1.14 (emf-name
619     (if (or early-p
620     (eq (generic-function-method-combination gf)
621     *standard-method-combination*))
622     (let (primary around before after)
623     (dolist (m methods)
624     (let ((qual (if early-p
625     (early-method-qualifiers m)
626     (method-qualifiers m)))
627     (specl (if early-p
628     (early-method-specializers m)
629     (unparse-specializers
630     (method-specializers m)))))
631     (case (car-safe qual)
632     (:around (push `(method :around ,specl) around))
633     (:before (push `(method :before ,specl) before))
634     (:after (push `(method :after ,specl) after))
635     (t (push `(method ,specl) primary)))))
636     `(effective-method ,gf-name
637     ,@(nreverse around)
638     ,@(nreverse before)
639     ,@(list (last primary))
640     ,@after))
641     `(effective-method ,gf-name ,(gensym)))))
642     (or (gethash emf-name *emf-name-table*)
643     (setf (gethash emf-name *emf-name-table*) emf-name))))
644 ram 1.2
645 gerd 1.14 ;;; end of combin.lisp

  ViewVC Help
Powered by ViewVC 1.1.5