[armedbear-cvs] r13569 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Sun Sep  4 06:34:50 2011
New Revision: 13569

Log:
Signal an error if unambiguous sorting of methods within a method group
is not possible due to the use of the same specializers.

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp
   trunk/abcl/test/lisp/abcl/mop-tests.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Sep  4 02:59:23 2011	(r13568)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Sun Sep  4 06:34:50 2011	(r13569)
@@ -936,7 +936,8 @@
                           thereis (method-group-p item qualifiers)))
            :description ',description
            :order ',order
-           :required ',required-p)))
+           :required ',required-p
+           :*-selecter ,(equal selecters '(*)))))
 
 (defun extract-required-part (lambda-list)
   (flet ((skip (key lambda-list)
@@ -1027,27 +1028,38 @@
                   collect `(,var ,init-form)))
          , at forms))))
 
+(defun assert-unambiguous-method-sorting (group-name methods)
+  (let ((specializers (make-hash-table :test 'equal)))
+    (dolist (method methods)
+      (push method (gethash (method-specializers method) specializers)))
+    (loop for specializer-methods being each hash-value of specializers
+       using (hash-key method-specializers)
+       unless (= 1 (length specializer-methods))
+       do (error "Ambiguous method sorting in method group ~A due to multiple ~
+                  methods with specializers ~S: ~S"
+                 group-name method-specializers specializer-methods))))
+
 (defmacro with-method-groups (method-group-specs methods-form &body forms)
   (flet ((grouping-form (spec methods-var)
-                        (let ((predicate (coerce-to-function (getf spec :predicate)))
-                              (group (gensym))
-                              (leftovers (gensym))
-                              (method (gensym)))
-                          `(let ((,group '())
-                                 (,leftovers '()))
-                             (dolist (,method ,methods-var)
-                               (if (funcall ,predicate (method-qualifiers ,method))
-                                   (push ,method ,group)
-                                   (push ,method ,leftovers)))
-                             (ecase ,(getf spec :order)
-                               (:most-specific-last )
-                               (:most-specific-first (setq ,group (nreverse ,group))))
-                             ,@(when (getf spec :required)
-                                 `((when (null ,group)
-                                     (error "Method group ~S must not be empty."
-                                            ',(getf spec :name)))))
-                             (setq ,methods-var (nreverse ,leftovers))
-                             ,group))))
+           (let ((predicate (coerce-to-function (getf spec :predicate)))
+                 (group (gensym))
+                 (leftovers (gensym))
+                 (method (gensym)))
+             `(let ((,group '())
+                    (,leftovers '()))
+                (dolist (,method ,methods-var)
+                  (if (funcall ,predicate (method-qualifiers ,method))
+                      (push ,method ,group)
+                      (push ,method ,leftovers)))
+                (ecase ,(getf spec :order)
+                  (:most-specific-last )
+                  (:most-specific-first (setq ,group (nreverse ,group))))
+                ,@(when (getf spec :required)
+                        `((when (null ,group)
+                            (error "Method group ~S must not be empty."
+                                   ',(getf spec :name)))))
+                (setq ,methods-var (nreverse ,leftovers))
+                ,group))))
     (let ((rest (gensym))
           (method (gensym)))
       `(let* ((,rest ,methods-form)
@@ -1058,6 +1070,11 @@
            (invalid-method-error ,method
                                  "Method ~S with qualifiers ~S does not belong to any method group."
                                  ,method (method-qualifiers ,method)))
+         ,@(unless (and (= 1 (length method-group-specs))
+                        (getf (car method-group-specs) :*-selecter))
+             (mapcar #'(lambda (spec)
+                         `(assert-unambiguous-method-sorting ',(getf spec :name) ,(getf spec :name)))
+                     method-group-specs))
          , at forms))))
 
 (defun method-combination-type-lambda

Modified: trunk/abcl/test/lisp/abcl/mop-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/mop-tests.lisp	Sun Sep  4 02:59:23 2011	(r13568)
+++ trunk/abcl/test/lisp/abcl/mop-tests.lisp	Sun Sep  4 06:34:50 2011	(r13569)
@@ -410,7 +410,38 @@
   T)
 
 
+;;; Taken from SBCL: error when method sorting is ambiguous
 
+(define-method-combination dmc-test-mc.3a ()
+  ((around (:around))
+   (primary * :required t))
+  (let ((form (if (rest primary)
+                  `(call-method ,(first primary) ,(rest primary))
+                  `(call-method ,(first primary)))))
+    (if around
+        `(call-method ,(first around) (,@(rest around)
+                                       (make-method ,form)))
+        form)))
+
+(defgeneric dmc-test-mc.3a (val)
+  (:method-combination dmc-test-mc.3a))
+
+(defmethod dmc-test-mc.3a ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+
+(defmethod dmc-test-mc.3a :around ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+
+(defmethod dmc-test-mc.3a :somethingelse ((val number))
+  (+ val (if (next-method-p) (call-next-method) 0)))
+
+(deftest dmc-test-mc.3a
+    (multiple-value-bind
+          (value error)
+        (ignore-errors (wam-test-mc-b 13))
+      (declare (ignore value))
+      (typep error 'error))
+  T)
 
 (defclass foo-class (standard-class))
 (defmethod mop:validate-superclass ((class foo-class) (superclass standard-object))