From 2d10bc4b0d8557a5c553d13a3d520c40b48414db Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 4 Nov 2005 11:18:37 +0000 Subject: [PATCH] 0.9.6.15: Make REINITIALIZE-INSTANCE on generic functions always call COMPUTE-DISCRIMINATING-FUNCTION, as required by AMOP. --- NEWS | 3 +++ src/pcl/dfun.lisp | 26 ++++++++++++------------- src/pcl/methods.lisp | 4 +--- tests/mop-10.impure-cload.lisp | 41 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 59 insertions(+), 17 deletions(-) create mode 100644 tests/mop-10.impure-cload.lisp diff --git a/NEWS b/NEWS index 215c3e2..48638e9 100644 --- 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 --- 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 "~@" - 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 --- 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 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 --- 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" -- 1.7.10.4