Commit 5bee53ac authored by rtoy's avatar rtoy
Browse files

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
parent 3def6682

code/float.lisp

+36 −31
Original line number Diff line number Diff line
@@ -5,7 +5,7 @@ 
;;; Carnegie Mellon University, and has been placed in the public domain.

;;;

(ext:file-comment

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.48 2010/04/20 17:57:44 rtoy Rel $")

  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.49 2011/09/03 05:19:03 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -1257,6 +1257,29 @@ rounding modes & do ieee round-to-integer. 
;;; represented by an integer.]

;;;

(defun %unary-round (number)

  (flet ((round-integer (bits exp sign)

	   (let* ((shifted (ash bits 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 sign)

		 (- rounded)

		 rounded))))

    (number-dispatch ((number real))

      ((integer) number)

      ((ratio) (values (round (numerator number) (denominator number))))
@@ -1265,32 +1288,14 @@ rounding modes & do ieee round-to-integer. 
	      number

	      (float most-positive-fixnum number))

	   (truly-the fixnum (%unary-round number))

	 (multiple-value-bind (bits exp)

	   (multiple-value-bind (bits exp sign)

	       (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)))))

	     (round-integer bits exp sign))))

      #+double-double

      ((double-double-float)

     (multiple-value-bind (bits exp)

       (multiple-value-bind (bits exp sign)

	   (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))))))

	 (round-integer bits exp sign))))))



(declaim (maybe-inline %unary-ftruncate/single-float

		       %unary-ftruncate/double-float))

general-info/release-20c.txt

+2 −0
Original line number Diff line number Diff line
@@ -141,6 +141,8 @@ New in this release: 
    - 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: