diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 641e27b06ee48f4c797e1695083e213a4baa0805..4a0ab06f6f7d4b146fdf6f856b15aae921daa6af 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.77 1998/10/01 16:01:48 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.78 1999/01/23 13:59:00 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -603,9 +603,11 @@ ;;; ;;; Test if the numeric-type ARG is within in domain specified by ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to -;;; be distinct as for the :negative-zero-is-not-zero feature. With -;;; the :negative-zero-is-not-zero feature this could be handled by -;;; the numeric subtype code in type.lisp. +;;; be distinct as for the :negative-zero-is-not-zero feature. Note +;;; that only inclusive and open domain limits are handled as these +;;; are the only types of limits currently used. With the +;;; :negative-zero-is-not-zero feature this could be handled by the +;;; numeric subtype code in type.lisp. ;;; (defun domain-subtypep (arg domain-low domain-high) (declare (type numeric-type arg) @@ -618,28 +620,23 @@ (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo) (minusp (float-sign arg-lo-val))) (compiler-note "Float zero bound ~s not correctly canonicalised?" arg-lo) - (setq arg-lo '(0l0) arg-lo-val 0l0)) + (setq arg-lo 0l0 arg-lo-val 0l0)) (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi) (plusp (float-sign arg-hi-val))) (compiler-note "Float zero bound ~s not correctly canonicalised?" arg-hi) - (setq arg-hi '(-0l0) arg-hi-val -0l0)) - ;; - (and (or (null domain-low) - (and arg-lo (>= arg-lo-val domain-low) - (not (and (zerop domain-low) (floatp domain-low) - (plusp (float-sign domain-low)) - (zerop arg-lo-val) (floatp arg-lo-val) - (if (consp arg-lo) - (plusp (float-sign arg-lo-val)) - (minusp (float-sign arg-lo-val))))))) - (or (null domain-high) - (and arg-hi (<= arg-hi-val domain-high) - (not (and (zerop domain-high) (floatp domain-high) - (minusp (float-sign domain-high)) - (zerop arg-hi-val) (floatp arg-hi-val) - (if (consp arg-hi) - (minusp (float-sign arg-hi-val)) - (plusp (float-sign arg-hi-val)))))))))) + (setq arg-hi -0l0 arg-hi-val -0l0)) + (flet ((fp-neg-zero-p (f) ; Is F -0.0? + (and (floatp f) (zerop f) (minusp (float-sign f)))) + (fp-pos-zero-p (f) ; Is F +0.0? + (and (floatp f) (zerop f) (plusp (float-sign f))))) + (and (or (null domain-low) + (and arg-lo (>= arg-lo-val domain-low) + (not (and (fp-pos-zero-p domain-low) + (fp-neg-zero-p arg-lo))))) + (or (null domain-high) + (and arg-hi (<= arg-hi-val domain-high) + (not (and (fp-neg-zero-p domain-high) + (fp-pos-zero-p arg-hi))))))))) ;;; Elfun-Derive-Type-Simple ;;;