carbon2-commit: Be more careful about side-effects from Lisp code, #'reduce

changeset: 5297:d579d76f3dcc user: Aidan Kehoe <kehoea(a)parhasard.net&gt; date: Sat Jul 24 15:56:57 2010 +0100 files: src/ChangeLog src/fns.c src/lisp.h tests/ChangeLog tests/automated/lisp-tests.el description: Be more careful about side-effects from Lisp code, #'reduce src/ChangeLog addition: 2010-07-24 Aidan Kehoe <kehoea(a)parhasard.net&gt; * 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(a)parhasard.net&gt; * automated/lisp-tests.el: Test a couple of things #'reduce was just made more careful about. diff -r fca0cf0971de -r d579d76f3dcc src/ChangeLog --- 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(a)parhasard.net&gt; + + * 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(a)informatik.uni-tuebingen.de&gt; * gc.c: diff -r fca0cf0971de -r d579d76f3dcc src/fns.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 ＠＠ -64,6 +64,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)) - { - invalid_state ("sequence modified during reduce", sequence); - } - - startp = XSTRING_DATA (sequence); - cursor = startp + cursor_offset; - accum = call2 (function, accum, + 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)) + { + mapping_interaction_error (Qreduce, sequence); + } + 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 { diff -r fca0cf0971de -r d579d76f3dcc src/lisp.h --- 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); \ } \ diff -r fca0cf0971de -r d579d76f3dcc tests/ChangeLog --- 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(a)parhasard.net&gt; + + * automated/lisp-tests.el: + Test a couple of things #'reduce was just made more careful + about. + 2010-06-13 Stephen J. Turnbull <stephen(a)xemacs.org&gt; * gtk/event-stream-tests.el: diff -r fca0cf0971de -r d579d76f3dcc tests/automated/lisp-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 _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches