Date: Friday, September 2, 2011 @ 22:19:03
Author: rtoy
Path: /project/cmucl/cvsroot/src
Modified: code/float.lisp general-info/release-20c.txt
Fix rounding for large numbers.
Bug was pointed by Christophe in private email. Fix is based on his
suggested solution. Some examples that should work now:
(round 100000000002.9d0) -> 100000000003
(round (+ most-positive-fixnum 1.5w0)) -> 536870912
------------------------------+
code/float.lisp | 67 ++++++++++++++++++++++-------------------
general-info/release-20c.txt | 2 +
2 files changed, 38 insertions(+), 31 deletions(-)
Index: src/code/float.lisp
diff -u src/code/float.lisp:1.48 src/code/float.lisp:1.49
--- src/code/float.lisp:1.48 Tue Apr 20 10:57:44 2010
+++ src/code/float.lisp Fri Sep 2 22:19:03 2011
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/float.lisp,v 1.48 2010/04/20 17:57:44 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/float.lisp,v 1.49 2011/09/03 05:19:03 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -1257,40 +1257,45 @@
;;; represented by an integer.]
;;;
(defun %unary-round (number)
- (number-dispatch ((number real))
- ((integer) number)
- ((ratio) (values (round (numerator number) (denominator number))))
- (((foreach single-float double-float #+long-float long-float))
- (if (< (float most-negative-fixnum number)
- number
- (float most-positive-fixnum number))
- (truly-the fixnum (%unary-round number))
- (multiple-value-bind (bits exp)
- (integer-decode-float number)
+ (flet ((round-integer (bits exp sign)
(let* ((shifted (ash bits exp))
- (rounded (if (and (minusp exp)
- (oddp shifted)
- (not (zerop (logand bits
- (ash 1 (- -1 exp))))))
+ (roundup-p
+ ;; Round if the are fraction bits (exp is
+ ;; negative).
+ (when (minusp exp)
+ (let ((fraction (ldb (byte (- exp) 0) bits))
+ (half (ash 1 (- -1 exp))))
+ ;; If the fraction is less than half, then no
+ ;; rounding. Otherwise, round up if the
+ ;; fraction is greater than half or the
+ ;; integer part is odd (for round-to-even).
+ (cond ((> fraction half) t)
+ ((< fraction half) nil)
+ ((oddp shifted)
+ t)))))
+ (rounded (if roundup-p
(1+ shifted)
shifted)))
- (if (minusp number)
+
+ (if (minusp sign)
(- rounded)
- rounded)))))
- #+double-double
- ((double-double-float)
- (multiple-value-bind (bits exp)
- (integer-decode-float number)
- (let* ((shifted (ash bits exp))
- (rounded (if (and (minusp exp)
- (oddp shifted)
- (not (zerop (logand bits
- (ash 1 (- -1 exp))))))
- (1+ shifted)
- shifted)))
- (if (minusp number)
- (- rounded)
- rounded))))))
+ rounded))))
+ (number-dispatch ((number real))
+ ((integer) number)
+ ((ratio) (values (round (numerator number) (denominator number))))
+ (((foreach single-float double-float #+long-float long-float))
+ (if (< (float most-negative-fixnum number)
+ number
+ (float most-positive-fixnum number))
+ (truly-the fixnum (%unary-round number))
+ (multiple-value-bind (bits exp sign)
+ (integer-decode-float number)
+ (round-integer bits exp sign))))
+ #+double-double
+ ((double-double-float)
+ (multiple-value-bind (bits exp sign)
+ (integer-decode-float number)
+ (round-integer bits exp sign))))))
(declaim (maybe-inline %unary-ftruncate/single-float
%unary-ftruncate/double-float))
Index: src/general-info/release-20c.txt
diff -u src/general-info/release-20c.txt:1.31 src/general-info/release-20c.txt:1.32
--- src/general-info/release-20c.txt:1.31 Wed Aug 31 21:39:55 2011
+++ src/general-info/release-20c.txt Fri Sep 2 22:19:03 2011
@@ -141,6 +141,8 @@
- Make stack overflow checking actually work on Mac OS X. The
implementation had the :stack-checking feature, but it didn't
actually prevent stack overflows from crashing lisp.
+ - Fix rounding of numbers larger than a fixnum. (See Trac #10 for
+ a related issue.)
* Trac Tickets: