From: Christophe R. <cr...@us...> - 2002-06-14 21:50:18
|
Update of /cvsroot/sbcl/sbcl/src/code In directory usw-pr-cvs1:/tmp/cvs-serv5933/src/code Modified Files: cross-float.lisp Log Message: 0.7.4.33: The missing piece in the OpenMCL build... ... move some clauses around in cross-compilation float logic. NB: I am _not_ sure that this is correct in any sense other than the empirical "it works". The IEEE-representation logic for the cross-compiler needs review by someone who knows what an IEEE float looks like. For now, though... ... now SBCL builds under OpenMCL! Index: cross-float.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cross-float.lisp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- cross-float.lisp 31 Oct 2001 17:51:05 -0000 1.7 +++ cross-float.lisp 14 Jun 2002 21:50:15 -0000 1.8 @@ -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,6 +112,7 @@ (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)) @@ -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,6 +173,7 @@ ;; 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) @@ -217,6 +221,7 @@ (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 |