X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=060f4a0cd0b907bd5839f41752bec352bd09c7c4;hb=b86f43bae31f775d834c724e21f0f573b968f695;hp=e312ba908eba58b6f756a752ba9daa03ecbe48a8;hpb=ea652c139bb060d821f3010b3b106bdbcec983aa;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index e312ba9..060f4a0 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) @@ -233,9 +276,7 @@ (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 @@ -260,6 +301,12 @@ ;; 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 @@ -278,16 +325,19 @@ (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)))) @@ -371,12 +421,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)) @@ -473,3 +532,4 @@ (return (nconc (frob required nr nreq) (frob optional no nopt) values))))) +