(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
(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
(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
- ;; <http://www.scri.fsu.edu/~jac/MAD3401/Backgrnd/ieee.html>,
- ;; <http://rodin.cs.uh.edu/~johnson2/ieee.html>,
- ;; and
- ;; <http://www.ttu.ee/sidu/cas/IEEE_Floating.htm>.
- ;; 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
+ ;; <http://www.scri.fsu.edu/~jac/MAD3401/Backgrnd/ieee.html>,
+ ;; <http://rodin.cs.uh.edu/~johnson2/ieee.html>,
+ ;; and
+ ;; <http://www.ttu.ee/sidu/cas/IEEE_Floating.htm>.
+ ;; 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))
(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))
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
((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)))))
projects / sbcl.git / blobdiff