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
)
100 (setf (random-documentation type-name
'method-combination
) doc
)
103 (defun short-combine-methods (type-name options operator ioa method doc
)
104 (cond ((null options
) (setq options
'(:most-specific-first
)))
105 ((equal options
'(:most-specific-first
)))
106 ((equal options
'(:most-specific-last
)))
108 (method-combination-error
109 "Illegal options to a short method combination type.~%~
110 The method combination type ~S accepts one option which~%~
111 must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
113 (make-instance 'short-method-combination
117 :identity-with-one-argument ioa
118 :definition-source method
121 (defmethod invalid-qualifiers ((gf generic-function
)
122 (combin short-method-combination
)
124 (let ((qualifiers (method-qualifiers method
))
125 (type-name (method-combination-type-name combin
)))
127 ((null qualifiers
) "has no qualifiers")
128 ((cdr qualifiers
) "has too many qualifiers")
129 (t (aver (and (neq (car qualifiers
) type-name
)
130 (neq (car qualifiers
) :around
)))
131 "has an invalid qualifier"))))
132 (invalid-method-error
134 "The method ~S on ~S ~A.~%~
135 The method combination type ~S was defined with the~%~
136 short form of DEFINE-METHOD-COMBINATION and so requires~%~
137 all methods have either the single qualifier ~S or the~%~
138 single qualifier :AROUND."
139 method gf why type-name type-name
))))
141 ;;;; long method combinations
143 (defun expand-long-defcombin (form)
144 (let ((type-name (cadr form
))
145 (lambda-list (caddr form
))
146 (method-group-specifiers (cadddr form
))
150 (when (and (consp (car body
)) (eq (caar body
) :arguments
))
151 (setq args-option
(cdr (pop body
))))
152 (when (and (consp (car body
)) (eq (caar body
) :generic-function
))
153 (setq gf-var
(cadr (pop body
))))
154 (multiple-value-bind (documentation function
)
155 (make-long-method-combination-function
156 type-name lambda-list method-group-specifiers args-option gf-var
158 `(load-long-defcombin ',type-name
',documentation
#',function
159 ',args-option
(sb-c:source-location
)))))
161 (defvar *long-method-combination-functions
* (make-hash-table :test
'eq
))
163 (defun load-long-defcombin
164 (type-name doc function args-lambda-list source-location
)
166 (list (find-class 'generic-function
)
167 (intern-eql-specializer type-name
)
170 (get-method #'find-method-combination
() specializers nil
))
172 (make-instance 'standard-method
174 :specializers specializers
175 :lambda-list
'(generic-function type-name options
)
176 :function
(lambda (args nms
&rest cm-args
)
177 (declare (ignore nms cm-args
))
179 (lambda (generic-function type-name options
)
180 (declare (ignore generic-function
))
181 (make-instance 'long-method-combination
184 :args-lambda-list args-lambda-list
187 :definition-source source-location
)))
188 (setf (gethash type-name
*long-method-combination-functions
*) function
)
189 (when old-method
(remove-method #'find-method-combination old-method
))
190 (add-method #'find-method-combination new-method
)
191 (setf (random-documentation type-name
'method-combination
) doc
)
194 (defmethod compute-effective-method ((generic-function generic-function
)
195 (combin long-method-combination
)
197 (funcall (gethash (method-combination-type-name combin
)
198 *long-method-combination-functions
*)
203 (defun make-long-method-combination-function
204 (type-name ll method-group-specifiers args-option gf-var body
)
205 (declare (ignore type-name
))
206 (multiple-value-bind (real-body declarations documentation
)
209 (wrap-method-group-specifier-bindings method-group-specifiers
213 (push `(,gf-var .generic-function.
) (cadr wrapped-body
)))
216 (setq wrapped-body
(deal-with-args-option wrapped-body args-option
)))
220 `(apply #'(lambda ,ll
,wrapped-body
)
221 (method-combination-options .method-combination.
))))
225 `(lambda (.generic-function. .method-combination. .applicable-methods.
)
226 (declare (ignorable .generic-function.
227 .method-combination. .applicable-methods.
))
228 (block .long-method-combination-function.
,wrapped-body
))))))
230 (define-condition long-method-combination-error
231 (reference-condition simple-error
)
234 :references
(list '(:ansi-cl
:macro define-method-combination
))))
238 ;;; The semantics of long form method combination in the presence of
239 ;;; multiple methods with the same specializers in the same method
240 ;;; group are unclear by the spec: a portion of the standard implies
241 ;;; that an error should be signalled, and another is more lenient.
243 ;;; It is reasonable to allow a single method group of * to bypass all
244 ;;; rules, as this is explicitly stated in the standard.
246 (defun group-cond-clause (name tests specializer-cache star-only
)
247 (let ((maybe-error-clause
249 `(setq ,specializer-cache .specializers.
)
250 `(if (and (equal ,specializer-cache .specializers.
)
251 (not (null .specializers.
)))
252 (return-from .long-method-combination-function.
253 '(error 'long-method-combination-error
254 :format-control
"More than one method of type ~S ~
255 with the same specializers."
256 :format-arguments
(list ',name
)))
257 (setq ,specializer-cache .specializers.
)))))
260 (push .method.
,name
))))
262 (defun wrap-method-group-specifier-bindings
263 (method-group-specifiers declarations real-body
)
264 (let (names specializer-caches cond-clauses required-checks order-cleanups
)
265 (let ((nspecifiers (length method-group-specifiers
)))
266 (dolist (method-group-specifier method-group-specifiers
267 (push `(t (return-from .long-method-combination-function.
268 `(invalid-method-error , .method.
269 "~@<is applicable, but does not belong ~
270 to any method group~@:>")))
272 (multiple-value-bind (name tests description order required
)
273 (parse-method-group-specifier method-group-specifier
)
274 (declare (ignore description
))
275 (let ((specializer-cache (gensym)))
277 (push specializer-cache specializer-caches
)
278 (push (group-cond-clause name tests specializer-cache
279 (and (eq (cadr method-group-specifier
) '*)
283 (push `(when (null ,name
)
284 (return-from .long-method-combination-function.
285 '(error 'long-method-combination-error
286 :format-control
"No ~S methods."
287 :format-arguments
(list ',name
))))
289 (loop (unless (and (constantp order
)
290 (neq order
(setq order
291 (constant-form-value order
))))
293 (push (cond ((eq order
:most-specific-first
)
294 `(setq ,name
(nreverse ,name
)))
295 ((eq order
:most-specific-last
) ())
298 (:most-specific-first
299 (setq ,name
(nreverse ,name
)))
300 (:most-specific-last
))))
302 `(let (,@(nreverse names
) ,@(nreverse specializer-caches
))
304 (dolist (.method. .applicable-methods.
)
305 (let ((.qualifiers.
(method-qualifiers .method.
))
306 (.specializers.
(method-specializers .method.
)))
307 (declare (ignorable .qualifiers. .specializers.
))
308 (cond ,@(nreverse cond-clauses
))))
309 ,@(nreverse required-checks
)
310 ,@(nreverse order-cleanups
)
313 (defun parse-method-group-specifier (method-group-specifier)
314 ;;(declare (values name tests description order required))
315 (let* ((name (pop method-group-specifier
))
321 (if (or (null method-group-specifier
)
322 (memq (car method-group-specifier
)
323 '(:description
:order
:required
)))
324 (return-from collect-tests t
)
325 (let ((pattern (pop method-group-specifier
)))
326 (push pattern patterns
)
327 (push (parse-qualifier-pattern name pattern
)
329 (nreverse collect
))))
332 (getf method-group-specifier
:description
333 (make-default-method-group-description patterns
))
334 (getf method-group-specifier
:order
:most-specific-first
)
335 (getf method-group-specifier
:required nil
))))
337 (defun parse-qualifier-pattern (name pattern
)
338 (cond ((eq pattern
'()) `(null .qualifiers.
))
340 ((symbolp pattern
) `(,pattern .qualifiers.
))
341 ((listp pattern
) `(qualifier-check-runtime ',pattern .qualifiers.
))
342 (t (error "In the method group specifier ~S,~%~
343 ~S isn't a valid qualifier pattern."
346 (defun qualifier-check-runtime (pattern qualifiers
)
347 (loop (cond ((and (null pattern
) (null qualifiers
))
349 ((eq pattern
'*) (return t
))
350 ((and pattern qualifiers
(eq (car pattern
) (car qualifiers
)))
355 (defun make-default-method-group-description (patterns)
358 "methods matching one of the patterns: ~{~S, ~} ~S"
359 (butlast patterns
) (car (last patterns
)))
361 "methods matching the pattern: ~S"
364 ;;; This baby is a complete mess. I can't believe we put it in this
365 ;;; way. No doubt this is a large part of what drives MLY crazy.
367 ;;; At runtime (when the effective-method is run), we bind an intercept
368 ;;; lambda-list to the arguments to the generic function.
370 ;;; At compute-effective-method time, the symbols in the :arguments
371 ;;; option are bound to the symbols in the intercept lambda list.
373 ;;; FIXME: in here we have not one but two mini-copies of a weird
374 ;;; hybrid of PARSE-LAMBDA-LIST and (obsolete) PARSE-DEFMACRO-LAMBDA-LIST.
375 (defun deal-with-args-option (wrapped-body args-lambda-list
)
376 (let ((intercept-rebindings
378 (dolist (arg args-lambda-list
(nreverse rebindings
))
379 (unless (member arg lambda-list-keywords
:test
#'eq
)
381 (symbol (push `(,arg
',arg
) rebindings
))
383 (unless (symbolp (car arg
))
384 (error "invalid lambda-list specifier: ~S." arg
))
385 (push `(,(car arg
) ',(car arg
)) rebindings
))
386 (t (error "invalid lambda-list-specifier: ~S." arg
)))))))
390 ;; Count the number of required and optional parameters in
391 ;; ARGS-LAMBDA-LIST into NREQ and NOPT, and set WHOLE to the
392 ;; name of a &WHOLE parameter, if any.
393 (when (member '&whole
(rest args-lambda-list
))
394 (error 'simple-program-error
395 :format-control
"~@<The value of the :ARGUMENTS option of ~
396 DEFINE-METHOD-COMBINATION is~2I~_~S,~I~_but &WHOLE may ~
397 only appear first in the lambda list.~:>"
398 :format-arguments
(list args-lambda-list
)))
399 (loop with state
= 'required
400 for arg in args-lambda-list do
401 (if (memq arg lambda-list-keywords
)
404 (required (incf nreq
))
405 (&optional
(incf nopt
))
406 (&whole
(setq whole arg state
'required
)))))
407 ;; This assumes that the head of WRAPPED-BODY is a let, and it
408 ;; injects let-bindings of the form (ARG 'SYM) for all variables
409 ;; of the argument-lambda-list; SYM is a gensym.
410 (aver (memq (first wrapped-body
) '(let let
*)))
411 (setf (second wrapped-body
)
412 (append intercept-rebindings
(second wrapped-body
)))
413 ;; Be sure to fill out the args lambda list so that it can be too
414 ;; short if it wants to.
415 (unless (or (memq '&rest args-lambda-list
)
416 (memq '&allow-other-keys args-lambda-list
))
417 (let ((aux (memq '&aux args-lambda-list
)))
418 (setq args-lambda-list
419 (append (ldiff args-lambda-list aux
)
420 (if (memq '&key args-lambda-list
)
424 ;; .GENERIC-FUNCTION. is bound to the generic function in the
425 ;; method combination function, and .GF-ARGS* is bound to the
426 ;; generic function arguments in effective method functions
427 ;; created for generic functions having a method combination that
430 ;; The DESTRUCTURING-BIND binds the parameters of the
431 ;; ARGS-LAMBDA-LIST to actual generic function arguments. Because
432 ;; ARGS-LAMBDA-LIST may be shorter or longer than the generic
433 ;; function's lambda list, which is only known at run time, this
434 ;; destructuring has to be done on a slighly modified list of
435 ;; actual arguments, from which values might be stripped or added.
437 ;; Using one of the variable names in the body inserts a symbol
438 ;; into the effective method, and running the effective method
439 ;; produces the value of actual argument that is bound to the
441 `(let ((inner-result.
,wrapped-body
)
442 (gf-lambda-list (generic-function-lambda-list .generic-function.
)))
443 `(destructuring-bind ,',args-lambda-list
444 (frob-combined-method-args
445 .gf-args.
',gf-lambda-list
447 ,,(when (memq '.ignore. args-lambda-list
)
448 ''(declare (ignore .ignore.
)))
449 ;; If there is a &WHOLE in the args-lambda-list, let
450 ;; it result in the actual arguments of the generic-function
451 ;; not the frobbed list.
453 ``(setq ,',whole .gf-args.
))
456 ;;; Partition VALUES into three sections: required, optional, and the
457 ;;; rest, according to required, optional, and other parameters in
458 ;;; LAMBDA-LIST. Make the required and optional sections NREQ and
459 ;;; NOPT elements long by discarding values or adding NILs. Value is
460 ;;; the concatenated list of required and optional sections, and what
461 ;;; is left as rest from VALUES.
462 (defun frob-combined-method-args (values lambda-list nreq nopt
)
463 (loop with section
= 'required
464 for arg in lambda-list
465 if
(memq arg lambda-list-keywords
) do
467 (unless (eq section
'&optional
)
469 else if
(eq section
'required
)
471 and collect
(pop values
) into required
472 else if
(eq section
'&optional
)
474 and collect
(pop values
) into optional
476 (flet ((frob (list n m
)
477 (cond ((> n m
) (butlast list
(- n m
)))
478 ((< n m
) (nconc list
(make-list (- m n
))))
480 (return (nconc (frob required nr nreq
)
481 (frob optional no nopt
)