From 4e2622bf0d63c40f447d44e6401ea054ef55b261 Mon Sep 17 00:00:00 2001 From: Paul Eggert Date: Thu, 2 Mar 2017 09:11:11 -0800 Subject: [PATCH] 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 5b5baff44e1..17353936e7f 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 4414b077bb9..e781a87d16f 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 32ec89871a8..88d86697e42 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 2e4a6aa2e8a..d38760cdde6 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 -- 2.11.4.GIT