X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-float.lisp;h=71f075485954058adb9f72ea54d8224e55e5d236;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=f7b995eb32202e7aedb66ccd31abe2a0f8091414;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp index f7b995e..71f0754 100644 --- a/src/code/cross-float.lisp +++ b/src/code/cross-float.lisp @@ -20,7 +20,7 @@ (declare (ignore traps)) ;; FIXME: should become STYLE-WARNING? (format *error-output* - "~&(can't portably mask float traps, proceeding anyway)~%") + "~&(can't portably mask float traps, proceeding anyway)~%") `(progn ,@body)) ;;; a helper function for DOUBLE-FLOAT-FOO-BITS functions @@ -29,12 +29,12 @@ (defun mask-and-sign-extend (x n) (assert (plusp n)) (let* ((high-bit (ash 1 (1- n))) - (mask (1- (ash high-bit 1))) - (uresult (logand mask x))) + (mask (1- (ash high-bit 1))) + (uresult (logand mask x))) (if (zerop (logand uresult high-bit)) - uresult - (logior uresult - (logand -1 (lognot mask)))))) + uresult + (logior uresult + (logand -1 (lognot mask)))))) ;;; portable implementations of SINGLE-FLOAT-BITS, ;;; DOUBLE-FLOAT-LOW-BITS, and DOUBLE-FLOAT-HIGH-BITS @@ -57,61 +57,61 @@ (if (zerop x) (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)) - ;; Calculate IEEE-style fields from Common-Lisp-style fields. - ;; - ;; KLUDGE: This code was written from my foggy memory of what IEEE - ;; format looks like, augmented by some experiments with - ;; the existing implementation of SINGLE-FLOAT-BITS, and what - ;; I found floating around on the net at - ;; , - ;; , - ;; and - ;; . - ;; And beyond the probable sheer flakiness of the code, all the bare - ;; numbers floating around here are sort of ugly, too. -- WHN 19990711 - (let* ((significand lisp-significand) - (exponent (+ lisp-exponent 23 127)) - (unsigned-result - (if (plusp exponent) ; if not obviously denormalized - (do () - (nil) - (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 - ;; denormalized numbers, and 255 is - ;; reserved for specials like NaN. - (assert (< 0 exponent 255)) - (return (logior (ash exponent 23) - (logand significand - (1- (ash 1 23)))))) + (integer-decode-float x) + (assert (plusp lisp-significand)) + ;; Calculate IEEE-style fields from Common-Lisp-style fields. + ;; + ;; KLUDGE: This code was written from my foggy memory of what IEEE + ;; format looks like, augmented by some experiments with + ;; the existing implementation of SINGLE-FLOAT-BITS, and what + ;; I found floating around on the net at + ;; , + ;; , + ;; and + ;; . + ;; And beyond the probable sheer flakiness of the code, all the bare + ;; numbers floating around here are sort of ugly, too. -- WHN 19990711 + (let* ((significand lisp-significand) + (exponent (+ lisp-exponent 23 127)) + (unsigned-result + (if (plusp exponent) ; if not obviously denormalized + (do () + (nil) + (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 + ;; denormalized numbers, and 255 is + ;; reserved for specials like NaN. + (assert (< 0 exponent 255)) + (return (logior (ash exponent 23) + (logand significand + (1- (ash 1 23)))))) - (t - ;; Shift as necessary to set bit 24 of - ;; significand. - (setf significand (ash significand 1) - exponent (1- exponent))))) - (do () - ((zerop exponent) - ;; Denormalized numbers have exponent one - ;; greater than the exponent field. - (ash significand -1)) - (unless (zerop (logand significand 1)) - (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" - x)) - (setf significand (ash significand -1) - exponent (1+ exponent)))))) - (ecase lisp-sign - (1 unsigned-result) - (-1 (logior unsigned-result (- (expt 2 31))))))))) + (t + ;; Shift as necessary to set bit 24 of + ;; significand. + (setf significand (ash significand 1) + exponent (1- exponent))))) + (do () + ((zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (ash significand -1)) + (unless (zerop (logand significand 1)) + (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" + x)) + (setf significand (ash significand -1) + exponent (1+ exponent)))))) + (ecase lisp-sign + (1 unsigned-result) + (-1 (logior unsigned-result (- (expt 2 31))))))))) (defun double-float-bits (x) (declare (type double-float x)) @@ -120,48 +120,48 @@ (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) - (assert (plusp lisp-significand)) - (let* ((significand lisp-significand) - (exponent (+ lisp-exponent 52 1023)) - (unsigned-result - (if (plusp exponent) ; if not obviously denormalized - (do () - (nil) - (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 - ;; denormalized numbers, and 2047 is - ;; reserved for specials like NaN. - (assert (< 0 exponent 2047)) - (return (logior (ash exponent 52) - (logand significand - (1- (ash 1 52)))))) - (t - ;; Shift as necessary to set bit 53 of - ;; significand. - (setf significand (ash significand 1) - exponent (1- exponent))))) - (do () - ((zerop exponent) - ;; Denormalized numbers have exponent one - ;; greater than the exponent field. - (ash significand -1)) - (unless (zerop (logand significand 1)) - (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" - x)) - (setf significand (ash significand -1) - exponent (1+ exponent)))))) - (ecase lisp-sign - (1 unsigned-result) - (-1 (logior unsigned-result (- (expt 2 63))))))))) + (integer-decode-float x) + (assert (plusp lisp-significand)) + (let* ((significand lisp-significand) + (exponent (+ lisp-exponent 52 1023)) + (unsigned-result + (if (plusp exponent) ; if not obviously denormalized + (do () + (nil) + (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 + ;; denormalized numbers, and 2047 is + ;; reserved for specials like NaN. + (assert (< 0 exponent 2047)) + (return (logior (ash exponent 52) + (logand significand + (1- (ash 1 52)))))) + (t + ;; Shift as necessary to set bit 53 of + ;; significand. + (setf significand (ash significand 1) + exponent (1- exponent))))) + (do () + ((zerop exponent) + ;; Denormalized numbers have exponent one + ;; greater than the exponent field. + (ash significand -1)) + (unless (zerop (logand significand 1)) + (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" + x)) + (setf significand (ash significand -1) + exponent (1+ exponent)))))) + (ecase lisp-sign + (1 unsigned-result) + (-1 (logior unsigned-result (- (expt 2 63))))))))) (defun double-float-low-bits (x) (declare (type double-float x)) @@ -226,7 +226,7 @@ 0 (ash 1 23))) (expt 0.5 23)))) - (* sign (kludge-opaque-expt 2.0 expt) mant))))) + (* sign (kludge-opaque-expt 2.0 expt) mant))))) (defun make-double-float (hi lo) (cond @@ -234,17 +234,17 @@ ((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))) + (sign (ecase (ldb (byte 1 63) bits) + (0 1.0d0) + (1 -1.0d0))) (iexpt (ldb (byte 11 52) bits)) - (expt (if (zerop iexpt) ; denormalized + (expt (if (zerop iexpt) ; denormalized -1022 (- iexpt 1023))) - (mant (* (logior (ldb (byte 52 0) bits) - (if (zerop iexpt) + (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))))) + (expt 0.5d0 52)))) + (* sign (kludge-opaque-expt 2.0d0 expt) mant)))))