Skip to content
Snippets Groups Projects
Commit bc8ef03a authored by dtc's avatar dtc
Browse files

Fixes for domain-subtypep.

parent 260d3351
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -603,9 +603,11 @@
;;; ;;;
;;; Test if the numeric-type ARG is within in domain specified by ;;; Test if the numeric-type ARG is within in domain specified by
;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
;;; be distinct as for the :negative-zero-is-not-zero feature. With ;;; be distinct as for the :negative-zero-is-not-zero feature. Note
;;; the :negative-zero-is-not-zero feature this could be handled by ;;; that only inclusive and open domain limits are handled as these
;;; the numeric subtype code in type.lisp. ;;; 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) (defun domain-subtypep (arg domain-low domain-high)
(declare (type numeric-type arg) (declare (type numeric-type arg)
...@@ -618,28 +620,23 @@ ...@@ -618,28 +620,23 @@
(when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo) (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
(minusp (float-sign arg-lo-val))) (minusp (float-sign arg-lo-val)))
(compiler-note "Float zero bound ~s not correctly canonicalised?" arg-lo) (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) (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
(plusp (float-sign arg-hi-val))) (plusp (float-sign arg-hi-val)))
(compiler-note "Float zero bound ~s not correctly canonicalised?" arg-hi) (compiler-note "Float zero bound ~s not correctly canonicalised?" arg-hi)
(setq arg-hi '(-0l0) arg-hi-val -0l0)) (setq arg-hi -0l0 arg-hi-val -0l0))
;; (flet ((fp-neg-zero-p (f) ; Is F -0.0?
(and (or (null domain-low) (and (floatp f) (zerop f) (minusp (float-sign f))))
(and arg-lo (>= arg-lo-val domain-low) (fp-pos-zero-p (f) ; Is F +0.0?
(not (and (zerop domain-low) (floatp domain-low) (and (floatp f) (zerop f) (plusp (float-sign f)))))
(plusp (float-sign domain-low)) (and (or (null domain-low)
(zerop arg-lo-val) (floatp arg-lo-val) (and arg-lo (>= arg-lo-val domain-low)
(if (consp arg-lo) (not (and (fp-pos-zero-p domain-low)
(plusp (float-sign arg-lo-val)) (fp-neg-zero-p arg-lo)))))
(minusp (float-sign arg-lo-val))))))) (or (null domain-high)
(or (null domain-high) (and arg-hi (<= arg-hi-val domain-high)
(and arg-hi (<= arg-hi-val domain-high) (not (and (fp-neg-zero-p domain-high)
(not (and (zerop domain-high) (floatp domain-high) (fp-pos-zero-p arg-hi)))))))))
(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))))))))))
;;; Elfun-Derive-Type-Simple ;;; Elfun-Derive-Type-Simple
;;; ;;;
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment