From 6b86886f7330c42eee09a7dac47f3c85784d75cf Mon Sep 17 00:00:00 2001
From: Ed Langley <elangley@cj.com>
Date: Wed, 24 Oct 2018 01:46:02 -0700
Subject: [PATCH] Allow effective method to sort methods differing in
 qualifiers only.

If two methods of a generic function using a custom method combination
(and not using * as the qualifier pattern) had all the same
specializers, but differing qualifiers, sbcl was throwing an
error. Fix this to allow the effective method to control what happens
in this situation and change the error message if there are two
methods that agree in both qualifiers and specializers.
---
 src/pcl/defcombin.lisp | 25 ++++++++++++++++---------
 tests/clos.impure.lisp | 28 ++++++++++++++++++++++++++++
 2 files changed, 44 insertions(+), 9 deletions(-)

diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp
index e44e3fa4e..11f830845 100644
--- a/src/pcl/defcombin.lisp
+++ b/src/pcl/defcombin.lisp
@@ -257,25 +257,30 @@
 ;;; It is reasonable to allow a single method group of * to bypass all
 ;;; rules, as this is explicitly stated in the standard.
 
-(defun group-cond-clause (name tests specializer-cache star-only)
+(defun group-cond-clause (name tests specializer-cache qualifier-cache star-only)
   (let ((maybe-error-clause
          (if star-only
-             `(setq ,specializer-cache .specializers.)
-             `(if (and (equal ,specializer-cache .specializers.)
+             `(setq ,specializer-cache .specializers.
+                    ,qualifier-cache .qualifiers.)
+             `(if (and (equal ,qualifier-cache .qualifiers.)
+                       (not (null .qualifiers.))
+                       (equal ,specializer-cache .specializers.)
                        (not (null .specializers.)))
                   (return-from .long-method-combination-function.
                     '(error 'long-method-combination-error
                       :format-control "More than one method of type ~S ~
-                                       with the same specializers."
+                                       with the same specializers and ~
+                                       qualifiers."
                       :format-arguments (list ',name)))
-                  (setq ,specializer-cache .specializers.)))))
+                  (setq ,specializer-cache .specializers.
+                        ,qualifier-cache .qualifiers.)))))
     `((or ,@tests)
       ,maybe-error-clause
       (push .method. ,name))))
 
 (defun wrap-method-group-specifier-bindings
     (method-group-specifiers declarations real-body)
-  (let (names specializer-caches cond-clauses required-checks order-cleanups)
+  (let (names specializer-caches qualifier-caches cond-clauses required-checks order-cleanups)
     (let ((nspecifiers (length method-group-specifiers)))
       (dolist (method-group-specifier method-group-specifiers
                (push `(t (return-from .long-method-combination-function.
@@ -286,10 +291,12 @@
         (multiple-value-bind (name tests description order required)
             (parse-method-group-specifier method-group-specifier)
           (declare (ignore description))
-          (let ((specializer-cache (gensym)))
+          (let ((specializer-cache (gensym))
+                (qualifier-cache (gensym)))
             (push name names)
             (push specializer-cache specializer-caches)
-            (push (group-cond-clause name tests specializer-cache
+            (push qualifier-cache qualifier-caches)
+            (push (group-cond-clause name tests specializer-cache qualifier-cache
                                      (and (eq (cadr method-group-specifier) '*)
                                           (= nspecifiers 1)))
                   cond-clauses)
@@ -313,7 +320,7 @@
                             (setq ,name (nreverse ,name)))
                            (:most-specific-last))))
                   order-cleanups))))
-      `(let (,@(nreverse names) ,@(nreverse specializer-caches))
+      `(let (,@(nreverse names) ,@(nreverse specializer-caches) ,@(nreverse qualifier-caches))
         ,@declarations
         (dolist (.method. .applicable-methods.)
           (let ((.qualifiers. (method-qualifiers .method.))
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 391816b42..99e0012cd 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -2664,3 +2664,31 @@
           `(lambda ()
              (defmethod foo ((bar keyword))))
         (() (condition 'sb-pcl:class-not-found-error))))))
+
+;;;; Methods that match in specializers but differ in qualifiers
+;;;; should work.  The definition of the method-combination is from
+;;;; the CLHS specification of define-method-combination, the methods
+;;;; are not.
+(defun positive-integer-qualifier-p (method-qualifiers)
+  (and (= (length method-qualifiers) 1)
+       (typep (first method-qualifiers) '(integer 0 *))))
+
+(define-method-combination example-method-combination ()
+  ((methods positive-integer-qualifier-p))
+  `(progn ,@(mapcar #'(lambda (method)
+                        `(call-method ,method))
+                    (stable-sort methods #'<
+                                 :key #'(lambda (method)
+                                          (first (method-qualifiers method)))))))
+
+(defgeneric different-qualifiers-only-generic-function (out)
+  (:method-combination example-method-combination))
+(defmethod different-qualifiers-only-generic-function 0 (out)
+  (format out "first message;"))
+(defmethod different-qualifiers-only-generic-function 1 (out)
+  (format out "second message."))
+
+(with-test (:name (:defmethod-differing-qualifiers-same-specializers))
+  (assert (equal "first message;second message."
+                 (with-output-to-string (s)
+                   (different-qualifiers-only-generic-function s)))))
-- 
2.18.0