0.9.3.14:

	Fix bug reported by Bruno Haible sbcl-devel 2004-08-02
	("standard method-combination ignores overridden
          compute-applicable-methods")
	... woohoo!  Less than a year between report and fix :-)
	... be more careful about assuming that we know the precedence
		order of methods when computing a discriminating net
		for a DISPATCH-DFUN.
	... (NB: this is not quite the same patch as I sent to
		sbcl-devel 2005-07-29: the dispatch dfun can cope with
		unsorted methods, so exploit that instead.)
	... only one test case is currently running; when the bug
		related to instances of two user-defined generic
		function classes is fixed, the second test case can run
		as well.

diff --git a/NEWS b/NEWS
index 5c230c7..c9c175d 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,10 @@
 changes in sbcl-0.9.4 relative to sbcl-0.9.3:
   * enhancement: SBCL on MIPS platforms now has a much larger dynamic
     space for its heap.  (thanks to Thiemo Seufer)
+  * bug fix: discriminating functions for generic function classes
+    with non-standard methods for COMPUTE-APPLICABLE-METHODS no longer
+    make invalid assumptions about method precedence order.  (reported
+    by Bruno Haible)
   * optimizations: REMOVE-DUPLICATES now runs in linear time on
     lists in some cases.  This partially fixes bug 384.
 

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index a10c91f..39f0b5c 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -615,7 +615,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
   (when (eq *boot-state* 'complete)
-    (unless (or caching-p (gf-requires-emf-keyword-checks gf))
+    (unless (or caching-p 
+                (gf-requires-emf-keyword-checks gf))
       ;; This should return T when almost all dispatching is by
       ;; eql specializers or built-in classes. In other words,
       ;; return NIL if we might ever need to do more than

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 140115a..91e746e 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1043,20 +1043,22 @@
 
 (defun generate-discrimination-net (generic-function methods types sorted-p)
   (let* ((arg-info (gf-arg-info generic-function))
+        (c-a-m-emf-std-p (gf-info-c-a-m-emf-std-p arg-info))
          (precedence (arg-info-precedence arg-info)))
     (generate-discrimination-net-internal
      generic-function methods types
      (lambda (methods known-types)
        (if (or sorted-p
-               (block one-order-p
-                 (let ((sorted-methods nil))
-                   (map-all-orders
-                    (copy-list methods) precedence
-                    (lambda (methods)
-                      (when sorted-methods (return-from one-order-p nil))
-                      (setq sorted-methods methods)))
-                   (setq methods sorted-methods))
-                 t))
+              (and c-a-m-emf-std-p
+                   (block one-order-p
+                     (let ((sorted-methods nil))
+                       (map-all-orders
+                        (copy-list methods) precedence
+                        (lambda (methods)
+                          (when sorted-methods (return-from one-order-p nil))
+                          (setq sorted-methods methods)))
+                       (setq methods sorted-methods))
+                     t)))
            `(methods ,methods ,known-types)
            `(unordered-methods ,methods ,known-types)))
      (lambda (position type true-value false-value)

diff --git a/tests/mop-3.impure-cload.lisp b/tests/mop-3.impure-cload.lisp
new file mode 100644 (file)
index 0000000..173ba20
--- /dev/null
+++ b/tests/mop-3.impure-cload.lisp
@@ -0,0 +1,94 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; This file contains two tests for COMPUTE-APPLICABLE-METHODS on
+;;; subclasses of generic functions.  However, at present it is
+;;; impossible to have both of these in the same image, because of a
+;;; vicious metacircle.  Once the vicious metacircle is dealt with,
+;;; uncomment the second test case.
+
+;;; tests from Bruno Haible (sbcl-devel 2004-08-02)
+
+(defpackage "MOP-3"
+  (:use "CL" "SB-MOP"))
+
+(in-package "MOP-3")
+
+(defclass msl-generic-function (standard-generic-function)
+  ()
+  (:metaclass funcallable-standard-class))
+
+(defun reverse-method-list (methods)
+  (let ((result '()))
+    (dolist (method methods)
+      (if (and (consp result)
+               (equal (method-qualifiers method) 
+                      (method-qualifiers (caar result))))
+          (push method (car result))
+          (push (list method) result)))
+    (reduce #'append result)))
+
+(defmethod compute-applicable-methods ((gf msl-generic-function) arguments)
+  (reverse-method-list (call-next-method)))
+(defmethod compute-applicable-methods-using-classes 
+    ((gf msl-generic-function) classes)
+  (reverse-method-list (call-next-method)))
+
+(defgeneric testgf07 (x) 
+  (:generic-function-class msl-generic-function)
+  (:method ((x integer)) 
+    (cons 'integer (if (next-method-p) (call-next-method))))
+  (:method ((x real)) 
+    (cons 'real (if (next-method-p) (call-next-method))))
+  (:method ((x number)) 
+    (cons 'number (if (next-method-p) (call-next-method))))
+  (:method :around ((x integer)) 
+    (coerce (call-next-method) 'vector)))
+
+(assert (equalp (list (testgf07 5.0) (testgf07 17))
+                '((number real) #(number real integer))))
+
+#|
+(defclass nonumber-generic-function (standard-generic-function)
+  ()
+  (:metaclass funcallable-standard-class))
+
+(defun nonumber-method-list (methods)
+  (remove-if #'(lambda (method)
+                 (member (find-class 'number)
+                         (sb-pcl:method-specializers method)))
+             methods))
+
+(defmethod compute-applicable-methods 
+    ((gf nonumber-generic-function) arguments)
+  (nonumber-method-list (call-next-method)))
+(defmethod compute-applicable-methods-using-classes 
+    ((gf nonumber-generic-function) classes)
+  (nonumber-method-list (call-next-method)))
+
+(defgeneric testgf08 (x) 
+  (:generic-function-class nonumber-generic-function)
+  (:method ((x integer)) 
+    (cons 'integer (if (next-method-p) (call-next-method))))
+  (:method ((x real)) 
+    (cons 'real (if (next-method-p) (call-next-method))))
+  (:method ((x number)) 
+    (cons 'number (if (next-method-p) (call-next-method))))
+  (:method :around ((x integer)) 
+    (coerce (call-next-method) 'vector)))
+
+(assert (equalp (list (testgf08 5.0) (testgf08 17))
+                '((real) #(integer real))))
+|#
+
+(sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 7f3b8d1..859320c 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.3.13"
+"0.9.3.14"