From: Christophe Rhodes Date: Mon, 1 Aug 2005 10:14:05 +0000 (+0000) Subject: 0.9.3.14: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=176fec4cc52018f811f343f339c79fbf58ab1838;p=sbcl.git 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 --- 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 --- 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 --- 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 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 --- 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"