[Emacs-diffs] trunk r114200: Change comparison functions =, <, >, <=, >= to take many arguments.

[Barry O'Reilly]

------------------------------------------------------------
revno: 114200
revision-id: address@hidden
parent: address@hidden
committer: Barry O'Reilly <address@hidden>
branch nick: trunk
timestamp: Wed 2013-09-11 01:03:23 -0400
message:
  Change comparison functions =, <, >, <=, >= to take many arguments.
  * src/data.c: Change comparison functions' interface and
    implementation
  * src/lisp.h: Make arithcompare available for efficient two arg
    comparisons
  * src/bytecode.c: Use arithcompare
  * src/fileio.c: Use new interface
  * test/automated/data-tests.el: New tests for comparison functions
  * etc/NEWS
added:
  test/automated/data-tests.el   datatests.el-20130911041418-ha1keli7tcoxl2ij-1
modified:
  etc/NEWS                       news-20100311060928-aoit31wvzf25yr1z-1
  src/bytecode.c                 bytecode.c-20091113204419-o5vbwnq5f7feedwu-257
  src/data.c                     data.c-20091113204419-o5vbwnq5f7feedwu-251
  src/fileio.c                   fileio.c-20091113204419-o5vbwnq5f7feedwu-210
  src/lisp.h                     lisp.h-20091113204419-o5vbwnq5f7feedwu-253

=== modified file 'etc/NEWS'
--- a/etc/NEWS  2013-09-10 20:38:52 +0000
+++ b/etc/NEWS  2013-09-11 05:03:23 +0000
@@ -625,6 +625,8 @@
 
 * Lisp Changes in Emacs 24.4
 
+** Comparison functions =, <, >, <=, >= now take many arguments.
+
 ** The second argument of `eval' can now be a lexical-environment.
 
 ** `with-demoted-errors' takes an additional argument `format'.

=== modified file 'src/bytecode.c'
--- a/src/bytecode.c    2013-07-16 21:35:45 +0000
+++ b/src/bytecode.c    2013-09-11 05:03:23 +0000
@@ -1367,7 +1367,7 @@
            Lisp_Object v1;
            BEFORE_POTENTIAL_GC ();
            v1 = POP;
-           TOP = Fgtr (TOP, v1);
+           TOP = arithcompare (TOP, v1, ARITH_GRTR);
            AFTER_POTENTIAL_GC ();
            NEXT;
          }
@@ -1377,7 +1377,7 @@
            Lisp_Object v1;
            BEFORE_POTENTIAL_GC ();
            v1 = POP;
-           TOP = Flss (TOP, v1);
+           TOP = arithcompare (TOP, v1, ARITH_LESS);
            AFTER_POTENTIAL_GC ();
            NEXT;
          }
@@ -1387,7 +1387,7 @@
            Lisp_Object v1;
            BEFORE_POTENTIAL_GC ();
            v1 = POP;
-           TOP = Fleq (TOP, v1);
+           TOP = arithcompare (TOP, v1, ARITH_LESS_OR_EQUAL);
            AFTER_POTENTIAL_GC ();
            NEXT;
          }
@@ -1397,7 +1397,7 @@
            Lisp_Object v1;
            BEFORE_POTENTIAL_GC ();
            v1 = POP;
-           TOP = Fgeq (TOP, v1);
+           TOP = arithcompare (TOP, v1, ARITH_GRTR_OR_EQUAL);
            AFTER_POTENTIAL_GC ();
            NEXT;
          }

=== modified file 'src/data.c'
--- a/src/data.c        2013-08-07 13:21:59 +0000
+++ b/src/data.c        2013-09-11 05:03:23 +0000
@@ -2255,10 +2255,8 @@
 
 /* Arithmetic functions */
 
-enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
-
-static Lisp_Object
-arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
+Lisp_Object
+arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison 
comparison)
 {
   double f1 = 0, f2 = 0;
   bool floatp = 0;
@@ -2275,32 +2273,32 @@
 
   switch (comparison)
     {
-    case equal:
+    case ARITH_EQUAL:
       if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
        return Qt;
       return Qnil;
 
-    case notequal:
+    case ARITH_NOTEQUAL:
       if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
        return Qt;
       return Qnil;
 
-    case less:
+    case ARITH_LESS:
       if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
        return Qt;
       return Qnil;
 
-    case less_or_equal:
+    case ARITH_LESS_OR_EQUAL:
       if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
        return Qt;
       return Qnil;
 
-    case grtr:
+    case ARITH_GRTR:
       if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
        return Qt;
       return Qnil;
 
-    case grtr_or_equal:
+    case ARITH_GRTR_OR_EQUAL:
       if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
        return Qt;
       return Qnil;
@@ -2310,48 +2308,60 @@
     }
 }
 
-DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
-       doc: /* Return t if two args, both numbers or markers, are equal.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
-{
-  return arithcompare (num1, num2, equal);
-}
-
-DEFUN ("<", Flss, Slss, 2, 2, 0,
-       doc: /* Return t if first arg is less than second arg.  Both must be 
numbers or markers.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
-{
-  return arithcompare (num1, num2, less);
-}
-
-DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
-       doc: /* Return t if first arg is greater than second arg.  Both must be 
numbers or markers.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
-{
-  return arithcompare (num1, num2, grtr);
-}
-
-DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
-       doc: /* Return t if first arg is less than or equal to second arg.
-Both must be numbers or markers.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
-{
-  return arithcompare (num1, num2, less_or_equal);
-}
-
-DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
-       doc: /* Return t if first arg is greater than or equal to second arg.
-Both must be numbers or markers.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
-{
-  return arithcompare (num1, num2, grtr_or_equal);
+static Lisp_Object
+arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
+                     enum Arith_Comparison comparison)
+{
+  for (ptrdiff_t argnum = 1; argnum < nargs; ++argnum)
+    {
+      if (EQ (Qnil, arithcompare (args[argnum-1], args[argnum], comparison)))
+        return Qnil;
+    }
+  return Qt;
+}
+
+DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0,
+       doc: /* Return t if args, all numbers or markers, are equal.  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  return arithcompare_driver (nargs, args, ARITH_EQUAL);
+}
+
+DEFUN ("<", Flss, Slss, 1, MANY, 0,
+       doc: /* Return t if each arg is less than the next arg.  All must be 
numbers or markers.  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  return arithcompare_driver (nargs, args, ARITH_LESS);
+}
+
+DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
+       doc: /* Return t if each arg is greater than the next arg.  All must be 
numbers or markers.  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  return arithcompare_driver (nargs, args, ARITH_GRTR);
+}
+
+DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
+       doc: /* Return t if each arg is less than or equal to the next arg.
+All must be numbers or markers.  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL);
+}
+
+DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
+       doc: /* Return t if each arg is greater than or equal to the next arg.
+All must be numbers or markers.  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
 }
 
 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
        doc: /* Return t if first arg is not equal to second arg.  Both must be 
numbers or markers.  */)
   (register Lisp_Object num1, Lisp_Object num2)
 {
-  return arithcompare (num1, num2, notequal);
+  return arithcompare (num1, num2, ARITH_NOTEQUAL);
 }
 
 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,

=== modified file 'src/fileio.c'
--- a/src/fileio.c      2013-09-03 14:40:09 +0000
+++ b/src/fileio.c      2013-09-11 05:03:23 +0000
@@ -5121,7 +5121,8 @@
        doc: /* Return t if (car A) is numerically less than (car B).  */)
   (Lisp_Object a, Lisp_Object b)
 {
-  return Flss (Fcar (a), Fcar (b));
+  Lisp_Object args[2] = { Fcar (a), Fcar (b), };
+  return Flss (2, args);
 }
 
 /* Build the complete list of annotations appropriate for writing out

=== modified file 'src/lisp.h'
--- a/src/lisp.h        2013-09-06 16:40:12 +0000
+++ b/src/lisp.h        2013-09-11 05:03:23 +0000
@@ -3160,6 +3160,16 @@
 /* Defined in data.c.  */
 extern Lisp_Object indirect_function (Lisp_Object);
 extern Lisp_Object find_symbol_value (Lisp_Object);
+enum Arith_Comparison {
+  ARITH_EQUAL,
+  ARITH_NOTEQUAL,
+  ARITH_LESS,
+  ARITH_GRTR,
+  ARITH_LESS_OR_EQUAL,
+  ARITH_GRTR_OR_EQUAL
+};
+extern Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2,
+                                 enum Arith_Comparison comparison);
 
 /* Convert the integer I to an Emacs representation, either the integer
    itself, or a cons of two or three integers, or if all else fails a float.

=== added file 'test/automated/data-tests.el'
--- a/test/automated/data-tests.el      1970-01-01 00:00:00 +0000
+++ b/test/automated/data-tests.el      2013-09-11 05:03:23 +0000
@@ -0,0 +1,75 @@
+;;; data-tests.el --- tests for src/data.c
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see `http://www.gnu.org/licenses/'.
+
+;;; Commentary:
+
+;;; Code:
+
+(ert-deftest data-tests-= ()
+  (should-error (=))
+  (should (= 1))
+  (should (= 2 2))
+  (should (= 9 9 9 9 9 9 9 9 9))
+  (should-not (apply #'= '(3 8 3)))
+  (should-error (= 9 9 'foo))
+  ;; Short circuits before getting to bad arg
+  (should-not (= 9 8 'foo)))
+
+(ert-deftest data-tests-< ()
+  (should-error (<))
+  (should (< 1))
+  (should (< 2 3))
+  (should (< -6 -1 0 2 3 4 8 9 999))
+  (should-not (apply #'< '(3 8 3)))
+  (should-error (< 9 10 'foo))
+  ;; Short circuits before getting to bad arg
+  (should-not (< 9 8 'foo)))
+
+(ert-deftest data-tests-> ()
+  (should-error (>))
+  (should (> 1))
+  (should (> 3 2))
+  (should (> 6 1 0 -2 -3 -4 -8 -9 -999))
+  (should-not (apply #'> '(3 8 3)))
+  (should-error (> 9 8 'foo))
+  ;; Short circuits before getting to bad arg
+  (should-not (> 8 9 'foo)))
+
+(ert-deftest data-tests-<= ()
+  (should-error (<=))
+  (should (<= 1))
+  (should (<= 2 3))
+  (should (<= -6 -1 -1 0 0 0 2 3 4 8 999))
+  (should-not (apply #'<= '(3 8 3 3)))
+  (should-error (<= 9 10 'foo))
+  ;; Short circuits before getting to bad arg
+  (should-not (<= 9 8 'foo)))
+
+(ert-deftest data-tests->= ()
+  (should-error (>=))
+  (should (>= 1))
+  (should (>= 3 2))
+  (should (>= 666 1 0 0 -2 -3 -3 -3 -4 -8 -8 -9 -999))
+  (should-not (apply #'>= '(3 8 3)))
+  (should-error (>= 9 8 'foo))
+  ;; Short circuits before getting to bad arg
+  (should-not (>= 8 9 'foo)))
+
+;;; data-tests.el ends here
+