commit d45dbccc5d2360818e70bbb0bc816c62c8cf6cbe (HEAD, refs/remotes/origin/master) Author: Paul Eggert Date: Sun Feb 5 14:07:11 2017 -0800 Port to clang 3.8.0 It does not allow a for-loop's control var to be an anonymous struct. * src/lisp.h (struct for_each_tail_internal): New type. (FOR_EACH_TAIL_INTERNAL): Use it. diff --git a/src/lisp.h b/src/lisp.h index edbd15170f..b753971fb9 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4603,6 +4603,14 @@ enum #define FOR_EACH_TAIL_SAFE(list) \ FOR_EACH_TAIL_INTERNAL (list, (void) 0, (void) (li.tail = Qnil), false) +/* Iterator intended for use only within FOR_EACH_TAIL_INTERNAL. */ +struct for_each_tail_internal +{ + Lisp_Object tail, tortoise; + intptr_t max, n; + unsigned short int q; +}; + /* Like FOR_EACH_TAIL (LIST), except evaluate DOTTED or CYCLE, respectively, if a dotted list or cycle is found, and check for quit if CHECK_QUIT. This is an internal macro intended for use @@ -4619,9 +4627,7 @@ enum is little point to calling maybe_quit here. */ #define FOR_EACH_TAIL_INTERNAL(list, dotted, cycle, check_quit) \ - for (struct { Lisp_Object tail, tortoise; intptr_t max, n; \ - unsigned short int q; \ - } li = { list, list, 2, 0, 2 }; \ + for (struct for_each_tail_internal li = { list, list, 2, 0, 2 }; \ CONSP (li.tail) || (dotted, false); \ (li.tail = XCDR (li.tail), \ ((--li.q != 0 \ commit c3ee4d2860a79503f0ea5a3ccdc8d4d1adaa8e57 Author: Paul Eggert Date: Sun Feb 5 13:25:37 2017 -0800 Add cyclic-list tests * test/manual/cycle-tests.el: New file (Bug#25606). diff --git a/test/manual/cycle-tests.el b/test/manual/cycle-tests.el new file mode 100644 index 0000000000..2632b2d7b5 --- /dev/null +++ b/test/manual/cycle-tests.el @@ -0,0 +1,314 @@ +;;; Test handling of cyclic and dotted lists -*- lexical-binding: t; -*- + +;; Copyright 2017 Free Software Foundation, Inc. + +;; Written by Paul Eggert + +;; 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 . + +(require 'ert) + +(defun cyc1 (a) + (let ((ls (make-list 10 a))) + (nconc ls ls) + ls)) +(defun cyc2 (a b) + (let ((ls1 (make-list 10 a)) + (ls2 (make-list 1000 b))) + (nconc ls2 ls2) + (nconc ls1 ls2) + ls1)) + +(defun dot1 (a) + (let ((ls (make-list 10 a))) + (nconc ls 'tail) + ls)) +(defun dot2 (a b) + (let ((ls1 (make-list 10 a)) + (ls2 (make-list 10 b))) + (nconc ls1 ls2) + (nconc ls2 'tail) + ls1)) + +(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)) + +(ert-deftest test-cycle-safe-length () + (should (<= 10 (safe-length (cyc1 1)))) + (should (<= 1010 (safe-length (cyc2 1 2)))) + (should (= 10 (safe-length (dot1 1)))) + (should (= 20 (safe-length (dot2 1 2))))) + +(ert-deftest test-cycle-member () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (member 1 c1)) + (should (member 1 c2)) + (should (member 1 d1)) + (should (member 1 d2)) + (should-error (member 2 c1) :type 'circular-list) + (should (member 2 c2)) + (should-error (member 2 d1) :type 'wrong-type-argument) + (should (member 2 d2)) + (should-error (member 3 c1) :type 'circular-list) + (should-error (member 3 c2) :type 'circular-list) + (should-error (member 3 d1) :type 'wrong-type-argument) + (should-error (member 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-memq () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (memq 1 c1)) + (should (memq 1 c2)) + (should (memq 1 d1)) + (should (memq 1 d2)) + (should-error (memq 2 c1) :type 'circular-list) + (should (memq 2 c2)) + (should-error (memq 2 d1) :type 'wrong-type-argument) + (should (memq 2 d2)) + (should-error (memq 3 c1) :type 'circular-list) + (should-error (memq 3 c2) :type 'circular-list) + (should-error (memq 3 d1) :type 'wrong-type-argument) + (should-error (memq 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-memql () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (memql 1 c1)) + (should (memql 1 c2)) + (should (memql 1 d1)) + (should (memql 1 d2)) + (should-error (memql 2 c1) :type 'circular-list) + (should (memql 2 c2)) + (should-error (memql 2 d1) :type 'wrong-type-argument) + (should (memql 2 d2)) + (should-error (memql 3 c1) :type 'circular-list) + (should-error (memql 3 c2) :type 'circular-list) + (should-error (memql 3 d1) :type 'wrong-type-argument) + (should-error (memql 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-assq () + (let ((c1 (cyc1 '(1))) + (c2 (cyc2 '(1) '(2))) + (d1 (dot1 '(1))) + (d2 (dot2 '(1) '(2)))) + (should (assq 1 c1)) + (should (assq 1 c2)) + (should (assq 1 d1)) + (should (assq 1 d2)) + (should-error (assq 2 c1) :type 'circular-list) + (should (assq 2 c2)) + (should-error (assq 2 d1) :type 'wrong-type-argument) + (should (assq 2 d2)) + (should-error (assq 3 c1) :type 'circular-list) + (should-error (assq 3 c2) :type 'circular-list) + (should-error (assq 3 d1) :type 'wrong-type-argument) + (should-error (assq 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-assoc () + (let ((c1 (cyc1 '(1))) + (c2 (cyc2 '(1) '(2))) + (d1 (dot1 '(1))) + (d2 (dot2 '(1) '(2)))) + (should (assoc 1 c1)) + (should (assoc 1 c2)) + (should (assoc 1 d1)) + (should (assoc 1 d2)) + (should-error (assoc 2 c1) :type 'circular-list) + (should (assoc 2 c2)) + (should-error (assoc 2 d1) :type 'wrong-type-argument) + (should (assoc 2 d2)) + (should-error (assoc 3 c1) :type 'circular-list) + (should-error (assoc 3 c2) :type 'circular-list) + (should-error (assoc 3 d1) :type 'wrong-type-argument) + (should-error (assoc 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-rassq () + (let ((c1 (cyc1 '(0 . 1))) + (c2 (cyc2 '(0 . 1) '(0 . 2))) + (d1 (dot1 '(0 . 1))) + (d2 (dot2 '(0 . 1) '(0 . 2)))) + (should (rassq 1 c1)) + (should (rassq 1 c2)) + (should (rassq 1 d1)) + (should (rassq 1 d2)) + (should-error (rassq 2 c1) :type 'circular-list) + (should (rassq 2 c2)) + (should-error (rassq 2 d1) :type 'wrong-type-argument) + (should (rassq 2 d2)) + (should-error (rassq 3 c1) :type 'circular-list) + (should-error (rassq 3 c2) :type 'circular-list) + (should-error (rassq 3 d1) :type 'wrong-type-argument) + (should-error (rassq 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-rassoc () + (let ((c1 (cyc1 '(0 . 1))) + (c2 (cyc2 '(0 . 1) '(0 . 2))) + (d1 (dot1 '(0 . 1))) + (d2 (dot2 '(0 . 1) '(0 . 2)))) + (should (rassoc 1 c1)) + (should (rassoc 1 c2)) + (should (rassoc 1 d1)) + (should (rassoc 1 d2)) + (should-error (rassoc 2 c1) :type 'circular-list) + (should (rassoc 2 c2)) + (should-error (rassoc 2 d1) :type 'wrong-type-argument) + (should (rassoc 2 d2)) + (should-error (rassoc 3 c1) :type 'circular-list) + (should-error (rassoc 3 c2) :type 'circular-list) + (should-error (rassoc 3 d1) :type 'wrong-type-argument) + (should-error (rassoc 3 d2) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-delq () + (should-error (delq 1 (cyc1 1)) :type 'circular-list) + (should-error (delq 1 (cyc2 1 2)) :type 'circular-list) + (should-error (delq 1 (dot1 1)) :type 'wrong-type-argument) + (should-error (delq 1 (dot2 1 2)) :type 'wrong-type-argument) + (should-error (delq 2 (cyc1 1)) :type 'circular-list) + (should-error (delq 2 (cyc2 1 2)) :type 'circular-list) + (should-error (delq 2 (dot1 1)) :type 'wrong-type-argument) + (should-error (delq 2 (dot2 1 2)) :type 'wrong-type-argument) + (should-error (delq 3 (cyc1 1)) :type 'circular-list) + (should-error (delq 3 (cyc2 1 2)) :type 'circular-list) + (should-error (delq 3 (dot1 1)) :type 'wrong-type-argument) + (should-error (delq 3 (dot2 1 2)) :type 'wrong-type-argument)) + +(ert-deftest test-cycle-delete () + (should-error (delete 1 (cyc1 1)) :type 'circular-list) + (should-error (delete 1 (cyc2 1 2)) :type 'circular-list) + (should-error (delete 1 (dot1 1)) :type 'wrong-type-argument) + (should-error (delete 1 (dot2 1 2)) :type 'wrong-type-argument) + (should-error (delete 2 (cyc1 1)) :type 'circular-list) + (should-error (delete 2 (cyc2 1 2)) :type 'circular-list) + (should-error (delete 2 (dot1 1)) :type 'wrong-type-argument) + (should-error (delete 2 (dot2 1 2)) :type 'wrong-type-argument) + (should-error (delete 3 (cyc1 1)) :type 'circular-list) + (should-error (delete 3 (cyc2 1 2)) :type 'circular-list) + (should-error (delete 3 (dot1 1)) :type 'wrong-type-argument) + (should-error (delete 3 (dot2 1 2)) :type 'wrong-type-argument)) + +(ert-deftest test-cycle-reverse () + (should-error (reverse (cyc1 1)) :type 'circular-list) + (should-error (reverse (cyc2 1 2)) :type 'circular-list) + (should-error (reverse (dot1 1)) :type 'wrong-type-argument) + (should-error (reverse (dot2 1 2)) :type 'wrong-type-argument)) + +(ert-deftest test-cycle-plist-get () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (plist-get c1 1)) + (should (plist-get c2 1)) + (should (plist-get d1 1)) + (should (plist-get d2 1)) + (should-not (plist-get c1 2)) + (should (plist-get c2 2)) + (should-not (plist-get d1 2)) + (should (plist-get d2 2)) + (should-not (plist-get c1 3)) + (should-not (plist-get c2 3)) + (should-not (plist-get d1 3)) + (should-not (plist-get d2 3)))) + +(ert-deftest test-cycle-lax-plist-get () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (lax-plist-get c1 1)) + (should (lax-plist-get c2 1)) + (should (lax-plist-get d1 1)) + (should (lax-plist-get d2 1)) + (should-error (lax-plist-get c1 2) :type 'circular-list) + (should (lax-plist-get c2 2)) + (should-not (lax-plist-get d1 2)) + (should (lax-plist-get d2 2)) + (should-error (lax-plist-get c1 3) :type 'circular-list) + (should-error (lax-plist-get c2 3) :type 'circular-list) + (should-not (lax-plist-get d1 3)) + (should-not (lax-plist-get d2 3)))) + +(ert-deftest test-cycle-plist-member () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (plist-member c1 1)) + (should (plist-member c2 1)) + (should (plist-member d1 1)) + (should (plist-member d2 1)) + (should-error (plist-member c1 2) :type 'circular-list) + (should (plist-member c2 2)) + (should-error (plist-member d1 2) :type 'wrong-type-argument) + (should (plist-member d2 2)) + (should-error (plist-member c1 3) :type 'circular-list) + (should-error (plist-member c2 3) :type 'circular-list) + (should-error (plist-member d1 3) :type 'wrong-type-argument) + (should-error (plist-member d2 3) :type 'wrong-type-argument))) + +(ert-deftest test-cycle-plist-put () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (plist-put c1 1 1)) + (should (plist-put c2 1 1)) + (should (plist-put d1 1 1)) + (should (plist-put d2 1 1)) + (should-error (plist-put c1 2 2) :type 'circular-list) + (should (plist-put c2 2 2)) + (should (plist-put d1 2 2)) + (should (plist-put d2 2 2)) + (should-error (plist-put c1 3 3) :type 'circular-list) + (should-error (plist-put c2 3 3) :type 'circular-list) + (should (plist-put d1 3 3)) + (should (plist-put d2 3 3)))) + +(ert-deftest test-cycle-lax-plist-put () + (let ((c1 (cyc1 1)) + (c2 (cyc2 1 2)) + (d1 (dot1 1)) + (d2 (dot2 1 2))) + (should (lax-plist-put c1 1 1)) + (should (lax-plist-put c2 1 1)) + (should (lax-plist-put d1 1 1)) + (should (lax-plist-put d2 1 1)) + (should-error (lax-plist-put c1 2 2) :type 'circular-list) + (should (lax-plist-put c2 2 2)) + (should (lax-plist-put d1 2 2)) + (should (lax-plist-put d2 2 2)) + (should-error (lax-plist-put c1 3 3) :type 'circular-list) + (should-error (lax-plist-put c2 3 3) :type 'circular-list) + (should (lax-plist-put d1 3 3)) + (should (lax-plist-put d2 3 3)))) + +(ert-deftest test-cycle-equal () + (should-error (equal (cyc1 1) (cyc1 1))) + (should-error (equal (cyc2 1 2) (cyc2 1 2)))) + +(ert-deftest test-cycle-nconc () + (should-error (nconc (cyc1 1) 'tail) :type 'circular-list) + (should-error (nconc (cyc2 1 2) 'tail) :type 'circular-list)) + +(provide 'cycle-tests) commit b491322ed0fcf039669183880a342bbb2326e787 Author: Paul Eggert Date: Sun Feb 5 13:25:37 2017 -0800 FOR_EACH_TAIL now checks for quit As per Eli Zaretskii (Bug#25606#20). Although these calls to maybe_quit are unnecessary in practice, Eli was not convinced that the calls are unnecessary. * src/lisp.h (FOR_EACH_TAIL, FOR_EACH_TAIL_CONS): Call maybe_quit every so often. (FOR_EACH_TAIL_INTERNAL): New arg CHECK_QUIT. All callers changed. diff --git a/src/lisp.h b/src/lisp.h index 13fca0b29e..edbd15170f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4580,44 +4580,56 @@ enum Lisp_String)) \ : make_unibyte_string (str, len)) -/* Loop over tails of LIST, checking for dotted lists and cycles. +/* Loop over tails of LIST, checking for dotted lists and cycles, + and possibly quitting after each loop iteration. In the loop body, ‘li.tail’ is the current cons; the name ‘li’ is short for “list iterator”. The expression LIST may be evaluated more than once, and so should not have side effects. The loop body should not modify the list’s top level structure other than by - perhaps deleting the current cons. - - Use Brent’s teleporting tortoise-hare algorithm. See: - Brent RP. BIT. 1980;20(2):176-84. doi:10.1007/BF01933190 - http://maths-people.anu.edu.au/~brent/pd/rpb051i.pdf */ + perhaps deleting the current cons. */ #define FOR_EACH_TAIL(list) \ FOR_EACH_TAIL_INTERNAL (list, CHECK_LIST_END (li.tail, list), \ - circular_list (list)) + circular_list (list), true) -/* Like FOR_EACH_TAIL (LIST), except check only for cycles. */ +/* Like FOR_EACH_TAIL (LIST), except do not check for dotted lists. */ -#define FOR_EACH_TAIL_CONS(list) \ - FOR_EACH_TAIL_INTERNAL (list, (void) 0, circular_list (list)) +#define FOR_EACH_TAIL_CONS(list) \ + FOR_EACH_TAIL_INTERNAL (list, (void) 0, circular_list (list), true) /* Like FOR_EACH_TAIL (LIST), except check for neither dotted lists - nor cycles. */ + nor cycles, and do not quit. */ #define FOR_EACH_TAIL_SAFE(list) \ - FOR_EACH_TAIL_INTERNAL (list, (void) 0, (void) (li.tail = Qnil)) + FOR_EACH_TAIL_INTERNAL (list, (void) 0, (void) (li.tail = Qnil), false) /* Like FOR_EACH_TAIL (LIST), except evaluate DOTTED or CYCLE, - respectively, if a dotted list or cycle is found. This is an - internal macro intended for use only by the above macros. */ + respectively, if a dotted list or cycle is found, and check for + quit if CHECK_QUIT. This is an internal macro intended for use + only by the above macros. -#define FOR_EACH_TAIL_INTERNAL(list, dotted, cycle) \ - for (struct { Lisp_Object tail, tortoise; intptr_t n, max; } li \ - = { list, list, 2, 2 }; \ + Use Brent’s teleporting tortoise-hare algorithm. See: + Brent RP. BIT. 1980;20(2):176-84. doi:10.1007/BF01933190 + http://maths-people.anu.edu.au/~brent/pd/rpb051i.pdf + + This macro uses maybe_quit because of an excess of caution. The + call to maybe_quit should not be needed in practice, as a very long + list, whether circular or not, will cause Emacs to be so slow in + other noninterruptible areas (e.g., garbage collection) that there + is little point to calling maybe_quit here. */ + +#define FOR_EACH_TAIL_INTERNAL(list, dotted, cycle, check_quit) \ + for (struct { Lisp_Object tail, tortoise; intptr_t max, n; \ + unsigned short int q; \ + } li = { list, list, 2, 0, 2 }; \ CONSP (li.tail) || (dotted, false); \ (li.tail = XCDR (li.tail), \ - (li.n-- == 0 \ - ? (void) (li.n = li.max <<= 1, li.tortoise = li.tail) \ - : EQ (li.tail, li.tortoise) ? (cycle) : (void) 0))) + ((--li.q != 0 \ + || ((check_quit) ? maybe_quit () : (void) 0, 0 < --li.n) \ + || (li.q = li.n = li.max <<= 1, li.n >>= USHRT_WIDTH, \ + li.tortoise = li.tail, false)) \ + && EQ (li.tail, li.tortoise)) \ + ? (cycle) : (void) 0)) /* Do a `for' loop over alist values. */ commit 14dd9101ec4838f75addf25bf6b06ef33f8a7e97 Author: Paul Eggert Date: Sun Feb 5 13:25:37 2017 -0800 Signal list cycles in ‘length’ etc. Use macros like FOR_EACH_TAIL instead of maybe_quit to catch list cycles automatically instead of relying on the user becoming impatient and typing C-g (Bug#25606). * src/fns.c (Flength, Fmember, Fmemq, Fmemql, Fassq, Fassoc, Frassq) (Frassoc, Fdelete, Freverse): Use FOR_EACH_TAIL instead of maybe_quit. (Fnreverse): Use simple EQ to check for circular list instead of rarely_quit, as this suffices in this unusual case. (Fplist_put, Flax_plist_put, Flax_plist_put): Use FOR_EACH_TAIL_CONS instead of maybe_quit. (internal_equal): Use FOR_EACH_TAIL_CONS to check lists, instead of by-hand tail recursion that did not catch cycles. * src/fns.c (Fsafe_length, Fplist_get): * src/xdisp.c (display_mode_element): Use FOR_EACH_TAIL_SAFE instead of by-hand Floyd’s algorithm. * src/lisp.h (QUIT_COUNT_HEURISTIC): Remove; no longer needed. (rarely_quit): Simply count toward USHRT_MAX + 1, since the fancier versions are no longer needed. (FOR_EACH_TAIL_CONS, FOR_EACH_TAIL_SAFE) (FOR_EACH_TAIL_INTERNAL): New macros, the last with definiens mostly taken from FOR_EACH_TAIL. (FOR_EACH_TAIL): Rewrite in terms of FOR_EACH_TAIL_INTERNAL. diff --git a/etc/NEWS b/etc/NEWS index cbf2b70c82..4d8ae091a7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -900,6 +900,9 @@ collection). ** 'if-let*', 'when-let*', and 'and-let*' are new in subr-x.el. The incumbent 'if-let' and 'when-let' are now aliases. +** Low-level list functions like 'length' and 'member' now do a better +job of signaling list cycles instead of looping indefinitely. + +++ ** The new functions 'make-nearby-temp-file' and 'temporary-file-directory' can be used for creation of temporary files of remote or mounted directories. diff --git a/src/fns.c b/src/fns.c index 4de74a5967..b5508fb56a 100644 --- a/src/fns.c +++ b/src/fns.c @@ -108,23 +108,11 @@ To get the number of bytes, use `string-bytes'. */) XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK); else if (CONSP (sequence)) { - EMACS_INT i = 0; - - do - { - ++i; - if ((i & (QUIT_COUNT_HEURISTIC - 1)) == 0) - { - if (MOST_POSITIVE_FIXNUM < i) - error ("List too long"); - maybe_quit (); - } - sequence = XCDR (sequence); - } - while (CONSP (sequence)); - - CHECK_LIST_END (sequence, sequence); - + intptr_t i = 0; + FOR_EACH_TAIL (sequence) + i++; + if (MOST_POSITIVE_FIXNUM < i) + error ("List too long"); val = make_number (i); } else if (NILP (sequence)) @@ -142,38 +130,10 @@ it returns 0. If LIST is circular, it returns a finite value which is at least the number of distinct elements. */) (Lisp_Object list) { - Lisp_Object tail, halftail; - double hilen = 0; - uintmax_t lolen = 1; - - if (! CONSP (list)) - return make_number (0); - - /* halftail is used to detect circular lists. */ - for (tail = halftail = list; ; ) - { - tail = XCDR (tail); - if (! CONSP (tail)) - break; - if (EQ (tail, halftail)) - break; - lolen++; - if ((lolen & 1) == 0) - { - halftail = XCDR (halftail); - if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0) - { - maybe_quit (); - if (lolen == 0) - hilen += UINTMAX_MAX + 1.0; - } - } - } - - /* If the length does not fit into a fixnum, return a float. - On all known practical machines this returns an upper bound on - the true length. */ - return hilen ? make_float (hilen + lolen) : make_fixnum_or_float (lolen); + intptr_t len = 0; + FOR_EACH_TAIL_SAFE (list) + len++; + return make_fixnum_or_float (len); } DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0, @@ -1383,15 +1343,9 @@ DEFUN ("member", Fmember, Smember, 2, 2, 0, The value is actually the tail of LIST whose car is ELT. */) (Lisp_Object elt, Lisp_Object list) { - unsigned short int quit_count = 0; - Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) - { - if (! NILP (Fequal (elt, XCAR (tail)))) - return tail; - rarely_quit (++quit_count); - } - CHECK_LIST_END (tail, list); + FOR_EACH_TAIL (list) + if (! NILP (Fequal (elt, XCAR (li.tail)))) + return li.tail; return Qnil; } @@ -1400,15 +1354,9 @@ DEFUN ("memq", Fmemq, Smemq, 2, 2, 0, The value is actually the tail of LIST whose car is ELT. */) (Lisp_Object elt, Lisp_Object list) { - unsigned short int quit_count = 0; - Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) - { - if (EQ (XCAR (tail), elt)) - return tail; - rarely_quit (++quit_count); - } - CHECK_LIST_END (tail, list); + FOR_EACH_TAIL (list) + if (EQ (XCAR (li.tail), elt)) + return li.tail; return Qnil; } @@ -1420,16 +1368,12 @@ The value is actually the tail of LIST whose car is ELT. */) if (!FLOATP (elt)) return Fmemq (elt, list); - unsigned short int quit_count = 0; - Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + FOR_EACH_TAIL (list) { - Lisp_Object tem = XCAR (tail); + Lisp_Object tem = XCAR (li.tail); if (FLOATP (tem) && internal_equal (elt, tem, 0, 0, Qnil)) - return tail; - rarely_quit (++quit_count); + return li.tail; } - CHECK_LIST_END (tail, list); return Qnil; } @@ -1439,15 +1383,9 @@ The value is actually the first element of LIST whose car is KEY. Elements of LIST that are not conses are ignored. */) (Lisp_Object key, Lisp_Object list) { - unsigned short int quit_count = 0; - Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) - { - if (CONSP (XCAR (tail)) && EQ (XCAR (XCAR (tail)), key)) - return XCAR (tail); - rarely_quit (++quit_count); - } - CHECK_LIST_END (tail, list); + FOR_EACH_TAIL (list) + if (CONSP (XCAR (li.tail)) && EQ (XCAR (XCAR (li.tail)), key)) + return XCAR (li.tail); return Qnil; } @@ -1468,17 +1406,13 @@ DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0, The value is actually the first element of LIST whose car equals KEY. */) (Lisp_Object key, Lisp_Object list) { - unsigned short int quit_count = 0; - Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + FOR_EACH_TAIL (list) { - Lisp_Object car = XCAR (tail); + Lisp_Object car = XCAR (li.tail); if (CONSP (car) && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))) return car; - rarely_quit (++quit_count); } - CHECK_LIST_END (tail, list); return Qnil; } @@ -1503,15 +1437,9 @@ DEFUN ("rassq", Frassq, Srassq, 2, 2, 0, The value is actually the first element of LIST whose cdr is KEY. */) (Lisp_Object key, Lisp_Object list) { - unsigned short int quit_count = 0; - Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) - { - if (CONSP (XCAR (tail)) && EQ (XCDR (XCAR (tail)), key)) - return XCAR (tail); - rarely_quit (++quit_count); - } - CHECK_LIST_END (tail, list); + FOR_EACH_TAIL (list) + if (CONSP (XCAR (li.tail)) && EQ (XCDR (XCAR (li.tail)), key)) + return XCAR (li.tail); return Qnil; } @@ -1520,17 +1448,13 @@ DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, The value is actually the first element of LIST whose cdr equals KEY. */) (Lisp_Object key, Lisp_Object list) { - unsigned short int quit_count = 0; - Lisp_Object tail; - for (tail = list; CONSP (tail); tail = XCDR (tail)) + FOR_EACH_TAIL (list) { - Lisp_Object car = XCAR (tail); + Lisp_Object car = XCAR (li.tail); if (CONSP (car) && (EQ (XCDR (car), key) || !NILP (Fequal (XCDR (car), key)))) return car; - rarely_quit (++quit_count); } - CHECK_LIST_END (tail, list); return Qnil; } @@ -1668,23 +1592,20 @@ changing the value of a sequence `foo'. */) } else { - unsigned short int quit_count = 0; - Lisp_Object tail, prev; + Lisp_Object prev = Qnil; - for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail)) + FOR_EACH_TAIL (seq) { - if (!NILP (Fequal (elt, XCAR (tail)))) + if (!NILP (Fequal (elt, (XCAR (li.tail))))) { if (NILP (prev)) - seq = XCDR (tail); + seq = XCDR (li.tail); else - Fsetcdr (prev, XCDR (tail)); + Fsetcdr (prev, XCDR (li.tail)); } else - prev = tail; - rarely_quit (++quit_count); + prev = li.tail; } - CHECK_LIST_END (tail, seq); } return seq; @@ -1702,15 +1623,17 @@ This function may destructively modify SEQ to produce the value. */) return Freverse (seq); else if (CONSP (seq)) { - unsigned short int quit_count = 0; Lisp_Object prev, tail, next; for (prev = Qnil, tail = seq; CONSP (tail); tail = next) { next = XCDR (tail); + /* If SEQ contains a cycle, attempting to reverse it + in-place will inevitably come back to SEQ. */ + if (EQ (next, seq)) + circular_list (seq); Fsetcdr (tail, prev); prev = tail; - rarely_quit (++quit_count); } CHECK_LIST_END (tail, seq); seq = prev; @@ -1753,13 +1676,9 @@ See also the function `nreverse', which is used more often. */) return Qnil; else if (CONSP (seq)) { - unsigned short int quit_count = 0; - for (new = Qnil; CONSP (seq); seq = XCDR (seq)) - { - new = Fcons (XCAR (seq), new); - rarely_quit (++quit_count); - } - CHECK_LIST_END (seq, seq); + new = Qnil; + FOR_EACH_TAIL (seq) + new = Fcons (XCAR (li.tail), new); } else if (VECTORP (seq)) { @@ -2011,18 +1930,14 @@ corresponding to the given PROP, or nil if PROP is not one of the properties on the list. This function never signals an error. */) (Lisp_Object plist, Lisp_Object prop) { - Lisp_Object tail, halftail; - - /* halftail is used to detect circular lists. */ - tail = halftail = plist; - while (CONSP (tail) && CONSP (XCDR (tail))) + FOR_EACH_TAIL_SAFE (plist) { - if (EQ (prop, XCAR (tail))) - return XCAR (XCDR (tail)); - - tail = XCDR (XCDR (tail)); - halftail = XCDR (halftail); - if (EQ (tail, halftail)) + if (! CONSP (XCDR (li.tail))) + break; + if (EQ (prop, XCAR (li.tail))) + return XCAR (XCDR (li.tail)); + li.tail = XCDR (li.tail); + if (EQ (li.tail, li.tortoise)) break; } @@ -2048,19 +1963,22 @@ use `(setq x (plist-put x prop val))' to be sure to use the new value. The PLIST is modified by side effects. */) (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) { - unsigned short int quit_count = 0; Lisp_Object prev = Qnil; - for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail)); - tail = XCDR (XCDR (tail))) + FOR_EACH_TAIL_CONS (plist) { - if (EQ (prop, XCAR (tail))) + if (! CONSP (XCDR (li.tail))) + break; + + if (EQ (prop, XCAR (li.tail))) { - Fsetcar (XCDR (tail), val); + Fsetcar (XCDR (li.tail), val); return plist; } - prev = tail; - rarely_quit (++quit_count); + prev = li.tail; + li.tail = XCDR (li.tail); + if (EQ (li.tail, li.tortoise)) + circular_list (plist); } Lisp_Object newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev)))); @@ -2089,20 +2007,16 @@ corresponding to the given PROP, or nil if PROP is not one of the properties on the list. */) (Lisp_Object plist, Lisp_Object prop) { - unsigned short int quit_count = 0; - Lisp_Object tail; - - for (tail = plist; - CONSP (tail) && CONSP (XCDR (tail)); - tail = XCDR (XCDR (tail))) + FOR_EACH_TAIL_CONS (plist) { - if (! NILP (Fequal (prop, XCAR (tail)))) - return XCAR (XCDR (tail)); - rarely_quit (++quit_count); + if (! CONSP (XCDR (li.tail))) + break; + if (! NILP (Fequal (prop, XCAR (li.tail)))) + return XCAR (XCDR (li.tail)); + li.tail = XCDR (li.tail); + if (EQ (li.tail, li.tortoise)) + circular_list (plist); } - - CHECK_LIST_END (tail, prop); - return Qnil; } @@ -2116,19 +2030,22 @@ use `(setq x (lax-plist-put x prop val))' to be sure to use the new value. The PLIST is modified by side effects. */) (Lisp_Object plist, Lisp_Object prop, Lisp_Object val) { - unsigned short int quit_count = 0; Lisp_Object prev = Qnil; - for (Lisp_Object tail = plist; CONSP (tail) && CONSP (XCDR (tail)); - tail = XCDR (XCDR (tail))) + FOR_EACH_TAIL_CONS (plist) { - if (! NILP (Fequal (prop, XCAR (tail)))) + if (! CONSP (XCDR (li.tail))) + break; + + if (! NILP (Fequal (prop, XCAR (li.tail)))) { - Fsetcar (XCDR (tail), val); + Fsetcar (XCDR (li.tail), val); return plist; } - prev = tail; - rarely_quit (++quit_count); + prev = li.tail; + li.tail = XCDR (li.tail); + if (EQ (li.tail, li.tortoise)) + circular_list (plist); } Lisp_Object newcell = list2 (prop, val); if (NILP (prev)) @@ -2206,9 +2123,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props, } } - unsigned short int quit_count = 0; tail_recurse: - rarely_quit (++quit_count); if (EQ (o1, o2)) return 1; if (XTYPE (o1) != XTYPE (o2)) @@ -2228,12 +2143,24 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props, } case Lisp_Cons: - if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props, ht)) - return 0; - o1 = XCDR (o1); - o2 = XCDR (o2); - /* FIXME: This inf-loops in a circular list! */ - goto tail_recurse; + { + Lisp_Object tail1 = o1; + FOR_EACH_TAIL_CONS (o1) + { + if (! CONSP (o2)) + return false; + if (! internal_equal (XCAR (li.tail), XCAR (o2), depth + 1, + props, ht)) + return false; + tail1 = XCDR (li.tail); + o2 = XCDR (o2); + if (EQ (tail1, o2)) + return true; + } + o1 = tail1; + depth++; + goto tail_recurse; + } case Lisp_Misc: if (XMISCTYPE (o1) != XMISCTYPE (o2)) @@ -2247,6 +2174,7 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, int depth, bool props, return 0; o1 = XOVERLAY (o1)->plist; o2 = XOVERLAY (o2)->plist; + depth++; goto tail_recurse; } if (MARKERP (o1)) @@ -2397,7 +2325,6 @@ Only the last argument is not altered, and need not be a list. usage: (nconc &rest LISTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - unsigned short int quit_count = 0; Lisp_Object val = Qnil; for (ptrdiff_t argnum = 0; argnum < nargs; argnum++) @@ -2413,13 +2340,8 @@ usage: (nconc &rest LISTS) */) CHECK_CONS (tem); Lisp_Object tail; - do - { - tail = tem; - tem = XCDR (tail); - rarely_quit (++quit_count); - } - while (CONSP (tem)); + FOR_EACH_TAIL_CONS (tem) + tail = li.tail; tem = args[argnum + 1]; Fsetcdr (tail, tem); @@ -2841,14 +2763,20 @@ property and a property with the value nil. The value is actually the tail of PLIST whose car is PROP. */) (Lisp_Object plist, Lisp_Object prop) { - unsigned short int quit_count = 0; - while (CONSP (plist) && !EQ (XCAR (plist), prop)) + FOR_EACH_TAIL (plist) { - plist = XCDR (plist); - plist = CDR (plist); - rarely_quit (++quit_count); + if (EQ (XCAR (li.tail), prop)) + return li.tail; + if (!CONSP (XCDR (li.tail))) + { + CHECK_LIST_END (XCDR (li.tail), plist); + return Qnil; + } + li.tail = XCDR (li.tail); + if (EQ (li.tail, li.tortoise)) + circular_list (plist); } - return plist; + return Qnil; } DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0, diff --git a/src/lisp.h b/src/lisp.h index 102e8bd70e..13fca0b29e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3129,20 +3129,14 @@ extern void maybe_quit (void); #define QUITP (!NILP (Vquit_flag) && NILP (Vinhibit_quit)) -/* Heuristic on how many iterations of a tight loop can be safely done - before it's time to do a quit. This must be a power of 2. It - is nice but not necessary for it to equal USHRT_MAX + 1. */ - -enum { QUIT_COUNT_HEURISTIC = 1 << 16 }; - /* Process a quit rarely, based on a counter COUNT, for efficiency. - "Rarely" means once per QUIT_COUNT_HEURISTIC or per USHRT_MAX + 1 - times, whichever is smaller (somewhat arbitrary, but often faster). */ + "Rarely" means once per USHRT_MAX + 1 times; this is somewhat + arbitrary, but efficient. */ INLINE void rarely_quit (unsigned short int count) { - if (! (count & (QUIT_COUNT_HEURISTIC - 1))) + if (! count) maybe_quit (); } @@ -4598,13 +4592,32 @@ enum http://maths-people.anu.edu.au/~brent/pd/rpb051i.pdf */ #define FOR_EACH_TAIL(list) \ + FOR_EACH_TAIL_INTERNAL (list, CHECK_LIST_END (li.tail, list), \ + circular_list (list)) + +/* Like FOR_EACH_TAIL (LIST), except check only for cycles. */ + +#define FOR_EACH_TAIL_CONS(list) \ + FOR_EACH_TAIL_INTERNAL (list, (void) 0, circular_list (list)) + +/* Like FOR_EACH_TAIL (LIST), except check for neither dotted lists + nor cycles. */ + +#define FOR_EACH_TAIL_SAFE(list) \ + FOR_EACH_TAIL_INTERNAL (list, (void) 0, (void) (li.tail = Qnil)) + +/* Like FOR_EACH_TAIL (LIST), except evaluate DOTTED or CYCLE, + respectively, if a dotted list or cycle is found. This is an + internal macro intended for use only by the above macros. */ + +#define FOR_EACH_TAIL_INTERNAL(list, dotted, cycle) \ for (struct { Lisp_Object tail, tortoise; intptr_t n, max; } li \ = { list, list, 2, 2 }; \ - CONSP (li.tail) || (CHECK_LIST_END (li.tail, list), false); \ + CONSP (li.tail) || (dotted, false); \ (li.tail = XCDR (li.tail), \ (li.n-- == 0 \ ? (void) (li.n = li.max <<= 1, li.tortoise = li.tail) \ - : EQ (li.tail, li.tortoise) ? circular_list (list) : (void) 0))) + : EQ (li.tail, li.tortoise) ? (cycle) : (void) 0))) /* Do a `for' loop over alist values. */ diff --git a/src/xdisp.c b/src/xdisp.c index 0e329dfe6e..5e1207f29e 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -23033,30 +23033,19 @@ display_mode_element (struct it *it, int depth, int field_width, int precision, goto tail_recurse; } else if (STRINGP (car) || CONSP (car)) - { - Lisp_Object halftail = elt; - int len = 0; - - while (CONSP (elt) - && (precision <= 0 || n < precision)) - { - n += display_mode_element (it, depth, - /* Do padding only after the last - element in the list. */ - (! CONSP (XCDR (elt)) - ? field_width - n - : 0), - precision - n, XCAR (elt), - props, risky); - elt = XCDR (elt); - len++; - if ((len & 1) == 0) - halftail = XCDR (halftail); - /* Check for cycle. */ - if (EQ (halftail, elt)) - break; - } - } + FOR_EACH_TAIL_SAFE (elt) + { + if (0 < precision && precision <= n) + break; + n += display_mode_element (it, depth, + /* Pad after only the last + list element. */ + (! CONSP (XCDR (li.tail)) + ? field_width - n + : 0), + precision - n, XCAR (li.tail), + props, risky); + } } break; commit b7fa6b1f1cee9d1b71553fa665843774d2e5cf3d Author: Paul Eggert Date: Sun Feb 5 13:25:37 2017 -0800 Simplify use of FOR_EACH_TAIL * src/data.c (circular_list): New function. * src/lisp.h (FOR_EACH_TAIL): Use Brent’s algorithm and C99 for-loop decl, to eliminate the need for the args TAIL, TORTOISE and N, and to speed things up a bit on typical hosts with optimization. All uses changed (Bug#25605). diff --git a/src/data.c b/src/data.c index 8e07bf01b4..12dc2df0ba 100644 --- a/src/data.c +++ b/src/data.c @@ -170,6 +170,12 @@ args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3) xsignal3 (Qargs_out_of_range, a1, a2, a3); } +void +circular_list (Lisp_Object list) +{ + xsignal1 (Qcircular_list, list); +} + /* Data type predicates. */ diff --git a/src/fns.c b/src/fns.c index ac7c1f265a..4de74a5967 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1544,25 +1544,23 @@ list. Write `(setq foo (delq element foo))' to be sure of correctly changing the value of a list `foo'. See also `remq', which does not modify the argument. */) - (register Lisp_Object elt, Lisp_Object list) + (Lisp_Object elt, Lisp_Object list) { - Lisp_Object tail, tortoise, prev = Qnil; - bool skip; + Lisp_Object prev = Qnil; - FOR_EACH_TAIL (tail, list, tortoise, skip) + FOR_EACH_TAIL (list) { - Lisp_Object tem = XCAR (tail); + Lisp_Object tem = XCAR (li.tail); if (EQ (elt, tem)) { if (NILP (prev)) - list = XCDR (tail); + list = XCDR (li.tail); else - Fsetcdr (prev, XCDR (tail)); + Fsetcdr (prev, XCDR (li.tail)); } else - prev = tail; + prev = li.tail; } - CHECK_LIST_END (tail, list); return list; } diff --git a/src/lisp.h b/src/lisp.h index a9011b4a8b..102e8bd70e 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3317,6 +3317,7 @@ extern struct Lisp_Symbol *indirect_variable (struct Lisp_Symbol *); extern _Noreturn void args_out_of_range (Lisp_Object, Lisp_Object); extern _Noreturn void args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); +extern _Noreturn void circular_list (Lisp_Object); extern Lisp_Object do_symval_forwarding (union Lisp_Fwd *); enum Set_Internal_Bind { SET_INTERNAL_SET, @@ -4585,20 +4586,25 @@ enum Lisp_String)) \ : make_unibyte_string (str, len)) -/* Loop over all tails of a list, checking for cycles. - FIXME: Make tortoise and n internal declarations. - FIXME: Unroll the loop body so we don't need `n'. */ -#define FOR_EACH_TAIL(hare, list, tortoise, n) \ - for ((tortoise) = (hare) = (list), (n) = true; \ - CONSP (hare); \ - (hare = XCDR (hare), (n) = !(n), \ - ((n) \ - ? (EQ (hare, tortoise) \ - ? xsignal1 (Qcircular_list, list) \ - : (void) 0) \ - /* Move tortoise before the next iteration, in case */ \ - /* the next iteration does an Fsetcdr. */ \ - : (void) ((tortoise) = XCDR (tortoise))))) +/* Loop over tails of LIST, checking for dotted lists and cycles. + In the loop body, ‘li.tail’ is the current cons; the name ‘li’ is + short for “list iterator”. The expression LIST may be evaluated + more than once, and so should not have side effects. The loop body + should not modify the list’s top level structure other than by + perhaps deleting the current cons. + + Use Brent’s teleporting tortoise-hare algorithm. See: + Brent RP. BIT. 1980;20(2):176-84. doi:10.1007/BF01933190 + http://maths-people.anu.edu.au/~brent/pd/rpb051i.pdf */ + +#define FOR_EACH_TAIL(list) \ + for (struct { Lisp_Object tail, tortoise; intptr_t n, max; } li \ + = { list, list, 2, 2 }; \ + CONSP (li.tail) || (CHECK_LIST_END (li.tail, list), false); \ + (li.tail = XCDR (li.tail), \ + (li.n-- == 0 \ + ? (void) (li.n = li.max <<= 1, li.tortoise = li.tail) \ + : EQ (li.tail, li.tortoise) ? circular_list (list) : (void) 0))) /* Do a `for' loop over alist values. */ commit 5e222f673717718cd0ee209487cc06637bd142fc Author: Simen Heggestøyl Date: Sun Feb 5 22:17:41 2017 +0100 * lisp/textmodes/css-mode.el: Require subr-x at compile time diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 0c7d76f792..19746c68e6 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -36,7 +36,7 @@ (require 'seq) (require 'sgml-mode) (require 'smie) -(require 'subr-x) +(eval-when-compile (require 'subr-x)) (defgroup css nil "Cascading Style Sheets (CSS) editing mode."