From a97775d248525618f538b3d128f895aef61a5fd7 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Thu, 5 Jun 2003 12:35:22 +0000 Subject: [PATCH] Fix a bug in constant-value dispatching found by Paul Dietz. * src/pcl/dfun.lisp (use-constant-value-dfun-p): Check more preconditions. (constant-value-miss): Add an assertion. --- pcl/dfun.lisp | 88 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 57 insertions(+), 31 deletions(-) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index ac678974f..383c6c70e 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.29 2003/06/03 10:28:23 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.30 2003/06/05 12:35:22 gerd Exp $") (in-package :pcl) @@ -543,26 +543,44 @@ And so, we are saved. (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-function-info gf) (declare (ignore nreq metatypes nkeys)) - (let* ((early-p (early-gf-p gf)) - (methods (generic-function-methods* gf)) - (default '(unknown))) + (let ((methods (generic-function-methods* gf))) (and (null applyp) (or (not (eq *boot-state* 'complete)) - (compute-applicable-methods-emf-std-p gf)) - (notany (lambda (method) - (or (and (eq *boot-state* 'complete) - (some #'eql-specializer-p - (method-specializers method))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) - :constant-value default))) - (if boolean-values-p - (not (or (eq value t) (eq value nil))) - (eq value default))))) - methods))))) + ;; + ;; If COMPUTE-APPLICABLE-METHODS is specialized, we + ;; can't use this, of course, because we can't tell + ;; which methods will be considered applicable. + ;; + ;; Also, don't use this method if the generic function + ;; has a non-standard method combination, because if it + ;; has, it's not sure that method functions are used + ;; directly as effective methods, which + ;; CONSTANT-VALUE-MISS depends on. The pre-defined + ;; method combinations like LIST are examples of that. + (and (compute-applicable-methods-emf-std-p gf) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + ;; + ;; Check that no method is eql-specialized, and that all + ;; methods return a constant value. If BOOLEAN-VALUES-P, + ;; check that all return T or NIL. Also, check that no + ;; method has specializers, to make sure that emfs are + ;; really method functions; see above. + (dolist (method methods t) + (when (eq *boot-state* 'complete) + (when (or (some #'eql-specializer-p + (method-specializers method)) + (method-qualifiers method)) + (return nil))) + (let* ((mf (if (consp method) + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method)))) + (constant (method-function-get mf :constant-value mf))) + (when (or (eq constant mf) + (and boolean-values-p + (not (member constant '(t nil))))) + (return nil)))))))) (defun make-constant-value-dfun (generic-function &optional cache) (multiple-value-bind (nreq applyp metatypes nkeys) @@ -1042,19 +1060,27 @@ And so, we are saved. (dfun-update generic-function #'make-caching-dfun ncache)))))))) -(defun constant-value-miss (generic-function args dfun-info) +(defun constant-value-miss (gf args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) - (dfun-miss (generic-function args wrappers invalidp emf nil nil t) - (cond (invalidp) - (t - (let* ((function (typecase emf - (fast-method-call (fast-method-call-function emf)) - (method-call (method-call-function emf)))) - (value (method-function-get function :constant-value)) - (ncache (fill-cache ocache wrappers value))) - (unless (eq ncache ocache) - (dfun-update generic-function - #'make-constant-value-dfun ncache)))))))) + (dfun-miss (gf args wrappers invalidp emf nil nil t) + (unless invalidp + (let* ((mf (typecase emf + (fast-method-call (fast-method-call-function emf)) + (method-call (method-call-function emf)))) + (value (let ((val (method-function-get mf :constant-value + '.not-found.))) + ;; + ;; This way of retrieving the constant value + ;; assumes that the emf is actually a method + ;; function that's used directly as effective + ;; method function. Let's check that is + ;; indeed the case, because it sometimes + ;; wasn't. + (assert (neq val '.not-found.)) + val)) + (ncache (fill-cache ocache wrappers value))) + (unless (eq ncache ocache) + (dfun-update gf #'make-constant-value-dfun ncache))))))) ;;; Given a generic function and a set of arguments to that generic function, ;;; returns a mess of values. -- GitLab