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