0.pre7.54:

[sbcl.git] / src / pcl / combin.lisp

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index 1c600ff..1221782 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -64,8 +64,10 @@
       (make-effective-method-function-internal generic-function form
                                               method-alist-p wrappers-p)))
 
-(defun make-effective-method-function-type (generic-function form
-                                           method-alist-p wrappers-p)
+(defun make-effective-method-fun-type (generic-function
+                                      form
+                                      method-alist-p
+                                      wrappers-p)
   (if (and (listp form)
           (eq (car form) 'call-method))
       (let* ((cm-args (cdr form))
@@ -86,7 +88,7 @@
                          'fast-method-call
                          'method-call))))
              (if (and (consp method) (eq (car method) 'make-method))
-                 (make-effective-method-function-type
+                 (make-effective-method-fun-type
                   generic-function (cadr method) method-alist-p wrappers-p)
                  (type-of method)))))
       'fast-method-call))
@@ -186,7 +188,7 @@
 
 (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
   (cond ((and (consp form) (eq (car form) 'call-method))
-        (case (make-effective-method-function-type
+        (case (make-effective-method-fun-type
                generic-function form method-alist-p wrappers-p)
           (fast-method-call
            '.fast-call-method.)
@@ -195,7 +197,7 @@
        ((and (consp form) (eq (car form) 'call-method-list))
         (case (if (every #'(lambda (form)
                              (eq 'fast-method-call
-                                 (make-effective-method-function-type
+                                 (make-effective-method-fun-type
                                   generic-function form
                                   method-alist-p wrappers-p)))
                          (cdr form))
@@ -213,14 +215,14 @@
   (cond ((and (consp form) (eq (car form) 'call-method))
         (let ((gensym (get-effective-method-gensym)))
           (values (make-emf-call metatypes applyp gensym
-                                 (make-effective-method-function-type
+                                 (make-effective-method-fun-type
                                   generic-function form method-alist-p wrappers-p))
                   (list gensym))))
        ((and (consp form) (eq (car form) 'call-method-list))
         (let ((gensym (get-effective-method-gensym))
               (type (if (every #'(lambda (form)
                                    (eq 'fast-method-call
-                                       (make-effective-method-function-type
+                                       (make-effective-method-fun-type
                                         generic-function form
                                         method-alist-p wrappers-p)))
                                (cdr form))
@@ -306,15 +308,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)
@@ -359,7 +376,7 @@
                                     applicable-methods))
 
 (defun invalid-method-error (method format-control &rest format-arguments)
-  (error "~@<invalid method error for ~2I_~S ~I~_method: ~2I~_~?~:>"
+  (error "~@<invalid method error for ~2I~_~S ~I~_method: ~2I~_~?~:>"
         method
         format-control
         format-arguments))