X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-float.lisp;h=f7b995eb32202e7aedb66ccd31abe2a0f8091414;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=ec8f2ab208eeb485e7bce27d155bd979d1037065;hpb=4eb1a6d3ad2b7dcc19ac0ec979a1eb1eb049659a;p=sbcl.git diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp index ec8f2ab..f7b995e 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)) @@ -77,7 +77,13 @@ (if (plusp exponent) ; if not obviously denormalized (do () (nil) - (cond (;; ordinary termination case + (cond (;; special termination case, denormalized + ;; float number + (zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (return (ash significand -1))) + (;; ordinary termination case (>= significand (expt 2 23)) (assert (< 0 significand (expt 2 24))) ;; Exponent 0 is reserved for @@ -87,12 +93,7 @@ (return (logior (ash exponent 23) (logand significand (1- (ash 1 23)))))) - (;; special termination case, denormalized - ;; float number - (zerop exponent) - ;; Denormalized numbers have exponent one - ;; greater than the exponent field. - (return (ash significand -1))) + (t ;; Shift as necessary to set bit 24 of ;; significand. @@ -111,11 +112,12 @@ (ecase lisp-sign (1 unsigned-result) (-1 (logior unsigned-result (- (expt 2 31))))))))) + (defun double-float-bits (x) (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) @@ -126,7 +128,13 @@ (if (plusp exponent) ; if not obviously denormalized (do () (nil) - (cond (;; ordinary termination case + (cond (;; special termination case, denormalized + ;; float number + (zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (return (ash significand -1))) + (;; ordinary termination case (>= significand (expt 2 52)) (assert (< 0 significand (expt 2 53))) ;; Exponent 0 is reserved for @@ -136,12 +144,6 @@ (return (logior (ash exponent 52) (logand significand (1- (ash 1 52)))))) - (;; special termination case, denormalized - ;; float number - (zerop exponent) - ;; Denormalized numbers have exponent one - ;; greater than the exponent field. - (return (ash significand -1))) (t ;; Shift as necessary to set bit 53 of ;; significand. @@ -160,6 +162,7 @@ (ecase lisp-sign (1 unsigned-result) (-1 (logior unsigned-result (- (expt 2 63))))))))) + (defun double-float-low-bits (x) (declare (type double-float x)) (if (zerop x) @@ -170,10 +173,11 @@ ;; would be nice to make the family of functions have a more ;; consistent return convention. (logand #xffffffff (double-float-bits x)))) + (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 @@ -181,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 +;;; 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) @@ -207,25 +210,41 @@ ;;; 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))) + (iexpt (ldb (byte 8 23) bits)) + (expt (if (zerop iexpt) ; denormalized + -126 + (- iexpt 127))) + (mant (* (logior (ldb (byte 23 0) bits) + (if (zerop iexpt) + 0 + (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))) + (iexpt (ldb (byte 11 52) bits)) + (expt (if (zerop iexpt) ; denormalized + -1022 + (- iexpt 1023))) + (mant (* (logior (ldb (byte 52 0) bits) + (if (zerop iexpt) + 0 + (ash 1 52))) + (expt 0.5d0 52)))) + (* sign (kludge-opaque-expt 2.0d0 expt) mant))))) +