X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=44f8fdbb5ebcc872a8a3d8361ce1eeb2c6dc3056;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=7652ec877e3ff5fcf0bdfd920fbbfe0be9f0cae9;hpb=69550d1ce4a94faec95a651f3f0c1e884966a496;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 7652ec8..44f8fdb 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -25,10 +25,13 @@ (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)))) ;;;; standard method combination @@ -99,6 +102,7 @@ (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) @@ -128,27 +132,20 @@ (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 @@ -192,6 +189,26 @@ (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)))) ;;;; long method combinations @@ -243,6 +260,7 @@ (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) @@ -281,59 +299,82 @@ .method-combination. .applicable-methods.)) (block .long-method-combination-function. ,wrapped-body)))))) -;; 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)))) + +;;; NOTE: +;;; +;;; The semantics of long form method combination in the presence of +;;; multiple methods with the same specializers in the same method +;;; group are unclear by the spec: a portion of the standard implies +;;; that an error should be signalled, and another is more lenient. +;;; +;;; It is reasonable to allow a single method group of * to bypass all +;;; rules, as this is explicitly stated in the standard. + +(defun group-cond-clause (name tests specializer-cache star-only) + (let ((maybe-error-clause + (if star-only + `(setq ,specializer-cache .specializers.) + `(if (and (equal ,specializer-cache .specializers.) + (not (null .specializers.))) + (return-from .long-method-combination-function. + '(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.))))) + `((or ,@tests) + ,maybe-error-clause + (push .method. ,name)))) (defun wrap-method-group-specifier-bindings - (method-group-specifiers declarations real-body) - (let (names - specializer-caches - cond-clauses - required-checks - order-cleanups) + (method-group-specifiers declarations real-body) + (let (names specializer-caches cond-clauses required-checks order-cleanups) + (let ((nspecifiers (length method-group-specifiers))) (dolist (method-group-specifier method-group-specifiers) - (multiple-value-bind (name tests description order required) - (parse-method-group-specifier method-group-specifier) - (declare (ignore description)) - (let ((specializer-cache (gensym))) - (push name names) - (push specializer-cache specializer-caches) - (push `((or ,@tests) - (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)) - (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))) - required-checks)) - (loop (unless (and (constantp order) - (neq order (setq order (eval order)))) - (return t))) - (push (cond ((eq order :most-specific-first) - `(setq ,name (nreverse ,name))) - ((eq order :most-specific-last) ()) - (t - `(ecase ,order - (:most-specific-first - (setq ,name (nreverse ,name))) - (:most-specific-last)))) - order-cleanups)))) - `(let (,@(nreverse names) ,@(nreverse specializer-caches)) - ,@declarations - (dolist (.method. .applicable-methods.) - (let ((.qualifiers. (method-qualifiers .method.)) - (.specializers. (method-specializers .method.))) - (declare (ignorable .qualifiers. .specializers.)) - (cond ,@(nreverse cond-clauses)))) - ,@(nreverse required-checks) - ,@(nreverse order-cleanups) - ,@real-body))) + (multiple-value-bind (name tests description order required) + (parse-method-group-specifier method-group-specifier) + (declare (ignore description)) + (let ((specializer-cache (gensym))) + (push name names) + (push specializer-cache specializer-caches) + (push (group-cond-clause name tests specializer-cache + (and (eq (cadr method-group-specifier) '*) + (= nspecifiers 1))) + cond-clauses) + (when required + (push `(when (null ,name) + (return-from .long-method-combination-function. + '(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)))) + (return t))) + (push (cond ((eq order :most-specific-first) + `(setq ,name (nreverse ,name))) + ((eq order :most-specific-last) ()) + (t + `(ecase ,order + (:most-specific-first + (setq ,name (nreverse ,name))) + (:most-specific-last)))) + order-cleanups)))) + `(let (,@(nreverse names) ,@(nreverse specializer-caches)) + ,@declarations + (dolist (.method. .applicable-methods.) + (let ((.qualifiers. (method-qualifiers .method.)) + (.specializers. (method-specializers .method.))) + (declare (ignorable .qualifiers. .specializers.)) + (cond ,@(nreverse cond-clauses)))) + ,@(nreverse required-checks) + ,@(nreverse order-cleanups) + ,@real-body)))) (defun parse-method-group-specifier (method-group-specifier) ;;(declare (values name tests description order required)) @@ -394,12 +435,21 @@ ;;; ;;; 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)) @@ -496,3 +546,4 @@ (return (nconc (frob required nr nreq) (frob optional no nopt) values))))) +