X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcombin.lisp;h=a28a1e4bfb41d654e1a3b2a6ed60c9137603d182;hb=416152f084604094445a758ff399871132dff2bd;hp=925be9798c5a62edb80ee9e0eeaae45a3d0929e4;hpb=d5aafdd8ab6387e12bac187048ed322bc96fb79a;p=sbcl.git

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 925be97..a28a1e4 100644
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -306,15 +306,30 @@
 	(primary ())
 	(after ())
 	(around ()))
-    (dolist (m applicable-methods)
-      (let ((qualifiers (if (listp m)
-			    (early-method-qualifiers m)
-			    (method-qualifiers m))))
-	(cond ((member ':before qualifiers)  (push m before))
-	      ((member ':after  qualifiers)  (push m after))
-	      ((member ':around  qualifiers) (push m around))
-	      (t
-	       (push m primary)))))
+    (flet ((lose (method why)
+             (invalid-method-error
+              method
+              "The method ~S ~A.~%~
+               Standard method combination requires all methods to have one~%~
+               of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
+               have no qualifier at all."
+              method why)))
+      (dolist (m applicable-methods)
+        (let ((qualifiers (if (listp m)
+                            (early-method-qualifiers m)
+                            (method-qualifiers m))))
+          (cond
+            ((null qualifiers) (push m primary))
+            ((cdr qualifiers)
+              (lose m "has more than one qualifier"))
+            ((eq (car qualifiers) :around)
+              (push m around))
+            ((eq (car qualifiers) :before)
+              (push m before))
+            ((eq (car qualifiers) :after)
+              (push m after))
+            (t
+              (lose m "has an illegal qualifier"))))))
     (setq before  (reverse before)
 	  after   (reverse after)
 	  primary (reverse primary)
@@ -341,10 +356,11 @@
 				  (make-method ,main-effective-method)))
 		 main-effective-method))))))
 
-;;;; the STANDARD method combination type. This is coded by hand (rather than
-;;;; with define-method-combination) for bootstrapping and efficiency reasons.
-;;;; Note that the definition of the find-method-combination-method appears in
-;;;; the file defcombin.lisp. This is because EQL methods can't appear in the
+;;;; the STANDARD method combination type. This is coded by hand
+;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
+;;;; and efficiency reasons. Note that the definition of the
+;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
+;;;; defcombin.lisp. This is because EQL methods can't appear in the
 ;;;; bootstrap.
 ;;;;
 ;;;; The DEFCLASS for the METHOD-COMBINATION and
@@ -357,52 +373,13 @@
 				     combin
 				     applicable-methods))
 
-;;; FIXME: As of sbcl-0.6.10, the bindings of *INVALID-METHOD-ERROR*
-;;; and *METHOD-COMBINATION-ERROR* are never changed, even within the
-;;; dynamic scope of method combination functions.
-(defvar *invalid-method-error*
-	#'(lambda (&rest args)
-	    (declare (ignore args))
-	    (error
-	      "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
-	       of a method combination function (inside the body of~%~
-	       DEFINE-METHOD-COMBINATION or a method on the generic~%~
-	       function COMPUTE-EFFECTIVE-METHOD).")))
-(defvar *method-combination-error*
-	#'(lambda (&rest args)
-	    (declare (ignore args))
-	    (error
-	      "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
-	       of a method combination function (inside the body of~%~
-	       DEFINE-METHOD-COMBINATION or a method on the generic~%~
-	       function COMPUTE-EFFECTIVE-METHOD).")))
+(defun invalid-method-error (method format-control &rest format-arguments)
+  (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
+	 method
+	 format-control
+	 format-arguments))
 
-;(defmethod compute-effective-method :around	;issue with magic
-;	   ((generic-function generic-function)     ;generic functions
-;	    (method-combination method-combination)
-;	    applicable-methods)
-;  (declare (ignore applicable-methods))
-;  (flet ((real-invalid-method-error (method format-string &rest args)
-;	   (declare (ignore method))
-;	   (apply #'error format-string args))
-;	 (real-method-combination-error (format-string &rest args)
-;	   (apply #'error format-string args)))
-;    (let ((*invalid-method-error* #'real-invalid-method-error)
-;	  (*method-combination-error* #'real-method-combination-error))
-;      (call-next-method))))
-
-(defun invalid-method-error (&rest args)
-  (apply *invalid-method-error* args))
-
-(defun method-combination-error (&rest args)
-  (apply *method-combination-error* args))
-
-;This definition now appears in defcombin.lisp.
-;
-;(defmethod find-method-combination ((generic-function generic-function)
-;				     (type (eql 'standard))
-;				     options)
-;  (when options
-;    (method-combination-error
-;      "The method combination type STANDARD accepts no options."))
-;  *standard-method-combination*)
+(defun method-combination-error (format-control &rest format-arguments)
+  (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
+	 format-control
+	 format-arguments))