X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdefcombin.lisp;h=6163057f1dfe62c92bc93a7e06bad7874c85eb93;hb=dcf5978d9d33098e868ae6eea28e1b310038c03d;hp=7652ec877e3ff5fcf0bdfd920fbbfe0be9f0cae9;hpb=69550d1ce4a94faec95a651f3f0c1e884966a496;p=sbcl.git

diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index 7652ec8..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
@@ -192,6 +186,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 +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)
@@ -496,3 +511,4 @@
 	    (return (nconc (frob required nr nreq)
 			   (frob optional no nopt)
 			   values)))))
+