From 7c427c71c78bf672794ad2a5810598b66d672648 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Wed, 24 Sep 2003 21:29:07 +0000
Subject: [PATCH] Fix bug where the compiler was not correctly deriving the
 result type of

	(defun foo (x)
	  (declare (type (double-float (0d0)) x))
	  (* x (- (log (random 1d0)))))

ONE-ARG-DERIVE-TYPE and TWO-ARG-DERIVE-TYPE should not create member
types directly, but should use specifier-type to create them, which
will canonicalize them appropriately for the type system.  The type
system expects member types to be converted to unions of singleton
number types, except in certain cases, like signed zeroes.

Based on a patch from Christophe Rhodes, sent to cmucl-imp.
---
 compiler/srctran.lisp | 8 +++-----
 1 file changed, 3 insertions(+), 5 deletions(-)

diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 9fd471b9d..320572295 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.133 2003/09/12 12:55:18 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.134 2003/09/24 21:29:07 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1129,9 +1129,7 @@
 		  (if member-fcn
 		      (with-float-traps-masked
 			  (:underflow :overflow :divide-by-zero)
-			(make-member-type
-			 :members (list
-				   (funcall member-fcn
+			(specifier-type `(eql ,(funcall member-fcn
 					    (first (member-type-members x))))))
 		      ;; Otherwise convert to a numeric type.
 		      (let ((result-type-list
@@ -1200,7 +1198,7 @@
 						:format (type-of result)
 						:complexp :real))
 			    (t
-			     (make-member-type :members (list result))))))
+			     (specifier-type `(eql ,result))))))
 		   #-conservative-float-type
 		   ((and (member-type-p x) (member-type-p y))
 		    (let* ((x (convert-member-type x))
-- 
GitLab