Mercurial > hg > xemacs-beta
changeset 5241:d579d76f3dcc
Be more careful about side-effects from Lisp code, #'reduce
src/ChangeLog addition:
2010-07-24 Aidan Kehoe <kehoea@parhasard.net>
* lisp.h (PARSE_KEYWORDS):
Always accept a nil :allow-other-keys keyword argument, as
described in the ALLOW-OTHER-KEYS-NIL Common Lisp issue writeup,
and as necessary for Paul Dietz' tests for #'reduce.
* fns.c (mapping_interaction_error): New.
(Freduce): Call mapping_interaction_error when KEY or FUNCTION
have modified a string SEQUENCE such that the byte length of the
string has changed, or such that the current cursor pointer
doesn't point to the beginning of a character.
Cf. the MAPPING-DESTRUCTIVE-INTERACTION Common Lisp issue
writeup.
When traversing a list, GCPRO the part of it we still have to
traverse, to avoid any crashes if FUNCTION or KEY amputate it
behind us and force a garbage collection.
tests/ChangeLog addition:
2010-07-24 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test a couple of things #'reduce was just made more careful
about.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 24 Jul 2010 15:56:57 +0100 |
| parents | fca0cf0971de |
| children | f3eca926258e |
| files | src/ChangeLog src/fns.c src/lisp.h tests/ChangeLog tests/automated/lisp-tests.el |
| diffstat | 5 files changed, 121 insertions(+), 17 deletions(-) [+] |
line wrap: on
line diff
--- a/src/ChangeLog Tue Jul 13 10:20:22 2010 +0200 +++ b/src/ChangeLog Sat Jul 24 15:56:57 2010 +0100 @@ -1,3 +1,21 @@ +2010-07-24 Aidan Kehoe <kehoea@parhasard.net> + + * lisp.h (PARSE_KEYWORDS): + Always accept a nil :allow-other-keys keyword argument, as + described in the ALLOW-OTHER-KEYS-NIL Common Lisp issue writeup, + and as necessary for Paul Dietz' tests for #'reduce. + + * fns.c (mapping_interaction_error): New. + (Freduce): Call mapping_interaction_error when KEY or FUNCTION + have modified a string SEQUENCE such that the byte length of the + string has changed, or such that the current cursor pointer + doesn't point to the beginning of a character. + Cf. the MAPPING-DESTRUCTIVE-INTERACTION Common Lisp issue + writeup. + When traversing a list, GCPRO the part of it we still have to + traverse, to avoid any crashes if FUNCTION or KEY amputate it + behind us and force a garbage collection. + 2010-06-05 Marcus Crestani <crestani@informatik.uni-tuebingen.de> * gc.c:
--- a/src/fns.c Tue Jul 13 10:20:22 2010 +0200 +++ b/src/fns.c Sat Jul 24 15:56:57 2010 +0100 @@ -65,6 +65,12 @@ static int internal_old_equal (Lisp_Object, Lisp_Object, int); Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth); +static DOESNT_RETURN +mapping_interaction_error (Lisp_Object func, Lisp_Object object) +{ + invalid_state_2 ("object modified while traversing it", func, object); +} + static Lisp_Object mark_bit_vector (Lisp_Object UNUSED (obj)) { @@ -4995,21 +5001,31 @@ starting++; startp = XSTRING_DATA (sequence); cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + INC_IBYTEPTR (cursor); cursor_offset = cursor - startp; } while (cursor_offset < byte_len && starting < ending) { - if (cursor_offset > XSTRING_LENGTH (sequence)) + accum = call2 (function, accum, + KEY (key, make_char (itext_ichar (cursor)))); + + startp = XSTRING_DATA (sequence); + cursor = startp + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) { - invalid_state ("sequence modified during reduce", sequence); + mapping_interaction_error (Qreduce, sequence); } - startp = XSTRING_DATA (sequence); - cursor = startp + cursor_offset; - accum = call2 (function, accum, - KEY (key, make_char (itext_ichar (cursor)))); INC_IBYTEPTR (cursor); cursor_offset = cursor - startp; ++starting; @@ -5018,7 +5034,7 @@ else { Elemcount len = string_char_length (sequence); - Bytecount cursor_offset; + Bytecount cursor_offset, byte_len = XSTRING_LENGTH (sequence); const Ibyte *cursor; ending = min (ending, len); @@ -5035,6 +5051,13 @@ ending--; if (ending > 0) { + cursor = XSTRING_DATA (sequence) + cursor_offset; + + if (!valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + DEC_IBYTEPTR (cursor); cursor_offset = cursor - XSTRING_DATA (sequence); } @@ -5042,18 +5065,19 @@ for (ii = ending - 1; ii >= starting; --ii) { - if (cursor_offset > XSTRING_LENGTH (sequence)) - { - invalid_state ("sequence modified during reduce", sequence); - } - - cursor = XSTRING_DATA (sequence) + cursor_offset; accum = call2 (function, KEY (key, make_char (itext_ichar (cursor))), accum); - if (ii > 1) + if (ii > 0) { cursor = XSTRING_DATA (sequence) + cursor_offset; + + if (byte_len != XSTRING_LENGTH (sequence) + || !valid_ibyteptr_p (cursor)) + { + mapping_interaction_error (Qreduce, sequence); + } + DEC_IBYTEPTR (cursor); cursor_offset = cursor - XSTRING_DATA (sequence); } @@ -5064,6 +5088,11 @@ { if (NILP (from_end)) { + struct gcpro gcpro1; + Lisp_Object tailed = Qnil; + + GCPRO1 (tailed); + if (!UNBOUNDP (initial_value)) { accum = initial_value; @@ -5073,6 +5102,9 @@ Elemcount counting = 0; EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { + /* KEY may amputate the list behind us; make sure what + remains to be processed is still reachable. */ + tailed = tail; if (counting == starting) { accum = KEY (key, elt); @@ -5089,6 +5121,10 @@ EXTERNAL_LIST_LOOP_3 (elt, sequence, tail) { + /* KEY or FUNCTION may amputate the list behind us; make + sure what remains to be processed is still + reachable. */ + tailed = tail; if (counting >= starting) { if (counting < ending) @@ -5103,6 +5139,8 @@ ++counting; } } + + UNGCPRO; } else {
--- a/src/lisp.h Tue Jul 13 10:20:22 2010 +0200 +++ b/src/lisp.h Sat Jul 24 15:56:57 2010 +0100 @@ -3577,9 +3577,18 @@ { \ continue; \ } \ - else if (!(pk_allow_other_keys \ - = non_nil_allow_other_keys_p (keywords_offset, \ - nargs, args))) \ + else if ((pk_allow_other_keys \ + = non_nil_allow_other_keys_p (keywords_offset, \ + nargs, args))) \ + { \ + continue; \ + } \ + else if (EQ (pk_key, Q_allow_other_keys) && \ + NILP (pk_value)) \ + { \ + continue; \ + } \ + else \ { \ invalid_keyword_argument (function, pk_key); \ } \
--- a/tests/ChangeLog Tue Jul 13 10:20:22 2010 +0200 +++ b/tests/ChangeLog Sat Jul 24 15:56:57 2010 +0100 @@ -1,3 +1,9 @@ +2010-07-24 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Test a couple of things #'reduce was just made more careful + about. + 2010-06-13 Stephen J. Turnbull <stephen@xemacs.org> * gtk/event-stream-tests.el:
--- a/tests/automated/lisp-tests.el Tue Jul 13 10:20:22 2010 +0200 +++ b/tests/automated/lisp-tests.el Sat Jul 24 15:56:57 2010 +0100 @@ -2341,4 +2341,37 @@ (gethash hashed-bignum hashing)) "checking hashing works correctly with #'eql tests and bignums")))) +;; +(when (decode-char 'ucs #x0192) + (Check-Error + invalid-state + (let ((str "aaaaaaaaaaaaa") + (called 0) + modified) + (reduce #'+ str + :key #'(lambda (object) + (prog1 + object + (incf called) + (or modified + (and (> called 5) + (setq modified + (fill str (read #r"?\u0192"))))))))))) + +(Assert + (eql 55 + (let ((sequence '(1 2 3 4 5 6 7 8 9 10)) + (called 0) + modified) + (reduce #'+ + sequence + :key + #'(lambda (object) (prog1 + object + (incf called) + (and (eql called 5) + (setcdr (nthcdr 3 sequence) nil)) + (garbage-collect)))))) + "checking we can amputate lists without crashing #'reduce") + ;;; end of lisp-tests.el