diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 476d88854f45e67e82aa96c2129fdfd5f0e8b535..641e27b06ee48f4c797e1695083e213a4baa0805 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.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/float-tran.lisp,v 1.76 1998/09/29 13:16:28 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.77 1998/10/01 16:01:48 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -575,6 +575,16 @@ ;;;; function, based on the domain of the input. ;;;; +;;; Generate a specifier for a complex type specialized to the same +;;; type as the argument. +(defun complex-float-type (arg) + (declare (type numeric-type arg)) + (let* ((format (case (numeric-type-class arg) + ((integer rational) 'single-float) + (t (numeric-type-format arg)))) + (float-type (or format 'float))) + (specifier-type `(complex ,float-type)))) + ;;; Compute a specifier like '(or float (complex float)), except float ;;; should be the right kind of float. Allow bounds for the float ;;; part too. @@ -698,7 +708,8 @@ (list result-type (specifier-type `(complex ,bound-type)))))) (t - (float-or-complex-float-type arg))))) + ;; No intersection so the result must be purely complex. + (complex-float-type arg))))) (t (float-or-complex-float-type arg default-low default-high)))))) diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index f49a5558773962d18846a3a13d973f60b96c9208..a40d483103cad1578a65163619c9913f38760813 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.86 1998/09/20 15:16:14 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.87 1998/10/01 16:01:47 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -388,6 +388,35 @@ ('both (and (interval-low x) (interval-high x))))) +;;; Signed zero comparison functions. Use these functions if we need +;;; to distinguish between signed zeroes. + +(defun signed-zero-< (x y) + (declare (real x y)) + (or (< x y) + (and (= x y) + (< (float-sign (float x)) + (float-sign (float y)))))) +(defun signed-zero-> (x y) + (declare (real x y)) + (or (> x y) + (and (= x y) + (> (float-sign (float x)) + (float-sign (float y)))))) + +(defun signed-zero-= (x y) + (declare (real x y)) + (and (= x y) + (= (float-sign (float x)) + (float-sign (float y))))) + +(defun signed-zero-<= (x y) + (declare (real x y)) + (or (< x y) + (and (= x y) + (<= (float-sign (float x)) + (float-sign (float y)))))) + ;;; INTERVAL-CONTAINS-P ;;; ;;; See if the interval X contains the number P, taking into account @@ -402,25 +431,26 @@ (hi (interval-high x))) (cond ((and lo hi) ;; The interval is bounded - (if (<= (bound-value lo) p (bound-value hi)) + (if (and (signed-zero-<= (bound-value lo) p) + (signed-zero-<= p (bound-value hi))) ;; P is definitely in the closure of the interval. ;; We just need to check the end points now. - (cond ((= p (bound-value lo)) + (cond ((signed-zero-= p (bound-value lo)) (numberp lo)) - ((= p (bound-value hi)) + ((signed-zero-= p (bound-value hi)) (numberp hi)) (t t)) nil)) (hi ;; Interval with upper bound - (if (< p (bound-value hi)) + (if (signed-zero-< p (bound-value hi)) t - (and (numberp hi) (= p hi)))) + (and (numberp hi) (signed-zero-= p hi)))) (lo ;; Interval with lower bound - (if (> p (bound-value lo)) + (if (signed-zero-> p (bound-value lo)) t - (and (numberp lo) (= p lo)))) + (and (numberp lo) (signed-zero-= p lo)))) (t ;; Interval with no bounds t))))