[cmucl-cvs] CMUCL commit: src (code/float.lisp general-info/release-20c.txt)

[Raymond Toy]

    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: