1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
26 ;;; FIXME: according to ANSI 3.4.10 this is supposed to allow &WHOLE
27 ;;; in the long syntax. But it clearly does not, because if you write
28 ;;; (&WHOLE v) then you get (LAMBDA (&WHOLE V ...) ...) which is illegal
30 (defmacro define-method-combination
(&whole form
&rest args
)
31 (declare (ignore args
))
33 (with-single-package-locked-error
34 (:symbol
',(second form
) "defining ~A as a method combination"))
37 (expand-long-defcombin form
)
38 (expand-short-defcombin form
))))
40 ;;;; standard method combination
42 ;;; The STANDARD method combination type is implemented directly by
43 ;;; the class STANDARD-METHOD-COMBINATION. The method on
44 ;;; COMPUTE-EFFECTIVE-METHOD does standard method combination directly
45 ;;; and is defined by hand in the file combin.lisp. The method for
46 ;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping
48 (defmethod find-method-combination ((generic-function generic-function
)
49 (type-name (eql 'standard
))
52 (method-combination-error
53 "STANDARD method combination accepts no options."))
54 *standard-method-combination
*)
56 ;;;; short method combinations
58 ;;;; Short method combinations all follow the same rule for computing the
59 ;;;; effective method. So, we just implement that rule once. Each short
60 ;;;; method combination object just reads the parameters out of the object
61 ;;;; and runs the same rule.
63 (defun expand-short-defcombin (whole)
64 (let* ((type-name (cadr whole
))
66 (getf (cddr whole
) :documentation
))
67 (identity-with-one-arg
68 (getf (cddr whole
) :identity-with-one-argument nil
))
70 (getf (cddr whole
) :operator type-name
)))
71 `(load-short-defcombin
72 ',type-name
',operator
',identity-with-one-arg
',documentation
73 (sb-c:source-location
))))
75 (defun load-short-defcombin (type-name operator ioa doc source-location
)
77 (list (find-class 'generic-function
)
78 (intern-eql-specializer type-name
)
81 (get-method #'find-method-combination
() specializers nil
))
84 (make-instance 'standard-method
86 :specializers specializers
87 :lambda-list
'(generic-function type-name options
)
88 :function
(lambda (args nms
&rest cm-args
)
89 (declare (ignore nms cm-args
))
91 (lambda (gf type-name options
)
93 (short-combine-methods
94 type-name options operator ioa new-method doc
))
96 :definition-source source-location
))
98 (remove-method #'find-method-combination old-method
))
99 (add-method #'find-method-combination new-method
)
101 (setf (random-documentation type-name
'method-combination
) doc
))
104 (defun short-combine-methods (type-name options operator ioa method doc
)
105 (cond ((null options
) (setq options
'(:most-specific-first
)))
106 ((equal options
'(:most-specific-first
)))
107 ((equal options
'(:most-specific-last
)))
109 (method-combination-error
110 "Illegal options to a short method combination type.~%~
111 The method combination type ~S accepts one option which~%~
112 must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
114 (make-instance 'short-method-combination
118 :identity-with-one-argument ioa
119 :definition-source method
122 (defmethod invalid-qualifiers ((gf generic-function
)
123 (combin short-method-combination
)
125 (let* ((qualifiers (method-qualifiers method
))
126 (qualifier (first qualifiers
))
127 (type-name (method-combination-type-name combin
))
132 "has too many qualifiers")
134 (aver (not (short-method-combination-qualifier-p
135 type-name qualifier
)))
136 "has an invalid qualifier"))))
137 (invalid-method-error
139 "~@<The method ~S on ~S ~A.~
141 The method combination type ~S was defined with the short form ~
142 of DEFINE-METHOD-COMBINATION and so requires all methods have ~
143 either ~{the single qualifier ~S~^ or ~}.~@:>"
144 method gf why type-name
(short-method-combination-qualifiers type-name
))))
146 ;;;; long method combinations
148 (defun expand-long-defcombin (form)
149 (let ((type-name (cadr form
))
150 (lambda-list (caddr form
))
151 (method-group-specifiers (cadddr form
))
155 (when (and (consp (car body
)) (eq (caar body
) :arguments
))
156 (setq args-option
(cdr (pop body
))))
157 (when (and (consp (car body
)) (eq (caar body
) :generic-function
))
158 (setq gf-var
(cadr (pop body
))))
159 (multiple-value-bind (documentation function
)
160 (make-long-method-combination-function
161 type-name lambda-list method-group-specifiers args-option gf-var
163 `(load-long-defcombin ',type-name
',documentation
#',function
164 ',args-option
(sb-c:source-location
)))))
166 (defvar *long-method-combination-functions
* (make-hash-table :test
'eq
))
168 (defun load-long-defcombin
169 (type-name doc function args-lambda-list source-location
)
171 (list (find-class 'generic-function
)
172 (intern-eql-specializer type-name
)
175 (get-method #'find-method-combination
() specializers nil
))
177 (make-instance 'standard-method
179 :specializers specializers
180 :lambda-list
'(generic-function type-name options
)
181 :function
(lambda (args nms
&rest cm-args
)
182 (declare (ignore nms cm-args
))
184 (lambda (generic-function type-name options
)
185 (declare (ignore generic-function
))
186 (make-instance 'long-method-combination
189 :args-lambda-list args-lambda-list
192 :definition-source source-location
)))
193 (setf (gethash type-name
*long-method-combination-functions
*) function
)
194 (when old-method
(remove-method #'find-method-combination old-method
))
195 (add-method #'find-method-combination new-method
)
196 (setf (random-documentation type-name
'method-combination
) doc
)
199 (defmethod compute-effective-method ((generic-function generic-function
)
200 (combin long-method-combination
)
202 (funcall (gethash (method-combination-type-name combin
)
203 *long-method-combination-functions
*)
208 (defun make-long-method-combination-function
209 (type-name ll method-group-specifiers args-option gf-var body
)
210 (declare (ignore type-name
))
211 (multiple-value-bind (real-body declarations documentation
)
214 (wrap-method-group-specifier-bindings method-group-specifiers
218 (push `(,gf-var .generic-function.
) (cadr wrapped-body
)))
221 (setq wrapped-body
(deal-with-args-option wrapped-body args-option
)))
225 `(apply #'(lambda ,ll
,wrapped-body
)
226 (method-combination-options .method-combination.
))))
230 `(lambda (.generic-function. .method-combination. .applicable-methods.
)
231 (declare (ignorable .generic-function.
232 .method-combination. .applicable-methods.
))
233 (block .long-method-combination-function.
,wrapped-body
))))))
235 (define-condition long-method-combination-error
236 (reference-condition simple-error
)
239 :references
(list '(:ansi-cl
:macro define-method-combination
))))
243 ;;; The semantics of long form method combination in the presence of
244 ;;; multiple methods with the same specializers in the same method
245 ;;; group are unclear by the spec: a portion of the standard implies
246 ;;; that an error should be signalled, and another is more lenient.
248 ;;; It is reasonable to allow a single method group of * to bypass all
249 ;;; rules, as this is explicitly stated in the standard.
251 (defun group-cond-clause (name tests specializer-cache star-only
)
252 (let ((maybe-error-clause
254 `(setq ,specializer-cache .specializers.
)
255 `(if (and (equal ,specializer-cache .specializers.
)
256 (not (null .specializers.
)))
257 (return-from .long-method-combination-function.
258 '(error 'long-method-combination-error
259 :format-control
"More than one method of type ~S ~
260 with the same specializers."
261 :format-arguments
(list ',name
)))
262 (setq ,specializer-cache .specializers.
)))))
265 (push .method.
,name
))))
267 (defun wrap-method-group-specifier-bindings
268 (method-group-specifiers declarations real-body
)
269 (let (names specializer-caches cond-clauses required-checks order-cleanups
)
270 (let ((nspecifiers (length method-group-specifiers
)))
271 (dolist (method-group-specifier method-group-specifiers
272 (push `(t (return-from .long-method-combination-function.
273 `(invalid-method-error , .method.
274 "~@<is applicable, but does not belong ~
275 to any method group~@:>")))
277 (multiple-value-bind (name tests description order required
)
278 (parse-method-group-specifier method-group-specifier
)
279 (declare (ignore description
))
280 (let ((specializer-cache (gensym)))
282 (push specializer-cache specializer-caches
)
283 (push (group-cond-clause name tests specializer-cache
284 (and (eq (cadr method-group-specifier
) '*)
288 (push `(when (null ,name
)
289 (return-from .long-method-combination-function.
290 '(error 'long-method-combination-error
291 :format-control
"No ~S methods."
292 :format-arguments
(list ',name
))))
294 (loop (unless (and (constantp order
)
295 (neq order
(setq order
296 (constant-form-value order
))))
298 (push (cond ((eq order
:most-specific-first
)
299 `(setq ,name
(nreverse ,name
)))
300 ((eq order
:most-specific-last
) ())
303 (:most-specific-first
304 (setq ,name
(nreverse ,name
)))
305 (:most-specific-last
))))
307 `(let (,@(nreverse names
) ,@(nreverse specializer-caches
))
309 (dolist (.method. .applicable-methods.
)
310 (let ((.qualifiers.
(method-qualifiers .method.
))
311 (.specializers.
(method-specializers .method.
)))
312 (declare (ignorable .qualifiers. .specializers.
))
313 (cond ,@(nreverse cond-clauses
))))
314 ,@(nreverse required-checks
)
315 ,@(nreverse order-cleanups
)
318 (defun parse-method-group-specifier (method-group-specifier)
319 ;;(declare (values name tests description order required))
320 (let* ((name (pop method-group-specifier
))
326 (if (or (null method-group-specifier
)
327 (memq (car method-group-specifier
)
328 '(:description
:order
:required
)))
329 (return-from collect-tests t
)
330 (let ((pattern (pop method-group-specifier
)))
331 (push pattern patterns
)
332 (push (parse-qualifier-pattern name pattern
)
334 (nreverse collect
))))
337 (getf method-group-specifier
:description
338 (make-default-method-group-description patterns
))
339 (getf method-group-specifier
:order
:most-specific-first
)
340 (getf method-group-specifier
:required nil
))))
342 (defun parse-qualifier-pattern (name pattern
)
343 (cond ((eq pattern
'()) `(null .qualifiers.
))
345 ((symbolp pattern
) `(,pattern .qualifiers.
))
346 ((listp pattern
) `(qualifier-check-runtime ',pattern .qualifiers.
))
347 (t (error "In the method group specifier ~S,~%~
348 ~S isn't a valid qualifier pattern."
351 (defun qualifier-check-runtime (pattern qualifiers
)
352 (loop (cond ((and (null pattern
) (null qualifiers
))
354 ((eq pattern
'*) (return t
))
355 ((and pattern qualifiers
(eq (car pattern
) (car qualifiers
)))
360 (defun make-default-method-group-description (patterns)
363 "methods matching one of the patterns: ~{~S, ~} ~S"
364 (butlast patterns
) (car (last patterns
)))
366 "methods matching the pattern: ~S"
369 ;;; This baby is a complete mess. I can't believe we put it in this
370 ;;; way. No doubt this is a large part of what drives MLY crazy.
372 ;;; At runtime (when the effective-method is run), we bind an intercept
373 ;;; lambda-list to the arguments to the generic function.
375 ;;; At compute-effective-method time, the symbols in the :arguments
376 ;;; option are bound to the symbols in the intercept lambda list.
378 ;;; FIXME: in here we have not one but two mini-copies of a weird
379 ;;; hybrid of PARSE-LAMBDA-LIST and (obsolete) PARSE-DEFMACRO-LAMBDA-LIST.
380 (defun deal-with-args-option (wrapped-body args-lambda-list
)
381 (let ((intercept-rebindings
383 (dolist (arg args-lambda-list
(nreverse rebindings
))
384 (unless (member arg lambda-list-keywords
:test
#'eq
)
386 (symbol (push `(,arg
',arg
) rebindings
))
388 (unless (symbolp (car arg
))
389 (error "invalid lambda-list specifier: ~S." arg
))
390 (push `(,(car arg
) ',(car arg
)) rebindings
))
391 (t (error "invalid lambda-list-specifier: ~S." arg
)))))))
395 ;; Count the number of required and optional parameters in
396 ;; ARGS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the
397 ;; name of a &WHOLE parameter, if any.
398 (when (member '&whole
(rest args-lambda-list
))
399 (error 'simple-program-error
400 :format-control
"~@<The value of the :ARGUMENTS option of ~
401 DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~
402 only appear first in the lambda list.~:>"
403 :format-arguments
(list args-lambda-list
)))
404 (loop with state
= 'required
405 for arg in args-lambda-list do
406 (if (memq arg lambda-list-keywords
)
409 (required (incf nreq
))
410 (&optional
(incf nopt
))
411 (&whole
(setq whole arg state
'required
)))))
412 ;; This assumes that the head of WRAPPED-BODY is a let, and it
413 ;; injects let-bindings of the form (ARG 'SYM) for all variables
414 ;; of the argument-lambda-list; SYM is a gensym.
415 (aver (memq (first wrapped-body
) '(let let
*)))
416 (setf (second wrapped-body
)
417 (append intercept-rebindings
(second wrapped-body
)))
418 ;; Be sure to fill out the args lambda list so that it can be too
419 ;; short if it wants to.
420 (unless (or (memq '&rest args-lambda-list
)
421 (memq '&allow-other-keys args-lambda-list
))
422 (let ((aux (memq '&aux args-lambda-list
)))
423 (setq args-lambda-list
424 (append (ldiff args-lambda-list aux
)
425 (if (memq '&key args-lambda-list
)
429 ;; .GENERIC-FUNCTION. is bound to the generic function in the
430 ;; method combination function, and .GF-ARGS* is bound to the
431 ;; generic function arguments in effective method functions
432 ;; created for generic functions having a method combination that
435 ;; The DESTRUCTURING-BIND binds the parameters of the
436 ;; ARGS-LAMBDA-LIST to actual generic function arguments. Because
437 ;; ARGS-LAMBDA-LIST may be shorter or longer than the generic
438 ;; function's lambda list, which is only known at run time, this
439 ;; destructuring has to be done on a slighly modified list of
440 ;; actual arguments, from which values might be stripped or added.
442 ;; Using one of the variable names in the body inserts a symbol
443 ;; into the effective method, and running the effective method
444 ;; produces the value of actual argument that is bound to the
446 `(let ((inner-result.
,wrapped-body
)
447 (gf-lambda-list (generic-function-lambda-list .generic-function.
)))
448 `(destructuring-bind ,',args-lambda-list
449 (frob-combined-method-args
450 .gf-args.
',gf-lambda-list
452 ,,(when (memq '.ignore. args-lambda-list
)
453 ''(declare (ignore .ignore.
)))
454 ;; If there is a &WHOLE in the args-lambda-list, let
455 ;; it result in the actual arguments of the generic-function
456 ;; not the frobbed list.
458 ``(setq ,',whole .gf-args.
))
461 ;;; Partition VALUES into three sections: required, optional, and the
462 ;;; rest, according to required, optional, and other parameters in
463 ;;; LAMBDA-LIST. Make the required and optional sections NREQ and
464 ;;; NOPT elements long by discarding values or adding NILs. Value is
465 ;;; the concatenated list of required and optional sections, and what
466 ;;; is left as rest from VALUES.
467 (defun frob-combined-method-args (values lambda-list nreq nopt
)
468 (loop with section
= 'required
469 for arg in lambda-list
470 if
(memq arg lambda-list-keywords
) do
472 (unless (eq section
'&optional
)
474 else if
(eq section
'required
)
476 and collect
(pop values
) into required
477 else if
(eq section
'&optional
)
479 and collect
(pop values
) into optional
481 (flet ((frob (list n m
)
482 (cond ((> n m
) (butlast list
(- n m
)))
483 ((< n m
) (nconc list
(make-list (- m n
))))
485 (return (nconc (frob required nr nreq
)
486 (frob optional no nopt
)