X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=6163057f1dfe62c92bc93a7e06bad7874c85eb93;hb=1b650be8b800cf96e2c268ae317fb26d0bf36827;hp=897b6449c734f9f1214b23e5637eeb1f88dfe5ab;hpb=b206788a30815e7cc363efebc0ead442c6b18dc3;p=sbcl.git diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 897b644..6163057 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -99,6 +99,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 +129,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,33 +155,57 @@ `(,operator ,@(mapcar (lambda (m) `(call-method ,m ())) primary))))) (cond ((null primary) - ;; FIXME(?): NO-APPLICABLE-METHOD seems more appropriate - ;; here, but - ;; (1) discussion with CSR on #lisp reminded me that it's - ;; a vexed question whether we can validly call - ;; N-A-M when an :AROUND method exists (and the - ;; definition of NO-NEXT-METHOD seems to discourage - ;; us from calling NO-NEXT-METHOD directly in that - ;; case, since it's supposed to be called from a - ;; CALL-NEXT-METHOD form), and - ;; (2) a call to N-A-M would require &REST FUN-ARGS, and - ;; we don't seem to have FUN-ARGS here. - ;; I think ideally failures in short method combination - ;; would end up either in NO-APPLICABLE-METHOD or - ;; NO-NEXT-METHOD, and I expect that's what ANSI - ;; generally intended, but it's not clear to me whether - ;; the details of what they actually specified let us - ;; make that happen. So for now I've just tried to - ;; clarify the error message text but left the general - ;; logic alone (and raised the question on sbcl-devel). - ;; -- WHN 2003-06-16 - `(error "no ~S methods for ~S on these arguments" - ',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 @@ -239,6 +257,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) @@ -492,3 +511,4 @@ (return (nconc (frob required nr nreq) (frob optional no nopt) values))))) +