[Emacs-diffs] master 0b36041: Round bignums consistently with other integers

[Paul Eggert]

branch: master
commit 0b36041d2a528419982a19940573783ff318c0d4
Author: Paul Eggert <address@hidden>
Commit: Paul Eggert <address@hidden>

    Round bignums consistently with other integers
    
    * src/bignum.c (mpz_bufsize): New function.
    (bignum_bufsize): Use it.
    (mpz_get_d_rounded): New function.
    (bignum_to_double): Use it.
    * src/bignum.c (bignum_to_double):
    * src/data.c (bignum_arith_driver):
    When converting bignums to double, round instead of
    truncating, to be consistent with what happens with fixnums.
    * test/src/floatfns-tests.el (bignum-to-float): Test rounding.
---
 src/bignum.c               | 34 +++++++++++++++++++++++++++++++---
 src/bignum.h               |  1 +
 src/data.c                 |  2 +-
 test/src/floatfns-tests.el |  6 ++++++
 4 files changed, 39 insertions(+), 4 deletions(-)

diff --git a/src/bignum.c b/src/bignum.c
index 5e86c40..1e78d98 100644
--- a/src/bignum.c
+++ b/src/bignum.c
@@ -62,7 +62,7 @@ init_bignum (void)
 double
 bignum_to_double (Lisp_Object n)
 {
-  return mpz_get_d (XBIGNUM (n)->value);
+  return mpz_get_d_rounded (XBIGNUM (n)->value);
 }
 
 /* Return D, converted to a Lisp integer.  Discard any fraction.
@@ -251,12 +251,40 @@ bignum_to_uintmax (Lisp_Object x)
 }
 
 /* Yield an upper bound on the buffer size needed to contain a C
-   string representing the bignum NUM in base BASE.  This includes any
+   string representing the NUM in base BASE.  This includes any
    preceding '-' and the terminating null.  */
+static ptrdiff_t
+mpz_bufsize (mpz_t const num, int base)
+{
+  return mpz_sizeinbase (num, base) + 2;
+}
 ptrdiff_t
 bignum_bufsize (Lisp_Object num, int base)
 {
-  return mpz_sizeinbase (XBIGNUM (num)->value, base) + 2;
+  return mpz_bufsize (XBIGNUM (num)->value, base);
+}
+
+/* Convert NUM to a nearest double, as opposed to mpz_get_d which
+   truncates toward zero.  */
+double
+mpz_get_d_rounded (mpz_t const num)
+{
+  ptrdiff_t size = mpz_bufsize (num, 10);
+
+  /* Use mpz_get_d as a shortcut for a bignum so small that rounding
+     errors cannot occur, which is possible if EMACS_INT (not counting
+     sign) has fewer bits than a double significand.  */
+  if (! ((FLT_RADIX == 2 && DBL_MANT_DIG <= FIXNUM_BITS - 1)
+        || (FLT_RADIX == 16 && DBL_MANT_DIG * 4 <= FIXNUM_BITS - 1))
+      && size <= DBL_DIG + 2)
+    return mpz_get_d (num);
+
+  USE_SAFE_ALLOCA;
+  char *buf = SAFE_ALLOCA (size);
+  mpz_get_str (buf, 10, num);
+  double result = strtod (buf, NULL);
+  SAFE_FREE ();
+  return result;
 }
 
 /* Store into BUF (of size SIZE) the value of NUM as a base-BASE string.
diff --git a/src/bignum.h b/src/bignum.h
index 6551549..e9cd5c0 100644
--- a/src/bignum.h
+++ b/src/bignum.h
@@ -46,6 +46,7 @@ extern mpz_t mpz[4];
 extern void init_bignum (void);
 extern Lisp_Object make_integer_mpz (void);
 extern void mpz_set_intmax_slow (mpz_t, intmax_t) ARG_NONNULL ((1));
+extern double mpz_get_d_rounded (mpz_t const);
 
 INLINE_HEADER_BEGIN
 
diff --git a/src/data.c b/src/data.c
index cc08037..750d494 100644
--- a/src/data.c
+++ b/src/data.c
@@ -2921,7 +2921,7 @@ bignum_arith_driver (enum arithop code, ptrdiff_t nargs, 
Lisp_Object *args,
       CHECK_NUMBER_COERCE_MARKER (val);
       if (FLOATP (val))
        return float_arith_driver (code, nargs, args, argnum,
-                                  mpz_get_d (*accum), val);
+                                  mpz_get_d_rounded (*accum), val);
     }
 }
 
diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el
index 14576b6..61b1c25 100644
--- a/test/src/floatfns-tests.el
+++ b/test/src/floatfns-tests.el
@@ -35,6 +35,12 @@
   (should-error (fround 0) :type 'wrong-type-argument))
 
 (ert-deftest bignum-to-float ()
+  ;; 122 because we want to go as big as possible to provoke a rounding error,
+  ;; but not too big: 2**122 < 10**37 < 2**123, and the C standard says
+  ;; 10**37 <= DBL_MAX so 2**122 cannot overflow as a double.
+  (let ((a (1- (ash 1 122))))
+    (should (or (eql a (1- (floor (float a))))
+                (eql a (floor (float a))))))
   (should (eql (float (+ most-positive-fixnum 1))
                (+ (float most-positive-fixnum) 1))))