0.9.6.15:

	Make REINITIALIZE-INSTANCE on generic functions always call
	COMPUTE-DISCRIMINATING-FUNCTION, as required by AMOP.

diff --git a/NEWS b/NEWS
index 215c3e2..48638e9 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,9 @@ changes in sbcl-0.9.7 relative to sbcl-0.9.6:
     least permitted and maybe required by AMOP).  As a consolation,
     however, the SBCL implementation of these functions now calls
     REINITIALIZE-INSTANCE as specified by AMOP.
+  * bug fix: REINITIALIZE-INSTANCE on generic functions calls
+    COMPUTE-DISCRIMINATING-FUNCTION (almost) unconditionally, as
+    specified by AMOP.
   * bug fix: it is now possible to have more than one subclass of
     STANDARD-GENERIC-FUNCTION without causing stack overflow.
     (reported by Bruno Haible, Pascal Costanza and others)

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 2d8acb7..15601a1 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -968,25 +968,25 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
 (defun accessor-miss (gf new object dfun-info)
   (let ((wrapper (wrapper-of object))
-       (previous-miss (assq gf *accessor-miss-history*)))
+        (previous-miss (assq gf *accessor-miss-history*)))
     (when (eq wrapper (cdr previous-miss))
       (error "~@<Vicious metacircle:  The computation of a ~
               dfun of ~s for argument ~s uses the dfun being ~
               computed.~@:>"
-            gf object))
+             gf object))
     (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*))
-          (ostate (type-of dfun-info))
-          (otype (dfun-info-accessor-type dfun-info))
-          oindex ow0 ow1 cache
-          (args (ecase otype
-                  ((reader boundp) (list object))
-                  (writer (list new object)))))
+           (ostate (type-of dfun-info))
+           (otype (dfun-info-accessor-type dfun-info))
+           oindex ow0 ow1 cache
+           (args (ecase otype
+                   ((reader boundp) (list object))
+                   (writer (list new object)))))
       (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
-       ;; The following lexical functions change the state of the
-       ;; dfun to that which is their name.  They accept arguments
-       ;; which are the parameters of the new state, and get other
-       ;; information from the lexical variables bound above.
-       (flet ((two-class (index w0 w1)
+        ;; The following lexical functions change the state of the
+        ;; dfun to that which is their name.  They accept arguments
+        ;; which are the parameters of the new state, and get other
+        ;; information from the lexical variables bound above.
+        (flet ((two-class (index w0 w1)
                (when (zerop (random 2)) (psetf w0 w1 w1 w0))
                (dfun-update gf
                             #'make-two-class-accessor-dfun

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index f721a4b..ae16f99 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -456,9 +456,7 @@
                        :argument-precedence-order argument-precedence-order))
         (lambda-list-p (set-arg-info gf :lambda-list lambda-list))
         (t (set-arg-info gf)))
-      (when (and (arg-info-valid-p (gf-arg-info gf))
-                 (not (null args))
-                 (or lambda-list-p (cddr args)))
+      (when (arg-info-valid-p (gf-arg-info gf))
         (update-dfun gf))
       (map-dependents gf (lambda (dependent)
                            (apply #'update-dependent gf dependent args))))))

diff --git a/tests/mop-10.impure-cload.lisp b/tests/mop-10.impure-cload.lisp
new file mode 100644 (file)
index 0000000..26cdd72
--- /dev/null
+++ b/tests/mop-10.impure-cload.lisp
@@ -0,0 +1,41 @@
+;;;; 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 tests of REINITIALIZE-INSTANCE on generic
+;;; functions.
+
+(defpackage "MOP-10"
+  (:use "CL" "SB-MOP" "TEST-UTIL"))
+
+(in-package "MOP-10")
+
+(defclass my-generic-function (standard-generic-function)
+  ()
+  (:metaclass funcallable-standard-class))
+
+(defgeneric foo (x)
+  (:method-combination list)
+  (:method list ((x float)) (* x x))
+  (:method list ((x integer)) (1+ x))
+  (:method list ((x number)) (expt x 2))
+  (:generic-function-class my-generic-function))
+
+(assert (equal (foo 3) '(4 9)))
+(defmethod compute-discriminating-function ((gf my-generic-function))
+  (let ((orig (call-next-method)))
+    (lambda (&rest args)
+      (let ((orig-result (apply orig args)))
+        (cons gf (reverse orig-result))))))
+(assert (equal (foo 3) '(4 9)))
+(reinitialize-instance #'foo)
+(assert (equal (foo 3) (cons #'foo '(9 4))))

diff --git a/version.lisp-expr b/version.lisp-expr
index bb543ba..33949f1 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.6.14"
+"0.9.6.15"