\f
(defmacro define-method-combination (&whole form &rest args)
(declare (ignore args))
- (if (and (cddr form)
- (listp (caddr form)))
- (expand-long-defcombin form)
- (expand-short-defcombin form)))
+ `(progn
+ (with-single-package-locked-error
+ (:symbol ',(second form) "defining ~A as a method combination"))
+ ,(if (and (cddr form)
+ (listp (caddr form)))
+ (expand-long-defcombin form)
+ (expand-short-defcombin form))))
\f
;;;; standard method combination
(when old-method
(remove-method #'find-method-combination old-method))
(add-method #'find-method-combination new-method)
+ (setf (random-documentation type 'method-combination) doc)
type))
(defun short-combine-methods (type options operator ioa method doc)
(order (car (method-combination-options combin)))
(around ())
(primary ()))
- (dolist (m applicable-methods)
- (let ((qualifiers (method-qualifiers m)))
- (flet ((lose (method why)
- (invalid-method-error
- method
- "The method ~S ~A.~%~
- The method combination type ~S was defined with the~%~
- short form of DEFINE-METHOD-COMBINATION and so requires~%~
- all methods have either the single qualifier ~S or the~%~
- single qualifier :AROUND."
- method why type type)))
- (cond ((null qualifiers)
- (lose m "has no qualifiers"))
- ((cdr qualifiers)
- (lose m "has more than one qualifier"))
+ (flet ((invalid (gf combin m)
+ (if *in-precompute-effective-methods-p*
+ (return-from compute-effective-method
+ `(%invalid-qualifiers ',gf ',combin ',m))
+ (invalid-qualifiers gf combin m))))
+ (dolist (m applicable-methods)
+ (let ((qualifiers (method-qualifiers m)))
+ (cond ((null qualifiers) (invalid generic-function combin m))
+ ((cdr qualifiers) (invalid generic-function combin m))
((eq (car qualifiers) :around)
(push m around))
((eq (car qualifiers) type)
(push m primary))
- (t
- (lose m "has an illegal qualifier"))))))
+ (t (invalid generic-function combin m))))))
(setq around (nreverse around))
(ecase order
(:most-specific-last) ; nothing to be done, already in correct order
`(,operator ,@(mapcar (lambda (m) `(call-method ,m ()))
primary)))))
(cond ((null primary)
- `(error "No ~S methods for the generic function ~S."
- ',type ',generic-function))
+ ;; As of sbcl-0.8.0.80 we don't seem to need to need
+ ;; to do anything messy like
+ ;; `(APPLY (FUNCTION (IF AROUND
+ ;; 'NO-PRIMARY-METHOD
+ ;; 'NO-APPLICABLE-METHOD)
+ ;; ',GENERIC-FUNCTION
+ ;; .ARGS.)
+ ;; here because (for reasons I don't understand at the
+ ;; moment -- WHN) control will never reach here if there
+ ;; are no applicable methods, but instead end up
+ ;; in NO-APPLICABLE-METHODS first.
+ ;;
+ ;; FIXME: The way that we arrange for .ARGS. to be bound
+ ;; here seems weird. We rely on EXPAND-EFFECTIVE-METHOD-FUNCTION
+ ;; recognizing any form whose operator is %NO-PRIMARY-METHOD
+ ;; as magical, and carefully surrounding it with a
+ ;; LAMBDA form which binds .ARGS. But...
+ ;; 1. That seems fragile, because the magicalness of
+ ;; %NO-PRIMARY-METHOD forms is scattered around
+ ;; the system. So it could easily be broken by
+ ;; locally-plausible maintenance changes like,
+ ;; e.g., using the APPLY expression above.
+ ;; 2. That seems buggy w.r.t. to MOPpish tricks in
+ ;; user code, e.g.
+ ;; (DEFMETHOD COMPUTE-EFFECTIVE-METHOD :AROUND (...)
+ ;; `(PROGN ,(CALL-NEXT-METHOD) (INCF *MY-CTR*)))
+ `(%no-primary-method ',generic-function .args.))
((null around) main-method)
(t
`(call-method ,(car around)
(,@(cdr around) (make-method ,main-method))))))))
+
+(defmethod invalid-qualifiers ((gf generic-function)
+ (combin short-method-combination)
+ method)
+ (let ((qualifiers (method-qualifiers method))
+ (type (method-combination-type combin)))
+ (let ((why (cond
+ ((null qualifiers) "has no qualifiers")
+ ((cdr qualifiers) "has too many qualifiers")
+ (t (aver (and (neq (car qualifiers) type)
+ (neq (car qualifiers) :around)))
+ "has an invalid qualifier"))))
+ (invalid-method-error
+ method
+ "The method ~S on ~S ~A.~%~
+ The method combination type ~S was defined with the~%~
+ short form of DEFINE-METHOD-COMBINATION and so requires~%~
+ all methods have either the single qualifier ~S or the~%~
+ single qualifier :AROUND."
+ method gf why type type))))
\f
;;;; long method combinations
(setf (gethash type *long-method-combination-functions*) function)
(when old-method (remove-method #'find-method-combination old-method))
(add-method #'find-method-combination new-method)
+ (setf (random-documentation type 'method-combination) doc)
type))
(defmethod compute-effective-method ((generic-function generic-function)
(type ll method-group-specifiers args-option gf-var body)
(declare (ignore type))
(multiple-value-bind (real-body declarations documentation)
- ;; (Note that PARSE-BODY ignores its second arg ENVIRONMENT.)
- (parse-body body nil)
-
+ (parse-body body)
(let ((wrapped-body
(wrap-method-group-specifier-bindings method-group-specifiers
declarations
;; parse-method-group-specifiers parse the method-group-specifiers
+(define-condition long-method-combination-error
+ (reference-condition simple-error)
+ ()
+ (:default-initargs
+ :references (list '(:ansi-cl :macro define-method-combination))))
+
(defun wrap-method-group-specifier-bindings
(method-group-specifiers declarations real-body)
(let (names
(if (and (equal ,specializer-cache .specializers.)
(not (null .specializers.)))
(return-from .long-method-combination-function.
- '(error "More than one method of type ~S ~
- with the same specializers."
- ',name))
+ '(error 'long-method-combination-error
+ :format-control "More than one method of type ~S ~
+ with the same specializers."
+ :format-arguments (list ',name)))
(setq ,specializer-cache .specializers.))
(push .method. ,name))
cond-clauses)
(when required
(push `(when (null ,name)
(return-from .long-method-combination-function.
- '(error "No ~S methods." ',name)))
+ '(error 'long-method-combination-error
+ :format-control "No ~S methods."
+ :format-arguments (list ',name))))
required-checks))
(loop (unless (and (constantp order)
(neq order (setq order (eval order))))
;;;
;;; At compute-effective-method time, the symbols in the :arguments
;;; option are bound to the symbols in the intercept lambda list.
+;;;
+;;; FIXME: in here we have not one but two mini-copies of a weird
+;;; hybrid of PARSE-LAMBDA-LIST and PARSE-DEFMACRO-LAMBDA-LIST.
(defun deal-with-args-option (wrapped-body args-lambda-list)
(let ((intercept-rebindings
(let (rebindings)
(dolist (arg args-lambda-list (nreverse rebindings))
(unless (member arg lambda-list-keywords)
- (push `(,arg ',arg) rebindings)))))
+ (typecase arg
+ (symbol (push `(,arg ',arg) rebindings))
+ (cons
+ (unless (symbolp (car arg))
+ (error "invalid lambda-list specifier: ~S." arg))
+ (push `(,(car arg) ',(car arg)) rebindings))
+ (t (error "invalid lambda-list-specifier: ~S." arg)))))))
(nreq 0)
(nopt 0)
(whole nil))
(return (nconc (frob required nr nreq)
(frob optional no nopt)
values)))))
+
projects / sbcl.git / blobdiff