From e8359a9d0b5b8722858295681a1eaa004e37ff67 Mon Sep 17 00:00:00 2001 From: Graham Dobbins Date: Sun, 5 Mar 2017 20:52:24 -0500 Subject: [PATCH] Add new lisp function length= with bytecode support * src/fns.c (Flength_eqlsign, length_eqlsign2): Define length= and length_eqlsign2 for use in the bytecode interpreter. * src/lisp.h: Export length_eqlsign2. * src/bytecode.c (exec_byte_code): Modify bytecode interpreter to handle length= by overloading the = bytecode. * lisp/emacs-lisp/bytecomp.el: Change bytecompiler to handle length= and alter how = is handled to accomodate it. Change byte-compile-delete-errors to default to t. Add new 'unused option to byte-compile-warning-types. * lisp/emacs-lisp/byte-opt.el: Use new unused option for deleting unused forms. * test/src/fns-tests.el: * test/lisp/emacs-lisp/bytecomp-tests.el: Add tests for new functionality. * doc/lispref/sequences.texi: Document length=. --- doc/lispref/sequences.texi | 28 ++++++ etc/NEWS | 8 ++ lisp/emacs-lisp/byte-opt.el | 4 +- lisp/emacs-lisp/bytecomp.el | 49 +++++++++- src/bytecode.c | 17 ++-- src/fns.c | 163 +++++++++++++++++++++++++++++++++ src/lisp.h | 1 + test/lisp/emacs-lisp/bytecomp-tests.el | 20 ++++ test/src/fns-tests.el | 34 +++++++ 9 files changed, 312 insertions(+), 12 deletions(-) diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index 2c88ee38cb..4740a35766 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -113,6 +113,34 @@ Sequence Functions since @code{length} only counts the number of characters, but does not account for the display width of each character. +@defun length= &rest sequences +This function takes any number of sequences or integers. The length of +each sequence is computed in the same manner as @code{length}. If +these lengths and any provided numbers are all equal this function +returns t, otherwise it returns nil. In addition to convenience, this +function is more efficient than computing the @code{length} and +comparing with @code{=} when one or more of the sequences is a list. + +@example +@group +(length= '(1 2) '(3 4)) + @result{} t +@end group +@group +(length= 3 '(1 2 3)) + @result{} t +@end group +@group +(length= 2 '(1 2 3)) + @result{} nil +@end group +@group +(length= '(1 2 3) "foo" [1 2 3]) + @result{} t +@end group +@end example +@end defun + @defun elt sequence index @anchor{Definition of elt} @cindex elements of sequences diff --git a/etc/NEWS b/etc/NEWS index 8f7356f3e0..04533f1317 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -325,6 +325,10 @@ always restricting the margin to a quarter of the window. ** Emacsclient has a new option -u/--suppress-output. The option suppresses display of return values from the server process. +** 'byte-compile-warnings' has a new element 'unused' + +** 'byte-compile-delete-errors' now defaults to t + * Editing Changes in Emacs 26.1 @@ -997,6 +1001,10 @@ that does not exist. operating recursively and when some other process deletes the directory or its files before 'delete-directory' gets to them. ++++ +** The new function 'length=' compares the lengths of sequences with +integers. + ** Changes in Frame- and Window- Handling +++ diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 004f2e2865..5ec1a2c6d2 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -545,7 +545,7 @@ byte-optimize-form-code-walker form) ((and for-effect (setq tmp (get fn 'side-effect-free)) - (or byte-compile-delete-errors + (or (not (byte-compile-warning-enabled-p 'unused)) (eq tmp 'error-free) (progn (byte-compile-warn "value returned from %s is unused" @@ -1199,7 +1199,7 @@ byte-optimize-set hash-table-count int-to-string intern-soft keymap-parent - length local-variable-if-set-p local-variable-p log log10 logand + length length= local-variable-if-set-p local-variable-p log log10 logand logb logior lognot logxor lsh langinfo make-list make-string make-symbol marker-buffer max member memq min minibuffer-selected-window minibuffer-window diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 25513bd024..ab611fb458 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -217,7 +217,7 @@ byte-optimize (const :tag "source-level" source) (const :tag "byte-level" byte))) -(defcustom byte-compile-delete-errors nil +(defcustom byte-compile-delete-errors t "If non-nil, the optimizer may delete forms that may signal an error. This includes variable references and calls to functions such as `car'." :group 'bytecomp @@ -286,8 +286,9 @@ byte-compile-error-on-warn (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved - obsolete noruntime cl-functions interactive-only - make-local mapcar constants suspicious lexical) + obsolete noruntime cl-functions interactive-only + make-local mapcar constants suspicious lexical + unused) "The list of warning types used when `byte-compile-warnings' is t.") (defcustom byte-compile-warnings t "List of warnings that the byte-compiler should issue (t for all). @@ -311,6 +312,8 @@ byte-compile-warnings mapcar mapcar called for effect. constants let-binding of, or assignment to, constants/nonvariables. suspicious constructs that usually don't do what the coder wanted. + unused forms are present where the return value is unused + and they have no side effects. If the list begins with `not', then the remaining elements specify warnings to suppress. For example, (not mapcar) will suppress warnings about mapcar." @@ -3442,7 +3445,6 @@ byte-defop-compiler-1 (byte-defop-compiler cons 2) (byte-defop-compiler aref 2) (byte-defop-compiler set 2) -(byte-defop-compiler (= byte-eqlsign) 2-and) (byte-defop-compiler (< byte-lss) 2-and) (byte-defop-compiler (> byte-gtr) 2-and) (byte-defop-compiler (<= byte-leq) 2-and) @@ -3658,6 +3660,8 @@ byte-compile-associative (byte-defop-compiler-1 - byte-compile-minus) (byte-defop-compiler (/ byte-quo) byte-compile-quo) (byte-defop-compiler nconc) +(byte-defop-compiler (= byte-eqlsign)) +(byte-defop-compiler (length= byte-eqlsign)) ;; Is this worth it? Both -before and -after are written in C. (defun byte-compile-char-before (form) @@ -3822,6 +3826,25 @@ byte-compile-insert (if (cdr form) (byte-compile-discard)))))) +(defun byte-compile-length= (form) + (if (and + byte-compile-delete-errors + (length= 3 form)) + (progn + (when (numberp (caddr form)) + (cl-rotatef (cadr form) (caddr form))) + (byte-compile-two-args form)) + (byte-compile-normal-call form))) + +(defun byte-compile-= (form) + ;; Add an unused addition prior to checking for equality in order to + ;; ensure correct types since the bytecode interpreter handles = as + ;; length=. + (byte-compile-and-folded + (if byte-compile-delete-errors + form + (cons (car form) (mapcar (lambda (x) `(+ ,x 0)) (cdr form)))))) + (byte-defop-compiler-1 setq) (byte-defop-compiler-1 setq-default) @@ -5051,6 +5074,24 @@ batch-byte-recompile-directory (eval form) form))) +(put '= 'compiler-macro + (lambda (form &rest args) + (if (and byte-compile-delete-errors + (length= 2 args)) + (let ((len1 (eq 'length (car-safe (car args)))) + (len2 (eq 'length (car-safe (cadr args))))) + (cond + ((and len1 len2) + `(length= ,(cadar args) ,(cadadr args))) + (len1 + (let ((sym (cl-gensym))) + `(let ((,sym ,(cadar args))) + (length= ,(cadr args) ,sym)))) + (len2 + `(length= ,(car args) ,(cadadr args))) + (t form))) + form))) + (provide 'byte-compile) (provide 'bytecomp) diff --git a/src/bytecode.c b/src/bytecode.c index e781a87d16..eaad24576f 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -992,14 +992,19 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CASE (Beqlsign): { Lisp_Object v2 = POP, v1 = TOP; + /* The = byte code has been overloaded to handle length= as well */ if (FLOATP (v1) || FLOATP (v2)) - TOP = arithcompare (v1, v2, ARITH_EQUAL); - else - { - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v1); - CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (v2); - TOP = EQ (v1, v2) ? Qt : Qnil; + { + /* The compiler macro for = makes sure the sequence + will be in POP. Since length= doesn't accept + floats, only POP can be a non-number. Since this + should be a rare case, just compute the length. */ + if (__builtin_expect (!(NUMBERP (v2) || MARKERP (v2)), 0)) + v2 = Flength (v2); + TOP = arithcompare (v1, v2, ARITH_EQUAL); } + else + TOP = length_eqlsign2 (v1, v2); NEXT; } diff --git a/src/fns.c b/src/fns.c index 10653558eb..93d90a8d7e 100644 --- a/src/fns.c +++ b/src/fns.c @@ -137,6 +137,168 @@ which is at least the number of distinct elements. */) return make_fixnum_or_float (len); } +/* length= of 2 is separated out to use in the bytecode interpreter */ +Lisp_Object +length_eqlsign2 (Lisp_Object s1, Lisp_Object s2) +{ + Lisp_Object val = Qnil; + + if (! CONSP (s1) && ! CONSP (s2)) + { + if (MARKERP (s1)) + XSETFASTINT (s1, marker_position (s1)); + else if (!INTEGERP (s1)) + s1 = Flength (s1); + + if (MARKERP (s2)) + XSETFASTINT (s2, marker_position (s2)); + else if (!INTEGERP (s2)) + s2 = Flength (s2); + + val = EQ (s1, s2) ? Qt : Qnil; + } + else if (CONSP (s1) && CONSP (s2)) + { + int done = 0; + FOR_EACH_TAIL (s2) + { + if (done) + return Qnil; + s1 = XCDR (s1); + if (! CONSP (s1)) + done = 1; + } + CHECK_LIST_END (s2, s2); + if (! CONSP (s1)) + { + CHECK_LIST_END (s1, s1); + val = Qt; + } + } + else + { + if (CONSP (s1)) + { + Lisp_Object temp = s1; + s1 = s2; + s2 = temp; + } + if (__builtin_expect (MARKERP (s1), 0)) + XSETFASTINT (s1, marker_position (s1)); + else if (! INTEGERP (s1)) + s1 = Flength (s1); + intptr_t n = XINT (s1); + intptr_t i = 0; + FOR_EACH_TAIL (s2) + { + i++; + if (i > n) + return Qnil; + } + CHECK_LIST_END (s2, s2); + if (i == n) + val = Qt; + } + + return val; +} + +DEFUN ("length=", Flength_eqlsign, Slength_eqlsign, 1, MANY, 0, + doc: /* Compare the lengths of sequences with integers. +Return t if they are all equal, otherwise nil. Arguments may either be +integers or any type acceptable to `length'. + +For example (length= 2 \\='(1 2) [3 4]) returns t. +usage: (length= &rest SEQUENCES) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + + /* if (nargs == 2) */ + /* return length_eqlsign2 (args[0], args[1]); */ + /* Don't call length_eqlsign2 since it allows markers. Calls of two + args should be byte compiled to length_eqlsign2 anyway. The full + call for such cases only happens when the option to keep type + checks and errors is set. */ + Lisp_Object val = Qnil; + + Lisp_Object temp_list = Qnil; + ptrdiff_t temp_list_i = 0; + + /* First check non list sequences, length stored in val or bail if + inconsistency found. */ + for (ptrdiff_t argnum = 0; argnum < nargs; argnum++) + { + if (CONSP (args[argnum])) + { + if (NILP (temp_list)) + { + temp_list = args[argnum]; + temp_list_i = argnum; + } + continue; + } + else if (!INTEGERP (args[argnum])) + args[argnum] = Flength (args[argnum]); + + if (NILP (val)) + val = args[argnum]; + else if (!EQ (val, args[argnum])) + return Qnil; + + args[argnum] = Qnil; + } + + /* Now jointly iterate over the lists if there are any. Bail if any + lengths don't match. */ + if (CONSP (temp_list)) + { + temp_list_i++; + + intptr_t n = 0; + if (NILP (val)) + n = MOST_POSITIVE_FIXNUM; + else + n = XINT (val); + + int done = 0; + intptr_t i = 0; + FOR_EACH_TAIL (temp_list) + { + i++; + if (done || i > n) + return Qnil; + for (ptrdiff_t argnum = temp_list_i; argnum < nargs; argnum++) + { + if (! NILP (args[argnum])) + { + args[argnum] = (XCDR (args[argnum])); + if (! CONSP (args[argnum])) + done = 1; + } + } + } + CHECK_LIST_END (temp_list, temp_list); + if (i != n && ! NILP (val)) + return Qnil; + for (ptrdiff_t argnum = temp_list_i; argnum < nargs; argnum++) + { + if (! NILP (args[argnum])) + { + if (! CONSP (args[argnum])) + CHECK_LIST_END (args[argnum], args[argnum]); + return Qnil; + } + } + if (NILP (val)) + return Qt; + } + + if (! NILP (val)) + val = Qt; + + return val; +} + DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0, doc: /* Return the number of bytes in STRING. If STRING is multibyte, this may be greater than the length of STRING. */) @@ -5070,6 +5232,7 @@ this variable. */); defsubr (&Sidentity); defsubr (&Srandom); defsubr (&Slength); + defsubr (&Slength_eqlsign); defsubr (&Ssafe_length); defsubr (&Sstring_bytes); defsubr (&Sstring_equal); diff --git a/src/lisp.h b/src/lisp.h index 6d0b528335..91febbc4ca 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3341,6 +3341,7 @@ extern void init_syntax_once (void); extern void syms_of_syntax (void); /* Defined in fns.c. */ +extern Lisp_Object length_eqlsign2 (Lisp_Object, Lisp_Object); enum { NEXT_ALMOST_PRIME_LIMIT = 11 }; extern EMACS_INT next_almost_prime (EMACS_INT) ATTRIBUTE_CONST; extern Lisp_Object larger_vector (Lisp_Object, ptrdiff_t, ptrdiff_t); diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index d0b9790738..4c38d8aec8 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -244,6 +244,18 @@ byte-opt-testsuite-arith-data (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) (let ((a 3) (b 2) (c 1.0)) (/ a b c -1)) + + ;; Since the = opcode is overloaded with length=, ensure it works + (let ((a 3) (b 2) (c 1.0)) (= 1 c)) + (let ((a 3) (b 2) (c 1.0)) (= 2 b)) + (let ((a 3) (b 2) (c 1.0)) (= a 0)) + (let ((a 3) (b 2) (c 1.0)) (= a)) + (let ((a 3) (b 2) (c 1.0)) (= 2.0)) + (let ((a 3) (b 2) (c 1.0)) (= 2.0 b (+ a c))) + (let ((a 3) (b 2) (c 1.0)) (= a 0)) + (let ((a 3) (b 2) (c 1.0)) (= a 0.0)) + (let ((a 3) (b 2) (c 1.0)) (= 0 a b c)) + ;; Test switch bytecode (let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t))) (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) @@ -500,6 +512,14 @@ bytecomp-lexbind-explain-1 (dolist (pat bytecomp-lexbind-tests) (should (bytecomp-lexbind-check-1 pat)))) +(ert-deftest bytecomp-tests-=-typing () + "Test that `=' checks for correct typing when +`byte-compile-delete-errors' is null." + (let (byte-compile-delete-errors) + (should-error + (funcall (byte-compile (lambda (x y) (= x y))) 2 '(1 2)) + :type 'wrong-type-argument))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index a1b48a643e..2547643935 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -246,6 +246,30 @@ fns-tests--collate-enabled-p (should (equal (mapcan #'identity data) '(foo bar))) (should (equal data '((foo bar) (bar)))))) +(ert-deftest fns-tests-length= () + (should (length= 2 '(3 4) (vector 5 6))) + (should (length= '(1 2) '(3 4))) + (should (length= 0 nil)) + (should (length= '(1 2) "ab")) + (should (length= "ab" [c d])) + (should-not (length= 3 '(1 2))) + (should-not (length= '(1 2) '(1 2 3))) + (should-not (length= "a" "ab")) + (should-error (length= '(1 2) 2.1)) + ;; length= of two args when compiled behaves slightly differently to + ;; accomodate overloading the = bytecode. Test it too. + (let* ((byte-compile-delete-errors t) + (comp-length= (byte-compile (lambda (x y) (length= x y))))) + (should-not (funcall comp-length= 2.1 '(1 2))) + (should (funcall comp-length= 2.0 '(1 2))) + (should (funcall comp-length= '(1 2) '(3 4))) + (should (funcall comp-length= 0 nil)) + (should (funcall comp-length= '(1 2) "ab")) + (should (funcall comp-length= "ab" [c d])) + (should-not (funcall comp-length= "a" "ab")) + (should-not (funcall comp-length= 3 '(1 2))) + (should-not (funcall comp-length= '(1 2) '(1 2 3))))) + ;; Test handling of cyclic and dotted lists. (defun cyc1 (a) @@ -284,6 +308,16 @@ dot2 (should (= 10 (safe-length (dot1 1)))) (should (= 20 (safe-length (dot2 1 2))))) +(ert-deftest test-cycle-length= () + (should-error (length= (cyc1 1)) :type 'circular-list) + (should-error (length= (cyc2 1 2)) :type 'circular-list) + (should-error (length= (dot1 1)) :type 'wrong-type-argument) + (should-error (length= (dot2 1 2)) :type 'wrong-type-argument) + (should-error (length= 100 (cyc1 1)) :type 'circular-list) + (should-error (length= 10000 (cyc2 1 2)) :type 'circular-list) + (should-error (length= 100 (dot1 1)) :type 'wrong-type-argument) + (should-error (length= 100 (dot2 1 2)) :type 'wrong-type-argument)) + (ert-deftest test-cycle-member () (let ((c1 (cyc1 1)) (c2 (cyc2 1 2)) -- 2.12.0