projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
0.7.13.3
[sbcl.git]
/
src
/
code
/
cross-float.lisp
diff --git
a/src/code/cross-float.lisp
b/src/code/cross-float.lisp
index
ec8f2ab
..
e7236c1
100644
(file)
--- a/
src/code/cross-float.lisp
+++ b/
src/code/cross-float.lisp
@@
-77,7
+77,13
@@
(if (plusp exponent) ; if not obviously denormalized
(do ()
(nil)
(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
(>= 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))))))
(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.
(t
;; Shift as necessary to set bit 24 of
;; significand.
@@
-111,6
+112,7
@@
(ecase lisp-sign
(1 unsigned-result)
(-1 (logior unsigned-result (- (expt 2 31)))))))))
(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))
(defun double-float-bits (x)
(declare (type double-float x))
(assert (= (float-radix x) 2))
@@
-126,7
+128,13
@@
(if (plusp exponent) ; if not obviously denormalized
(do ()
(nil)
(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
(>= 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))))))
(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.
(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)))))))))
(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)
(defun double-float-low-bits (x)
(declare (type double-float x))
(if (zerop x)
@@
-170,6
+173,7
@@
;; would be nice to make the family of functions have a more
;; consistent return convention.
(logand #xffffffff (double-float-bits x))))
;; 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)
(defun double-float-high-bits (x)
(declare (type double-float x))
(if (zerop x)
@@
-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?
;;; 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
;;; 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)
;;; 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)
@@
-217,6
+220,7
@@
(ash 1 23))
(expt 0.5 23))))
(* sign (kludge-opaque-expt 2.0 expt) mant))))
(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
(defun make-double-float (hi lo)
(if (and (zerop hi) (zerop lo)) ; IEEE float special case
0.0d0