Commit ebb99847 authored by Barry O'Reilly's avatar Barry O'Reilly
Browse files

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
parent 1b3b87df
...@@ -625,6 +625,8 @@ actually using interpreter-mode-alist for something. ...@@ -625,6 +625,8 @@ actually using interpreter-mode-alist for something.
* Lisp Changes in Emacs 24.4 * Lisp Changes in Emacs 24.4
** Comparison functions =, <, >, <=, >= now take many arguments.
** The second argument of `eval' can now be a lexical-environment. ** The second argument of `eval' can now be a lexical-environment.
** `with-demoted-errors' takes an additional argument `format'. ** `with-demoted-errors' takes an additional argument `format'.
......
...@@ -1367,7 +1367,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ...@@ -1367,7 +1367,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
Lisp_Object v1; Lisp_Object v1;
BEFORE_POTENTIAL_GC (); BEFORE_POTENTIAL_GC ();
v1 = POP; v1 = POP;
TOP = Fgtr (TOP, v1); TOP = arithcompare (TOP, v1, ARITH_GRTR);
AFTER_POTENTIAL_GC (); AFTER_POTENTIAL_GC ();
NEXT; NEXT;
} }
...@@ -1377,7 +1377,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ...@@ -1377,7 +1377,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
Lisp_Object v1; Lisp_Object v1;
BEFORE_POTENTIAL_GC (); BEFORE_POTENTIAL_GC ();
v1 = POP; v1 = POP;
TOP = Flss (TOP, v1); TOP = arithcompare (TOP, v1, ARITH_LESS);
AFTER_POTENTIAL_GC (); AFTER_POTENTIAL_GC ();
NEXT; NEXT;
} }
...@@ -1387,7 +1387,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ...@@ -1387,7 +1387,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
Lisp_Object v1; Lisp_Object v1;
BEFORE_POTENTIAL_GC (); BEFORE_POTENTIAL_GC ();
v1 = POP; v1 = POP;
TOP = Fleq (TOP, v1); TOP = arithcompare (TOP, v1, ARITH_LESS_OR_EQUAL);
AFTER_POTENTIAL_GC (); AFTER_POTENTIAL_GC ();
NEXT; NEXT;
} }
...@@ -1397,7 +1397,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ...@@ -1397,7 +1397,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
Lisp_Object v1; Lisp_Object v1;
BEFORE_POTENTIAL_GC (); BEFORE_POTENTIAL_GC ();
v1 = POP; v1 = POP;
TOP = Fgeq (TOP, v1); TOP = arithcompare (TOP, v1, ARITH_GRTR_OR_EQUAL);
AFTER_POTENTIAL_GC (); AFTER_POTENTIAL_GC ();
NEXT; NEXT;
} }
......
...@@ -2255,10 +2255,8 @@ bool-vector. IDX starts at 0. */) ...@@ -2255,10 +2255,8 @@ bool-vector. IDX starts at 0. */)
/* Arithmetic functions */ /* Arithmetic functions */
enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal }; Lisp_Object
arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison)
static Lisp_Object
arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
{ {
double f1 = 0, f2 = 0; double f1 = 0, f2 = 0;
bool floatp = 0; bool floatp = 0;
...@@ -2275,32 +2273,32 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison) ...@@ -2275,32 +2273,32 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
switch (comparison) switch (comparison)
{ {
case equal: case ARITH_EQUAL:
if (floatp ? f1 == f2 : XINT (num1) == XINT (num2)) if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
return Qt; return Qt;
return Qnil; return Qnil;
case notequal: case ARITH_NOTEQUAL:
if (floatp ? f1 != f2 : XINT (num1) != XINT (num2)) if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
return Qt; return Qt;
return Qnil; return Qnil;
case less: case ARITH_LESS:
if (floatp ? f1 < f2 : XINT (num1) < XINT (num2)) if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
return Qt; return Qt;
return Qnil; return Qnil;
case less_or_equal: case ARITH_LESS_OR_EQUAL:
if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2)) if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
return Qt; return Qt;
return Qnil; return Qnil;
case grtr: case ARITH_GRTR:
if (floatp ? f1 > f2 : XINT (num1) > XINT (num2)) if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
return Qt; return Qt;
return Qnil; return Qnil;
case grtr_or_equal: case ARITH_GRTR_OR_EQUAL:
if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2)) if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
return Qt; return Qt;
return Qnil; return Qnil;
...@@ -2310,48 +2308,60 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison) ...@@ -2310,48 +2308,60 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
} }
} }
DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0, static Lisp_Object
doc: /* Return t if two args, both numbers or markers, are equal. */) arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
(register Lisp_Object num1, Lisp_Object num2) enum Arith_Comparison comparison)
{ {
return arithcompare (num1, num2, equal); for (ptrdiff_t argnum = 1; argnum < nargs; ++argnum)
{
if (EQ (Qnil, arithcompare (args[argnum-1], args[argnum], comparison)))
return Qnil;
}
return Qt;
} }
DEFUN ("<", Flss, Slss, 2, 2, 0, DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0,
doc: /* Return t if first arg is less than second arg. Both must be numbers or markers. */) doc: /* Return t if args, all numbers or markers, are equal. */)
(register Lisp_Object num1, Lisp_Object num2) (ptrdiff_t nargs, Lisp_Object *args)
{ {
return arithcompare (num1, num2, less); return arithcompare_driver (nargs, args, ARITH_EQUAL);
} }
DEFUN (">", Fgtr, Sgtr, 2, 2, 0, DEFUN ("<", Flss, Slss, 1, MANY, 0,
doc: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */) doc: /* Return t if each arg is less than the next arg. All must be numbers or markers. */)
(register Lisp_Object num1, Lisp_Object num2) (ptrdiff_t nargs, Lisp_Object *args)
{ {
return arithcompare (num1, num2, grtr); return arithcompare_driver (nargs, args, ARITH_LESS);
} }
DEFUN ("<=", Fleq, Sleq, 2, 2, 0, DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
doc: /* Return t if first arg is less than or equal to second arg. doc: /* Return t if each arg is greater than the next arg. All must be numbers or markers. */)
Both must be numbers or markers. */) (ptrdiff_t nargs, Lisp_Object *args)
(register Lisp_Object num1, Lisp_Object num2)
{ {
return arithcompare (num1, num2, less_or_equal); return arithcompare_driver (nargs, args, ARITH_GRTR);
} }
DEFUN (">=", Fgeq, Sgeq, 2, 2, 0, DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
doc: /* Return t if first arg is greater than or equal to second arg. doc: /* Return t if each arg is less than or equal to the next arg.
Both must be numbers or markers. */) All must be numbers or markers. */)
(register Lisp_Object num1, Lisp_Object num2) (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 (num1, num2, grtr_or_equal); return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
} }
DEFUN ("/=", Fneq, Sneq, 2, 2, 0, DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */) 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) (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, DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
......
...@@ -5121,7 +5121,8 @@ DEFUN ("car-less-than-car", Fcar_less_than_car, Scar_less_than_car, 2, 2, 0, ...@@ -5121,7 +5121,8 @@ DEFUN ("car-less-than-car", Fcar_less_than_car, Scar_less_than_car, 2, 2, 0,
doc: /* Return t if (car A) is numerically less than (car B). */) doc: /* Return t if (car A) is numerically less than (car B). */)
(Lisp_Object a, Lisp_Object 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 /* Build the complete list of annotations appropriate for writing out
......
...@@ -3160,6 +3160,16 @@ EXFUN (Fbyteorder, 0) ATTRIBUTE_CONST; ...@@ -3160,6 +3160,16 @@ EXFUN (Fbyteorder, 0) ATTRIBUTE_CONST;
/* Defined in data.c. */ /* Defined in data.c. */
extern Lisp_Object indirect_function (Lisp_Object); extern Lisp_Object indirect_function (Lisp_Object);
extern Lisp_Object find_symbol_value (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 /* 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. itself, or a cons of two or three integers, or if all else fails a float.
......
;;; 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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment