0.8.1.52:

[sbcl.git] / src / compiler / float-tran.lisp

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index f4f65bf..972a954 100644 (file)
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -426,7 +426,7 @@
                                 `(coerce (,',prim-quick (coerce x 'double-float))
                                   'single-float))
                                (t
-                                (compiler-note
+                                (compiler-notify
                                  "unable to avoid inline argument range check~@
                                   because the argument range (~S) was not within 2^64"
                                  (type-specifier (continuation-type x)))
@@ -439,7 +439,7 @@
                                                             (#.(expt 2d0 64)))))
                                `(,',prim-quick x))
                               (t
-                               (compiler-note
+                               (compiler-notify
                                 "unable to avoid inline argument range check~@
                                  because the argument range (~S) was not within 2^64"
                                 (type-specifier (continuation-type x)))
@@ -560,35 +560,28 @@
     ;; Check that the ARG bounds are correctly canonicalized.
     (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 canonicalized?" arg-lo)
-      (setq arg-lo '(0e0) arg-lo-val 0e0))
+      (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo)
+      (setq arg-lo 0e0 arg-lo-val arg-lo))
     (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 canonicalized?" arg-hi)
-      (setq arg-hi `(,(ecase *read-default-float-format*
-                       (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
-                       #!+long-float
-                       (long-float (load-time-value (make-unportable-float :long-float-negative-zero)))))
-           arg-hi-val (ecase *read-default-float-format*
-                        (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
-                        #!+long-float
-                        (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))))
-    (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))))))))))
+      (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi)
+      (setq arg-hi (ecase *read-default-float-format*
+                     (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+                     #!+long-float
+                     (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))
+           arg-hi-val arg-hi))
+    (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)))))))))
 (eval-when (:compile-toplevel :execute)
   (setf *read-default-float-format* 'single-float))