[Emacs-diffs] master 4e2622b: Fix rounding errors in <, =, etc.

[Paul Eggert]

branch: master
commit 4e2622bf0d63c40f447d44e6401ea054ef55b261
Author: Paul Eggert <address@hidden>
Commit: Paul Eggert <address@hidden>

    Fix rounding errors in <, =, etc.
    
    * etc/NEWS: Document this.
    * src/bytecode.c (exec_byte_code):
    * src/data.c (arithcompare):
    Do not lose information when comparing floats to integers.
    * test/src/data-tests.el (data-tests-=, data-tests-<)
    (data-tests->, data-tests-<=, data-tests->=):
    Test this.
---
 etc/NEWS               |  5 +++
 src/bytecode.c         | 14 +++-----
 src/data.c             | 86 +++++++++++++++++++++++++++++++-------------------
 test/src/data-tests.el |  6 ++++
 4 files changed, 70 insertions(+), 41 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 5b5baff..1735393 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -902,6 +902,11 @@ interpreting consecutive runs of numerical characters as 
numbers, and
 compares their numerical values.  According to this predicate,
 "foo2.png" is smaller than "foo12.png".
 
+---
+** Numeric comparisons no longer return incorrect answers due to
+internal rounding errors.  For example, (< most-positive-fixnum (+ 1.0
+most-positive-fixnum)) now correctly returns t on 64-bit hosts.
+
 +++
 ** The new function 'char-from-name' converts a Unicode name string
 to the corresponding character code.
diff --git a/src/bytecode.c b/src/bytecode.c
index 4414b07..e781a87 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -992,18 +992,14 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, 
Lisp_Object maxdepth,
        CASE (Beqlsign):
          {
            Lisp_Object v2 = POP, v1 = TOP;
-           CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
-           CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
-           bool equal;
            if (FLOATP (v1) || FLOATP (v2))
+             TOP = arithcompare (v1, v2, ARITH_EQUAL);
+           else
              {
-               double f1 = FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1);
-               double f2 = FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2);
-               equal = f1 == f2;
+               CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1);
+               CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2);
+               TOP = EQ (v1, v2) ? Qt : Qnil;
              }
-           else
-             equal = XINT (v1) == XINT (v2);
-           TOP = equal ? Qt : Qnil;
            NEXT;
          }
 
diff --git a/src/data.c b/src/data.c
index 32ec898..88d8669 100644
--- a/src/data.c
+++ b/src/data.c
@@ -2392,68 +2392,90 @@ bool-vector.  IDX starts at 0.  */)
 /* Arithmetic functions */
 
 Lisp_Object
-arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison 
comparison)
+arithcompare (Lisp_Object num1, Lisp_Object num2,
+             enum Arith_Comparison comparison)
 {
-  double f1 = 0, f2 = 0;
-  bool floatp = 0;
+  double f1, f2;
+  EMACS_INT i1, i2;
+  bool fneq;
+  bool test;
 
   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
   CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
 
-  if (FLOATP (num1) || FLOATP (num2))
+  /* If either arg is floating point, set F1 and F2 to the 'double'
+     approximations of the two arguments.  Regardless, set I1 and I2
+     to integers that break ties if the floating point comparison is
+     either not done or reports equality.  */
+
+  if (FLOATP (num1))
+    {
+      f1 = XFLOAT_DATA (num1);
+      if (FLOATP (num2))
+       {
+         i1 = i2 = 0;
+         f2 = XFLOAT_DATA (num2);
+       }
+      else
+       i1 = f2 = i2 = XINT (num2);
+      fneq = f1 != f2;
+    }
+  else
     {
-      floatp = 1;
-      f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
-      f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
+      i1 = XINT (num1);
+      if (FLOATP (num2))
+       {
+         i2 = f1 = i1;
+         f2 = XFLOAT_DATA (num2);
+         fneq = f1 != f2;
+       }
+      else
+       {
+         i2 = XINT (num2);
+         fneq = false;
+       }
     }
 
   switch (comparison)
     {
     case ARITH_EQUAL:
-      if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
-       return Qt;
-      return Qnil;
+      test = !fneq && i1 == i2;
+      break;
 
     case ARITH_NOTEQUAL:
-      if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
-       return Qt;
-      return Qnil;
+      test = fneq || i1 != i2;
+      break;
 
     case ARITH_LESS:
-      if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
-       return Qt;
-      return Qnil;
+      test = fneq ? f1 < f2 : i1 < i2;
+      break;
 
     case ARITH_LESS_OR_EQUAL:
-      if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
-       return Qt;
-      return Qnil;
+      test = fneq ? f1 <= f2 : i1 <= i2;
+      break;
 
     case ARITH_GRTR:
-      if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
-       return Qt;
-      return Qnil;
+      test = fneq ? f1 > f2 : i1 > i2;
+      break;
 
     case ARITH_GRTR_OR_EQUAL:
-      if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
-       return Qt;
-      return Qnil;
+      test = fneq ? f1 >= f2 : i1 >= i2;
+      break;
 
     default:
-      emacs_abort ();
+      eassume (false);
     }
+
+  return test ? Qt : Qnil;
 }
 
 static Lisp_Object
 arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
                      enum Arith_Comparison comparison)
 {
-  ptrdiff_t argnum;
-  for (argnum = 1; argnum < nargs; ++argnum)
-    {
-      if (EQ (Qnil, arithcompare (args[argnum - 1], args[argnum], comparison)))
-        return Qnil;
-    }
+  for (ptrdiff_t i = 1; i < nargs; i++)
+    if (NILP (arithcompare (args[i - 1], args[i], comparison)))
+      return Qnil;
   return Qt;
 }
 
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 2e4a6aa..d38760c 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -29,6 +29,8 @@
   (should (= 1))
   (should (= 2 2))
   (should (= 9 9 9 9 9 9 9 9 9))
+  (should (= most-negative-fixnum (float most-negative-fixnum)))
+  (should-not (= most-positive-fixnum (+ 1.0 most-positive-fixnum)))
   (should-not (apply #'= '(3 8 3)))
   (should-error (= 9 9 'foo))
   ;; Short circuits before getting to bad arg
@@ -39,6 +41,7 @@
   (should (< 1))
   (should (< 2 3))
   (should (< -6 -1 0 2 3 4 8 9 999))
+  (should (< 0.5 most-positive-fixnum (+ 1.0 most-positive-fixnum)))
   (should-not (apply #'< '(3 8 3)))
   (should-error (< 9 10 'foo))
   ;; Short circuits before getting to bad arg
@@ -49,6 +52,7 @@
   (should (> 1))
   (should (> 3 2))
   (should (> 6 1 0 -2 -3 -4 -8 -9 -999))
+  (should (> (+ 1.0 most-positive-fixnum) most-positive-fixnum 0.5))
   (should-not (apply #'> '(3 8 3)))
   (should-error (> 9 8 'foo))
   ;; Short circuits before getting to bad arg
@@ -59,6 +63,7 @@
   (should (<= 1))
   (should (<= 2 3))
   (should (<= -6 -1 -1 0 0 0 2 3 4 8 999))
+  (should (<= 0.5 most-positive-fixnum (+ 1.0 most-positive-fixnum)))
   (should-not (apply #'<= '(3 8 3 3)))
   (should-error (<= 9 10 'foo))
   ;; Short circuits before getting to bad arg
@@ -69,6 +74,7 @@
   (should (>= 1))
   (should (>= 3 2))
   (should (>= 666 1 0 0 -2 -3 -3 -3 -4 -8 -8 -9 -999))
+  (should (>= (+ 1.0 most-positive-fixnum) most-positive-fixnum))
   (should-not (apply #'>= '(3 8 3)))
   (should-error (>= 9 8 'foo))
   ;; Short circuits before getting to bad arg