From 8e287237218b0c8c98e76ffb413a9056aa564e97 Mon Sep 17 00:00:00 2001 From: Graham Dobbins Date: Sun, 26 Feb 2017 13:06:50 -0500 Subject: [PATCH 1/2] Add new lisp function length= * src/fns.c (Flength_eqlsign): define length= function. * test/src/fns-tests.el: add tests. --- etc/NEWS | 4 ++ src/fns.c | 104 ++++++++++++++++++++++++++++++++++++++++++++++++++ test/src/fns-tests.el | 17 +++++++++ 3 files changed, 125 insertions(+) diff --git a/etc/NEWS b/etc/NEWS index 31b7e4789e..6abcda729b 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -970,6 +970,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 and +numbers. + ** Changes in Frame- and Window- Handling +++ diff --git a/src/fns.c b/src/fns.c index 0b694529c5..8de7495841 100644 --- a/src/fns.c +++ b/src/fns.c @@ -137,6 +137,109 @@ which is at least the number of distinct elements. */) return make_fixnum_or_float (len); } +DEFUN ("length=", Flength_eqlsign, Slength_eqlsign, 1, MANY, 0, + doc: /* Each element of SEQUENCES may be any type accepted by +`length' or `='. True if the length of each sequence is equal to each +number, otherwise returns nil. +usage: (length= &rest SEQUENCES) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + + 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 (Fnumber_or_marker_p (args[argnum])) + { + if (NILP (val)) + { + val = args[argnum]; + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val); + } + else if (! CALLN (Feqlsign, val, args[argnum])) + return Qnil; + + args[argnum] = Qnil; + } + else if (CONSP (args[argnum])) + { + if (NILP (temp_list)) + { + temp_list = args[argnum]; + temp_list_i = argnum; + } + } + else + { + if (NILP (val)) + val = Flength (args[argnum]); + else if (! CALLN (Feqlsign, val, Flength (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 if (FLOATP (val)) + if (XFLOAT_DATA (val) - (intptr_t) XFLOAT_DATA (val) == 0) + n = (XFLOAT_DATA (val)); + else + return Qnil; + 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])) + { + CHECK_LIST_END (args[argnum], args[argnum]); + done = 1; + } + } + } + } + if (i != n && ! NILP (val)) + return Qnil; + for (ptrdiff_t argnum = temp_list_i; argnum < nargs; argnum++) + { + if (! NILP (args[argnum])) + return Qnil; + } + CHECK_LIST_END (temp_list, temp_list); + 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. */) @@ -5073,6 +5176,7 @@ this variable. */); defsubr (&Sidentity); defsubr (&Srandom); defsubr (&Slength); + defsubr (&Slength_eqlsign); defsubr (&Ssafe_length); defsubr (&Sstring_bytes); defsubr (&Sstring_equal); diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index a1b48a643e..5661ef2019 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -246,6 +246,13 @@ 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-not (length= 3 '(1 2))) + (should-not (length= '(1 2) '(1 2 3))) + (should-not (length= '(1 2) 2.1))) + ;; Test handling of cyclic and dotted lists. (defun cyc1 (a) @@ -284,6 +291,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.11.1 From 1d319882af723b02f702e00dd056ccf29a1f71f4 Mon Sep 17 00:00:00 2001 From: Graham Dobbins Date: Sun, 26 Feb 2017 14:16:51 -0500 Subject: [PATCH 2/2] Add bytecode support for length= by co-opting ='s bytecode length= behaves the same as = when given types appropriate for =. * src/fns.c (length_eqlsign2): define function for case of 2 args to length= * src/bytecode.c (exec_byte_code): change byte interpreter case for = opcode to use previous function * src/lisp.h (length_eqlsign2): add prototype for length_eqlsign2 * lisp/emacs-lisp/bytecomp.el: make length= compile to the same opcode as =, change byte-compile-delete-errors to default to t, make = compile in a discarded + operation in order to check types when previous var is null, change byte-compile-warning-types to include an 'unused' option, add a compiler macro for = to change to length= when appropriate. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): change warning to depend on 'unused' option of byte-compile-warning-types, add length= to side-effect-free-fns. * test/lisp/emacs-lisp/bytecomp-tests.el: add tests for above functionality. --- etc/NEWS | 5 ++ lisp/emacs-lisp/byte-opt.el | 4 +- lisp/emacs-lisp/bytecomp.el | 41 +++++++++++++++-- src/bytecode.c | 15 +----- src/fns.c | 83 ++++++++++++++++++++++++++++++++++ src/lisp.h | 1 + test/lisp/emacs-lisp/bytecomp-tests.el | 20 ++++++++ 7 files changed, 150 insertions(+), 19 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index 6abcda729b..642f1fdcfc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -325,6 +325,11 @@ 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 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..5c4a1d0cba 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,22 @@ byte-compile-insert (if (cdr form) (byte-compile-discard)))))) +(defun byte-compile-length= (form) + (if (length= 2 (cdr 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=. + (unless byte-compile-delete-errors + ;; The optimizer is smart enough to remove this when + ;; byte-compile-delete-errors is t, but why make it? + (byte-compile-form `(+ ,@(cdr form))) + (byte-compile-discard)) + (byte-compile-and-folded form)) + (byte-defop-compiler-1 setq) (byte-defop-compiler-1 setq-default) @@ -5051,6 +5071,19 @@ batch-byte-recompile-directory (eval form) form))) +(put '= 'compiler-macro + (lambda (form &rest args) + (cl-loop for f in args + when #1=(and (consp f) + (eq 'length (car f))) + return + `(length= + ,@(cl-loop for f in args + if #1# collect (cadr f) into lens + else collect f into nums + finally return (nconc nums lens))) + finally return form))) + (provide 'byte-compile) (provide 'bytecomp) diff --git a/src/bytecode.c b/src/bytecode.c index 4414b077bb..c32662ec36 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -991,19 +991,8 @@ 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)) - { - double f1 = FLOATP (v1) ? XFLOAT_DATA (v1) : XINT (v1); - double f2 = FLOATP (v2) ? XFLOAT_DATA (v2) : XINT (v2); - equal = f1 == f2; - } - else - equal = XINT (v1) == XINT (v2); - TOP = equal ? Qt : Qnil; + Lisp_Object v1 = POP; + TOP = length_eqlsign2 (TOP, v1); NEXT; } diff --git a/src/fns.c b/src/fns.c index 8de7495841..b0247c81c4 100644 --- a/src/fns.c +++ b/src/fns.c @@ -137,6 +137,86 @@ 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 (Fnumber_or_marker_p (s1)) + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (s1); + else if (! CONSP (s1)) + s1 = Flength (s1); + + if (Fnumber_or_marker_p (s2)) + CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (s2); + else if (! CONSP (s2)) + s2 = Flength (s2); + + if (! CONSP (s1) && ! CONSP (s2)) + { + int equal = 0; + if (FLOATP (s1) || FLOATP (s2)) + { + double f1 = FLOATP (s1) ? XFLOAT_DATA (s1) : XINT (s1); + double f2 = FLOATP (s2) ? XFLOAT_DATA (s2) : XINT (s2); + equal = f1 == f2; + } + else + equal = XINT (s1) == XINT (s2); + val = equal ? 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; + } + intptr_t n = 0; + if (FLOATP (s1)) + { + if (XFLOAT_DATA (s1) - (intptr_t) XFLOAT_DATA (s1) == 0) + n = XFLOAT_DATA (s1); + else + return Qnil; + } + else + 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: /* Each element of SEQUENCES may be any type accepted by `length' or `='. True if the length of each sequence is equal to each @@ -145,6 +225,9 @@ usage: (length= &rest SEQUENCES) */) (ptrdiff_t nargs, Lisp_Object *args) { + if (nargs == 2) + return length_eqlsign2 (args[0], args[1]); + Lisp_Object val = Qnil; Lisp_Object temp_list = Qnil; diff --git a/src/lisp.h b/src/lisp.h index e048011a86..836becac8a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3343,6 +3343,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: -- 2.11.1