X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=972a954742c37e943709c433495b825f9a8016b7;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=b0e652a88cfa0363574a6b68c87f1175fa760396;hpb=d323b0249b9b1e4a91ddf8716ac9185cd268d973;p=sbcl.git

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index b0e652a..972a954 100644
--- 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)))
@@ -538,11 +538,18 @@
     (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
 			 (complex ,float-type)))))
 
+) ; PROGN
+
+(eval-when (:compile-toplevel :execute)
+  ;; So the problem with this hack is that it's actually broken.  If
+  ;; the host does not have long floats, then setting *R-D-F-F* to
+  ;; LONG-FLOAT doesn't actually buy us anything.  FIXME.
+  (setf *read-default-float-format*
+	#!+long-float 'long-float #!-long-float 'double-float))
 ;;; Test whether 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.
+#-sb-xc-host  ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (defun domain-subtypep (arg domain-low domain-high)
   (declare (type numeric-type arg)
 	   (type (or real null) domain-low domain-high))
@@ -553,28 +560,33 @@
     ;; 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 '(0l0) arg-lo-val 0l0))
+      (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 '(-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))))))))))
+      (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))
+
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+(progn
 
 ;;; Handle monotonic functions of a single variable whose domain is
 ;;; possibly part of the real line. ARG is the variable, FCN is the
@@ -585,8 +597,7 @@
 ;;; result, which occurs for the parts of ARG not in the DOMAIN.
 ;;;
 ;;; Negative and positive zero are considered distinct within
-;;; DOMAIN-LOW and DOMAIN-HIGH, as for the :negative-zero-is-not-zero
-;;; feature.
+;;; DOMAIN-LOW and DOMAIN-HIGH.
 ;;;
 ;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
 ;;; can't compute the bounds using FCN.
@@ -675,7 +686,7 @@
   (frob atanh -1d0 1d0 -1 1)
   ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
   ;; includes -0.0.
-  (frob sqrt -0d0 nil 0 nil))
+  (frob sqrt (load-time-value (make-unportable-float :double-float-negative-zero)) nil 0 nil))
 
 ;;; Compute bounds for (expt x y). This should be easy since (expt x
 ;;; y) = (exp (* y (log x))). However, computations done this way