X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-float.lisp;h=e0b2eb009f751ef30ca55d88f348a30b310c289a;hb=26341a4b638f5480993e9715bfb637e560592819;hp=7fcb3e052580de6305d024a0ae672bb9acc67762;hpb=13719956d7f8944ed88a29998e7f76400f873206;p=sbcl.git

diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp
index 7fcb3e0..e0b2eb0 100644
--- a/src/code/cross-float.lisp
+++ b/src/code/cross-float.lisp
@@ -55,7 +55,7 @@
   (declare (type single-float x))
   (assert (= (float-radix x) 2))
   (if (zerop x)
-      0 ; known property of IEEE floating point: 0.0 is represented as 0.
+      (if (eql x 0.0f0) 0 #x-80000000)
       (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
 	  (integer-decode-float x)
 	(assert (plusp lisp-significand))
@@ -117,7 +117,7 @@
   (declare (type double-float x))
   (assert (= (float-radix x) 2))
   (if (zerop x)
-      0 ; known property of IEEE floating point: 0.0d0 is represented as 0.
+      (if (eql x 0.0d0) 0 #x-8000000000000000)
       ;; KLUDGE: As per comments in SINGLE-FLOAT-BITS, above.
       (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
 	  (integer-decode-float x)
@@ -177,7 +177,7 @@
 (defun double-float-high-bits (x)
   (declare (type double-float x))
   (if (zerop x)
-      0
+      (if (eql x 0.0d0) 0 #x-80000000)
       (mask-and-sign-extend (ash (double-float-bits x) -32) 32)))
 
 ;;; KLUDGE: This is a hack to work around a bug in CMU CL 18c which
@@ -185,10 +185,9 @@
 ;;; when trying to optimize the EXPT forms in the MAKE-FOO-FLOAT
 ;;; functions below. See the message
 ;;;   Subject: Re: Compiler bug?
-;;;   From: Raymond Toy <toy@rtp.ericsson.se>
+;;;   From: Raymond Toy
 ;;;   Date: 28 Mar 2001 08:19:59 -0500
-;;;   Message-ID: <4nvgou3u9s.fsf@rtp.ericsson.se>
-;;; on the cmucl-imp@cons.org mailing list. Once the CMU CL folks
+;;; on the cmucl-imp mailing list. Once the CMU CL folks
 ;;; make a bug-fix release, we can get rid of this and go back to
 ;;; calling EXPT directly. -- WHN 2001-04-05
 (defun kludge-opaque-expt (x y)
@@ -211,26 +210,31 @@
 ;;; workarounds *do* look messy to me, which is why I just went
 ;;; with this quick kludge instead.) -- WHN 19990711
 (defun make-single-float (bits)
-  (if (zerop bits) ; IEEE float special case
-      0.0
-      (let ((sign (ecase (ldb (byte 1 31) bits)
-		    (0  1.0)
-		    (1 -1.0)))
-	    (expt (- (ldb (byte 8 23) bits) 127))
-	    (mant (* (logior (ldb (byte 23 0) bits)
-			     (ash 1 23))
-		     (expt 0.5 23))))
-	(* sign (kludge-opaque-expt 2.0 expt) mant))))
+  (cond
+    ;; IEEE float special cases
+    ((zerop bits) 0.0)
+    ((= bits #x-80000000) -0.0)
+    (t (let ((sign (ecase (ldb (byte 1 31) bits)
+		     (0  1.0)
+		     (1 -1.0)))
+	     (expt (- (ldb (byte 8 23) bits) 127))
+	     (mant (* (logior (ldb (byte 23 0) bits)
+			      (ash 1 23))
+		      (expt 0.5 23))))
+	 (* sign (kludge-opaque-expt 2.0 expt) mant)))))
 
 (defun make-double-float (hi lo)
-  (if (and (zerop hi) (zerop lo)) ; IEEE float special case
-      0.0d0
-      (let* ((bits (logior (ash hi 32) lo))
-	     (sign (ecase (ldb (byte 1 63) bits)
-		     (0  1.0d0)
-		     (1 -1.0d0)))
-	     (expt (- (ldb (byte 11 52) bits) 1023))
-	     (mant (* (logior (ldb (byte 52 0) bits)
-			      (ash 1 52))
-		      (expt 0.5d0 52))))
-	(* sign (kludge-opaque-expt 2.0d0 expt) mant))))
+  (cond
+    ;; IEEE float special cases
+    ((and (zerop hi) (zerop lo)) 0.0d0)
+    ((and (= hi #x-80000000) (zerop lo)) -0.0d0)
+    (t (let* ((bits (logior (ash hi 32) lo))
+	      (sign (ecase (ldb (byte 1 63) bits)
+		      (0  1.0d0)
+		      (1 -1.0d0)))
+	      (expt (- (ldb (byte 11 52) bits) 1023))
+	      (mant (* (logior (ldb (byte 52 0) bits)
+			       (ash 1 52))
+		       (expt 0.5d0 52))))
+	 (* sign (kludge-opaque-expt 2.0d0 expt) mant)))))
+