5:59 a.m.
This patch completes the work started by Martin some time ago.
Basically, it allows functions `<', `>', `<=', `>=', `='
and `/=' to
accept any number of arguments, while losing no speed for the
two-argument versions, and preserving full bytecode compatibility.
(< 1 2 3)
=> t
(< 1 2 2)
=> nil
(<= 1 2 2)
=> t
The compiler handles the functions specially by generating a constant
(t) for one-argument, the appropriate bytecode for two-argument
version, and a normal funcall for >2 arguments. Here are several
examples:
(disassemble (lambda () (< a b c)))
0 constant <
1 varref a
2 varref b
3 varref c
4 call 3
5 return
However:
(disassemble (lambda () (< a b)))
0 varref a
1 varref b
2 lss
3 return
Also:
(disassemble (lambda () (< a)))
0 constant t
1 return
I've taken care to preserve the special optimization for two-argument
version of /=, where (/= A B) is optimized as (not (= A B)).
(disassemble (lambda () (/= a b)))
0 varref a
1 varref b
2 eqlsign
3 not
4 return
This optimization does not hold with more than two arguments:
(disassemble (lambda () (/= a b c)))
0 constant /=
1 varref a
2 varref b
3 varref c
4 call 3
5 return
With this patch, the comparison functions are consistent with
arithmetic functions, such as +, -, * and others. I have given this
some test, and it runs fine. I think this will make a nice feature
for XEmacs 21.
C ChangeLog:
1998-05-01 Hrvoje Niksic <hniksic(a)srce.hr>
* fileio.c (Fcar_less_than_car): Fix Flss caller.
(Fcdr_less_than_cdr): Ditto.
* lisp.h: Fix declarations.
* data.c: Enable many arguments versions of <, >, <=, >= and /=.
* bytecode.c (Fbyte_code): Use arithcompare.
* data.c (arithcompare): Make non-static.
Lisp ChangeLog:
1998-05-01 Hrvoje Niksic <hniksic(a)srce.hr>
* byte-optimize.el: Don't attempt to optimize /=.
* bytecomp.el (byte-compile-one-ore-more-args): New function.
(byte-compile-/=): Ditto.
--- etc/NEWS.orig Fri May 1 06:44:50 1998
+++ etc/NEWS Fri May 1 06:54:21 1998
＠＠ -201,6 +201,14 ＠＠
- LDAP SDK 1.0 from Netscape Corp.
(http://developer.netscape.com)
+** The arithmetic comparison functions <, >, =, /= now accept 1 or
+more arguments.
+
+This means that if you want to test whether A < B < C, you can write
+it as (< A B C) instead of (and (< A B) (< B C)). Likewise,
+(apply #'> LIST) now tests if LIST is monotonously increasing -- and
+so on.
+
** The XEmacs hashtables now have a consistent read/print syntax.
This means that a hashtable will be readably printed in a
structure-like form:
--- src/fileio.c.orig Fri May 1 06:25:05 1998
+++ src/fileio.c Fri May 1 06:25:46 1998
＠＠ -3401,7 +3401,7 ＠＠
*/
(a, b))
{
- return Flss (Fcar (a), Fcar (b));
+ return arithcompare (Fcar (a), Fcar (b), arith_less);
}
/* Heh heh heh, let's define this too, just to aggravate the person who
＠＠ -3411,7 +3411,7 ＠＠
*/
(a, b))
{
- return Flss (Fcdr (a), Fcdr (b));
+ return arithcompare (Fcdr (a), Fcdr (b), arith_less);
}
/* Build the complete list of annotations appropriate for writing out
--- src/lisp.h.orig Fri May 1 05:50:40 1998
+++ src/lisp.h Fri May 1 06:19:02 1998
＠＠ -2004,6 +2004,16 ＠＠
Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object);
DECLARE_DOESNT_RETURN (dead_wrong_type_argument (Lisp_Object, Lisp_Object));
void check_int_range (int, int, int);
+
+enum arith_comparison {
+ arith_equal,
+ arith_notequal,
+ arith_less,
+ arith_grtr,
+ arith_less_or_equal,
+ arith_grtr_or_equal };
+Lisp_Object arithcompare (Lisp_Object, Lisp_Object, enum arith_comparison);
+
Lisp_Object word_to_lisp (unsigned int);
unsigned int lisp_to_word (Lisp_Object);
＠＠ -2557,7 +2567,7 ＠＠
EXFUN (Fforward_line, 2);
EXFUN (Ffset, 2);
EXFUN (Ffuncall, MANY);
-EXFUN (Fgeq, 2);
+EXFUN (Fgeq, MANY);
EXFUN (Fget, 3);
EXFUN (Fget_buffer_process, 1);
EXFUN (Fget_coding_system, 1);
＠＠ -2566,7 +2576,7 ＠＠
EXFUN (Fgethash, 3);
EXFUN (Fgettext, 1);
EXFUN (Fgoto_char, 2);
-EXFUN (Fgtr, 2);
+EXFUN (Fgtr, MANY);
EXFUN (Fhashtablep, 1);
EXFUN (Findent_to, 3);
EXFUN (Findirect_function, 1);
＠＠ -2583,10 +2593,10 ＠＠
EXFUN (Flax_plist_get, 3);
EXFUN (Flax_plist_remprop, 2);
EXFUN (Flength, 1);
-EXFUN (Fleq, 2);
+EXFUN (Fleq, MANY);
EXFUN (Flist, MANY);
EXFUN (Flistp, 1);
-EXFUN (Flss, 2);
+EXFUN (Flss, MANY);
EXFUN (Fmake_byte_code, MANY);
EXFUN (Fmake_coding_system, 4);
EXFUN (Fmake_glyph_internal, 1);
--- src/data.c.orig Fri May 1 05:45:25 1998
+++ src/data.c Fri May 1 06:18:07 1998
＠＠ -974,10 +974,9 ＠＠
/* 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)
{
CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num1);
CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num2);
＠＠ -990,152 +989,95 ＠＠
switch (comparison)
{
- case equal: return f1 == f2 ? Qt : Qnil;
- case notequal: return f1 != f2 ? Qt : Qnil;
- case less: return f1 < f2 ? Qt : Qnil;
- case less_or_equal: return f1 <= f2 ? Qt : Qnil;
- case grtr: return f1 > f2 ? Qt : Qnil;
- case grtr_or_equal: return f1 >= f2 ? Qt : Qnil;
+ case arith_equal: return f1 == f2 ? Qt : Qnil;
+ case arith_notequal: return f1 != f2 ? Qt : Qnil;
+ case arith_less: return f1 < f2 ? Qt : Qnil;
+ case arith_less_or_equal: return f1 <= f2 ? Qt : Qnil;
+ case arith_grtr: return f1 > f2 ? Qt : Qnil;
+ case arith_grtr_or_equal: return f1 >= f2 ? Qt : Qnil;
}
}
#endif /* LISP_FLOAT_TYPE */
switch (comparison)
{
- case equal: return XINT (num1) == XINT (num2) ? Qt : Qnil;
- case notequal: return XINT (num1) != XINT (num2) ? Qt : Qnil;
- case less: return XINT (num1) < XINT (num2) ? Qt : Qnil;
- case less_or_equal: return XINT (num1) <= XINT (num2) ? Qt : Qnil;
- case grtr: return XINT (num1) > XINT (num2) ? Qt : Qnil;
- case grtr_or_equal: return XINT (num1) >= XINT (num2) ? Qt : Qnil;
+ case arith_equal: return XINT (num1) == XINT (num2) ? Qt : Qnil;
+ case arith_notequal: return XINT (num1) != XINT (num2) ? Qt : Qnil;
+ case arith_less: return XINT (num1) < XINT (num2) ? Qt : Qnil;
+ case arith_less_or_equal: return XINT (num1) <= XINT (num2) ? Qt : Qnil;
+ case arith_grtr: return XINT (num1) > XINT (num2) ? Qt : Qnil;
+ case arith_grtr_or_equal: return XINT (num1) >= XINT (num2) ? Qt : Qnil;
}
abort ();
return Qnil; /* suppress compiler warning */
}
-DEFUN ("=", Feqlsign, 2, 2, 0, /*
-Return t if two args, both numbers, characters or markers, are equal.
-*/
- (num1, num2))
-{
- return arithcompare (num1, num2, equal);
-}
-
-DEFUN ("<", Flss, 2, 2, 0, /*
-Return t if first arg is less than second arg.
-Both must be numbers, characters or markers.
-*/
- (num1, num2))
-{
- return arithcompare (num1, num2, less);
-}
-
-DEFUN (">", Fgtr, 2, 2, 0, /*
-Return t if first arg is greater than second arg.
-Both must be numbers, characters or markers.
-*/
- (num1, num2))
-{
- return arithcompare (num1, num2, grtr);
-}
-
-DEFUN ("<=", Fleq, 2, 2, 0, /*
-Return t if first arg is less than or equal to second arg.
-Both must be numbers, characters or markers.
-*/
- (num1, num2))
-{
- return arithcompare (num1, num2, less_or_equal);
-}
-
-DEFUN (">=", Fgeq, 2, 2, 0, /*
-Return t if first arg is greater than or equal to second arg.
-Both must be numbers, characters or markers.
-*/
- (num1, num2))
-{
- return arithcompare (num1, num2, grtr_or_equal);
-}
-
-DEFUN ("/=", Fneq, 2, 2, 0, /*
-Return t if first arg is not equal to second arg.
-Both must be numbers, characters or markers.
-*/
- (num1, num2))
-{
- return arithcompare (num1, num2, notequal);
-}
-
-#if 0
-/* I tried implementing Common Lisp multi-arg comparison functions,
- but failed because the byte-compiler needs to be hacked as well. */
-
static Lisp_Object
-arithcompare_many (enum comparison comparison, int nargs, Lisp_Object *args)
+arithcompare_many (enum arith_comparison comparison,
+ int nargs, Lisp_Object *args)
{
REGISTER int argnum;
for (argnum = 1; argnum < nargs; argnum++)
- if (EQ (arithcompare ( args[argnum-1], args[argnum], comparison), Qnil))
+ if (EQ (arithcompare (args[argnum-1], args[argnum], comparison), Qnil))
return Qnil;
return Qt;
}
-xxxDEFUN ("=", Feqlsign, 1, MANY, 0, /*
+DEFUN ("=", Feqlsign, 1, MANY, 0, /*
Return t if all the arguments are equal.
The arguments may be numbers, characters or markers.
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare (equal, nargs, args);
+ return arithcompare_many (arith_equal, nargs, args);
}
-xxxDEFUN ("<", Flss, 1, MANY, 0, /*
+DEFUN ("<", Flss, 1, MANY, 0, /*
Return t if the sequence of arguments is monotonically increasing.
The arguments may be numbers, characters or markers.
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare (less, nargs, args);
+ return arithcompare_many (arith_less, nargs, args);
}
-xxxDEFUN (">", Fgtr, 1, MANY, 0, /*
+DEFUN (">", Fgtr, 1, MANY, 0, /*
Return t if the sequence of arguments is monotonically decreasing.
The arguments may be numbers, characters or markers.
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare (grtr, nargs, args);
+ return arithcompare_many (arith_grtr, nargs, args);
}
-xxxDEFUN ("<=", Fleq, 1, MANY, 0, /*
+DEFUN ("<=", Fleq, 1, MANY, 0, /*
Return t if the sequence of arguments is monotonically nondecreasing.
The arguments may be numbers, characters or markers.
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare (less_or_equal, nargs, args);
+ return arithcompare_many (arith_less_or_equal, nargs, args);
}
-xxxDEFUN (">=", Fgeq, 1, MANY, 0, /*
+DEFUN (">=", Fgeq, 1, MANY, 0, /*
Return t if the sequence of arguments is monotonically nonincreasing.
The arguments may be numbers, characters or markers.
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare_many (grtr_or_equal, nargs, args);
+ return arithcompare_many (arith_grtr_or_equal, nargs, args);
}
-xxxDEFUN ("/=", Fneq, 1, MANY, 0, /*
+DEFUN ("/=", Fneq, 1, MANY, 0, /*
Return t if the sequence of arguments is monotonically increasing.
The arguments may be numbers, characters or markers.
*/
(int nargs, Lisp_Object *args))
{
- return arithcompare_many (notequal, nargs, args);
+ return arithcompare_many (arith_notequal, nargs, args);
}
-#endif /* 0 - disabled for now */
DEFUN ("zerop", Fzerop, 1, 1, 0, /*
Return t if NUMBER is zero.
--- src/bytecode.c.orig Fri May 1 05:53:17 1998
+++ src/bytecode.c Fri May 1 05:56:06 1998
＠＠ -811,22 +811,22 ＠＠
case Bgtr:
v1 = POP;
- TOP = Fgtr (TOP, v1);
+ TOP = arithcompare (TOP, v1, arith_grtr);
break;
case Blss:
v1 = POP;
- TOP = Flss (TOP, v1);
+ TOP = arithcompare (TOP, v1, arith_less);
break;
case Bleq:
v1 = POP;
- TOP = Fleq (TOP, v1);
+ TOP = arithcompare (TOP, v1, arith_less_or_equal);
break;
case Bgeq:
v1 = POP;
- TOP = Fgeq (TOP, v1);
+ TOP = arithcompare (TOP, v1, arith_grtr_or_equal);
break;
case Bdiff:
--- lisp/bytecomp.el.orig Fri May 1 05:25:10 1998
+++ lisp/bytecomp.el Fri May 1 06:11:10 1998
＠＠ -2889,11 +2889,12 ＠＠
(byte-defop-compiler20 old-memq 2)
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
-(byte-defop-compiler (= byte-eqlsign) 2)
-(byte-defop-compiler (< byte-lss) 2)
-(byte-defop-compiler (> byte-gtr) 2)
-(byte-defop-compiler (<= byte-leq) 2)
-(byte-defop-compiler (>= byte-geq) 2)
+(byte-defop-compiler (= byte-eqlsign) byte-compile-one-or-more-args)
+(byte-defop-compiler (< byte-lss) byte-compile-one-or-more-args)
+(byte-defop-compiler (> byte-gtr) byte-compile-one-or-more-args)
+(byte-defop-compiler (<= byte-leq) byte-compile-one-or-more-args)
+(byte-defop-compiler (>= byte-geq) byte-compile-one-or-more-args)
+(byte-defop-compiler /= byte-compile-/=)
(byte-defop-compiler get 2+1)
(byte-defop-compiler nth 2)
(byte-defop-compiler substring 2-3)
＠＠ -3103,6 +3104,21 ＠＠
(byte-defop-compiler nconc)
(byte-defop-compiler-1 beginning-of-line)
+(defun byte-compile-one-or-more-args (form)
+ (let ((len (length form)))
+ (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more"))
+ ((= len 2) (byte-compile-constant t))
+ ((= len 3) (byte-compile-two-args form))
+ (t (byte-compile-normal-call form)))))
+
+(defun byte-compile-/= (form)
+ (let ((len (length form)))
+ (cond ((= len 1) (byte-compile-subr-wrong-args form "1 or more"))
+ ((= len 2) (byte-compile-constant t))
+ ;; optimize (/= X Y) to (not (= X Y))
+ ((= len 3) (byte-compile-form-do-effect `(not (= ,＠(cdr form)))))
+ (t (byte-compile-normal-call form)))))
+
(defun byte-compile-buffer-substring (form)
(let ((len (length form)))
;; buffer-substring used to take exactly two args, but now takes 0-3.
＠＠ -3539,18 +3555,18 ＠＠
(byte-compile-out 'byte-unbind (length (car (cdr form))))))
-(byte-defop-compiler-1 /= byte-compile-negated)
+;;(byte-defop-compiler-1 /= byte-compile-negated)
(byte-defop-compiler-1 atom byte-compile-negated)
(byte-defop-compiler-1 nlistp byte-compile-negated)
-(put '/= 'byte-compile-negated-op '=)
+;;(put '/= 'byte-compile-negated-op '=)
(put 'atom 'byte-compile-negated-op 'consp)
(put 'nlistp 'byte-compile-negated-op 'listp)
(defun byte-compile-negated (form)
(byte-compile-form-do-effect (byte-compile-negation-optimizer form)))
-;; Even when optimization is off, /= is optimized to (not (= ...)).
+;; Even when optimization is off, atom is optimized to (not (consp ...)).
(defun byte-compile-negation-optimizer (form)
;; an optimizer for forms where <form1> is less efficient than (not
<form2>)
(list 'not
--- lisp/byte-optimize.el.orig Fri May 1 06:08:11 1998
+++ lisp/byte-optimize.el Fri May 1 06:08:20 1998
＠＠ -1029,7 +1029,7 ＠＠
(put 'while 'byte-optimizer 'byte-optimize-while)
;; byte-compile-negation-optimizer lives in bytecomp.el
-(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
+;(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
--
Hrvoje Niksic <hniksic(a)srce.hr> | Student at FER Zagreb, Croatia
--------------------------------+--------------------------------
"Memory is like an orgasm. It's a lot better if you don't have to
fake it." -- Seymour Cray, on virtual memory