X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=44f8fdbb5ebcc872a8a3d8361ce1eeb2c6dc3056;hb=69ef68ba7393e3492c1b4a756d1140f71c2922bc;hp=ff9265720fa332b0711a02f27a390d45456b6024;hpb=2bcdd03aba3bc43e34732e8c6b0b1bfbead6dae1;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index ff92657..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 @@ -161,12 +158,57 @@ `(,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)))) ;;;; long method combinations @@ -218,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) @@ -256,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)) @@ -369,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)) @@ -471,3 +546,4 @@ (return (nconc (frob required nr nreq) (frob optional no nopt) values))))) +