Mercurial > hg > xemacs-beta
changeset 5852:e9bb3688e654
Fix some bugs in #'substitute, #'nsubstitute.
src/ChangeLog addition:
2015-03-04 Aidan Kehoe <kehoea@parhasard.net>
* sequence.c (count_with_tail):
Accept COUNT from #'substitute, #'nsubstitute too.
* sequence.c (FdeleteX):
Only remove COUNT from the arguments if FROM-END is non-nil.
* sequence.c (Fnsubstitute):
Remove COUNT from the arguments if specified and FROM-END is
non-nil.
* sequence.c (Fsubstitute):
Remove COUNT from the arguments if specified and FROM-END is
non-nil. Do this before calling count_with_tail(). When we
encounter the cons return by count_with_tail(), use the
replacement object.
tests/ChangeLog addition:
2015-03-04 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Add some tests for #'substitute.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 04 Mar 2015 15:54:00 +0000 |
| parents | eabf763bc6f9 |
| children | 1044acf60048 |
| files | src/ChangeLog src/sequence.c tests/ChangeLog tests/automated/lisp-tests.el |
| diffstat | 4 files changed, 229 insertions(+), 78 deletions(-) [+] |
line wrap: on
line diff
--- a/src/ChangeLog Sat Feb 28 17:06:40 2015 -0800 +++ b/src/ChangeLog Wed Mar 04 15:54:00 2015 +0000 @@ -1,3 +1,18 @@ +2015-03-04 Aidan Kehoe <kehoea@parhasard.net> + + * sequence.c (count_with_tail): + Accept COUNT from #'substitute, #'nsubstitute too. + * sequence.c (FdeleteX): + Only remove COUNT from the arguments if FROM-END is non-nil. + * sequence.c (Fnsubstitute): + Remove COUNT from the arguments if specified and FROM-END is + non-nil. + * sequence.c (Fsubstitute): + Remove COUNT from the arguments if specified and FROM-END is + non-nil. Do this before calling count_with_tail(). When we + encounter the cons return by count_with_tail(), use the + replacement object. + 2015-01-08 Stephen J. Turnbull <stephen@xemacs.org> Fix progress bar crashes.
--- a/src/sequence.c Sat Feb 28 17:06:40 2015 -0800 +++ b/src/sequence.c Wed Mar 04 15:54:00 2015 +0000 @@ -710,9 +710,6 @@ /* Our callers should have filtered out non-positive COUNT. */ assert (counting >= 0); - /* And we're not prepared to handle COUNT from any other caller at the - moment. */ - assert (EQ (caller, QremoveX)|| EQ (caller, QdeleteX)); } check_test = get_check_test_function (item, &test, test_not, if_, if_not, @@ -1878,7 +1875,7 @@ PARSE_KEYWORDS (FdeleteX, nargs, args, 9, (test, if_not, if_, test_not, key, start, end, from_end, - count), (start = Qzero, count = Qunbound)); + count), (start = Qzero)); CHECK_SEQUENCE (sequence); CHECK_NATNUM (start); @@ -1890,45 +1887,41 @@ ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end); } - if (!UNBOUNDP (count)) - { - if (!NILP (count)) - { - CHECK_INTEGER (count); - if (FIXNUMP (count)) - { - counting = XFIXNUM (count); - } + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (FIXNUMP (count)) + { + counting = XFIXNUM (count); + } #ifdef HAVE_BIGNUM - else - { - counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? - 1 + MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM - 1; - } + else + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM - 1; + } #endif - - if (counting < 1) - { - return sequence; - } - - if (!NILP (from_end)) + if (counting < 1) + { + return sequence; + } + + if (!NILP (from_end)) + { + /* Sigh, this is inelegant. Force count_with_tail () to ignore + the count keyword, so we get the actual number of matching + elements, and can start removing from the beginning for the + from-end case. */ + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args; + ii < nargs; ii += 2) { - /* Sigh, this is inelegant. Force count_with_tail () to ignore - the count keyword, so we get the actual number of matching - elements, and can start removing from the beginning for the - from-end case. */ - for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args; - ii < nargs; ii += 2) + if (EQ (args[ii], Q_count)) { - if (EQ (args[ii], Q_count)) - { - args[ii + 1] = Qnil; - break; - } + args[ii + 1] = Qnil; + break; } - ii = 0; } + ii = 0; } } @@ -5797,6 +5790,20 @@ { return sequence; } + + if (!NILP (from_end)) + { + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (Fnsubstitute))->min_args; + ii < nargs; ii += 2) + { + if (EQ (args[ii], Q_count)) + { + args[ii + 1] = Qnil; + break; + } + } + ii = 0; + } } check_test = get_check_test_function (item, &test, test_not, if_, if_not, @@ -6015,16 +6022,16 @@ { Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil; Lisp_Object result = Qnil, result_tail = Qnil; - Lisp_Object object, position0, matched_count; + Lisp_Object object, position0, matched; Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0; - Elemcount ii = 0, counting = MOST_POSITIVE_FIXNUM, presenting = 0; + Elemcount ii = 0, counting = MOST_POSITIVE_FIXNUM, skipping = 0; Boolint test_not_unboundp = 1; check_test_func_t check_test = NULL; struct gcpro gcpro1; PARSE_KEYWORDS (Fsubstitute, nargs, args, 9, (test, if_, if_not, test_not, key, start, end, count, - from_end), (start = Qzero, count = Qunbound)); + from_end), (start = Qzero)); CHECK_SEQUENCE (sequence); @@ -6040,30 +6047,6 @@ check_test = get_check_test_function (item, &test, test_not, if_, if_not, key, &test_not_unboundp); - if (!UNBOUNDP (count)) - { - if (!NILP (count)) - { - CHECK_INTEGER (count); - if (FIXNUMP (count)) - { - counting = XFIXNUM (count); - } -#ifdef HAVE_BIGNUM - else - { - counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? - 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM; - } -#endif - - if (counting <= 0) - { - return sequence; - } - } - } - if (!CONSP (sequence)) { position0 = position (&object, item, sequence, check_test, @@ -6081,17 +6064,62 @@ } } - matched_count = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute); - - if (ZEROP (matched_count)) + if (!NILP (count)) + { + CHECK_INTEGER (count); + if (FIXNUMP (count)) + { + counting = XFIXNUM (count); + } +#ifdef HAVE_BIGNUM + else + { + counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ? + 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM; + } +#endif + + if (counting <= 0) + { + return sequence; + } + + /* Sigh, this is inelegant. Force count_with_tail () to ignore the count + keyword, so we get the actual number of matching elements, and can + start removing from the beginning for the from-end case. */ + if (!NILP (from_end)) + { + for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (Fsubstitute))->min_args; + ii < nargs; ii += 2) + { + if (EQ (args[ii], Q_count)) + { + args[ii + 1] = Qnil; + break; + } + } + ii = 0; + } + } + + matched = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute); + + if (ZEROP (matched)) { return sequence; } if (!NILP (count) && !NILP (from_end)) { - presenting = XFIXNUM (matched_count); - presenting = presenting <= counting ? 0 : presenting - counting; + Elemcount matching = XFIXNUM (matched); + if (matching > counting) + { + /* skipping is the number of elements to be skipped before we start + substituting. It is for those cases where both :count and + :from-end are specified, and the number of elements present is + greater than that limit specified with :count. */ + skipping = matching - counting; + } } GCPRO1 (result); @@ -6100,20 +6128,32 @@ { if (EQ (tail, tailing)) { + /* No need to do check_test, we're sure that this element matches + because its cons is what count_with_tail returned as the + tail. */ + if (skipping ? encountered >= skipping : encountered < counting) + { + if (NILP (result)) + { + result = Fcons (new_, XCDR (tail)); + } + else + { + XSETCDR (result_tail, Fcons (new_, XCDR (tail))); + } + } + else + { + XSETCDR (result_tail, tail); + } + XUNGCPRO (elt); UNGCPRO; - - if (NILP (result)) - { - return XCDR (tail); - } - - XSETCDR (result_tail, XCDR (tail)); - return result; + return result; } else if (starting <= ii && ii < ending && (check_test (test, key, item, elt) == test_not_unboundp) - && (presenting ? encountered++ >= presenting + && (skipping ? encountered++ >= skipping : encountered++ < counting)) { if (NILP (result))
--- a/tests/ChangeLog Sat Feb 28 17:06:40 2015 -0800 +++ b/tests/ChangeLog Wed Mar 04 15:54:00 2015 +0000 @@ -1,3 +1,8 @@ +2015-03-04 Aidan Kehoe <kehoea@parhasard.net> + + * automated/lisp-tests.el: + Add some tests for #'substitute. + 2014-10-11 Stephen J. Turnbull <stephen@xemacs.org> * automated/keymap-tests.el:
--- a/tests/automated/lisp-tests.el Sat Feb 28 17:06:40 2015 -0800 +++ b/tests/automated/lisp-tests.el Wed Mar 04 15:54:00 2015 +0000 @@ -2988,6 +2988,97 @@ (Check-Error wrong-number-of-arguments (funcall list-and-four 7 8 9 10))) +;; Test #'substitute. Paul Dietz has much more comprehensive tests. + +(Assert (equal (substitute 'a 'b '(a b c d e f g)) '(a a c d e f g))) +(Assert (equal (substitute 'a 'b '(a b c d e b f g) :from-end t :count 1) + '(a b c d e a f g))) + +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :count nil))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :key nil))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :count 100))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :count 0))) + (and (equal nomodif x) y)) + '(a b c a b d a c b a e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :count 1))) + (and (equal nomodif x) y)) + '(z b c a b d a c b a e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'c x :count 1))) + (and (equal nomodif x) y)) + '(a b z a b d a c b a e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :from-end t))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :from-end t :count 1))) + (and (equal nomodif x) y)) + '(a b c a b d a c b z e))) +(Assert (equal (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif)) + (y (substitute 'z 'a x :from-end t :count 4))) + (and (equal nomodif x) y)) + '(z b c z b d z c b z e))) +(Assert (equal (multiple-value-list + (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif))) + (values + (loop for i from 0 to 10 + collect (substitute 'z 'a x :start i)) + (equal nomodif x)))) + '(((z b c z b d z c b z e) (a b c z b d z c b z e) + (a b c z b d z c b z e) (a b c z b d z c b z e) + (a b c a b d z c b z e) (a b c a b d z c b z e) + (a b c a b d z c b z e) (a b c a b d a c b z e) + (a b c a b d a c b z e) (a b c a b d a c b z e) + (a b c a b d a c b a e)) + t))) +(Assert (equal (multiple-value-list + (let* ((nomodif '(a b c a b d a c b a e)) + (x (copy-list nomodif))) + (values + (loop for i from 0 to 10 + collect (substitute 'z 'a x :start i :end nil)) + (equal nomodif x)))) + '(((z b c z b d z c b z e) (a b c z b d z c b z e) + (a b c z b d z c b z e) (a b c z b d z c b z e) + (a b c a b d z c b z e) (a b c a b d z c b z e) + (a b c a b d z c b z e) (a b c a b d a c b z e) + (a b c a b d a c b z e) (a b c a b d a c b z e) + (a b c a b d a c b a e)) + t))) +(Assert (equal + (let* ((nomodif '(1 2 3 2 6 1 2 4 1 3 2 7)) + (x (copy-list nomodif)) + (y (substitute 300 1 x :key #'1-))) + (and (equal nomodif x) y)) + '(1 300 3 300 6 1 300 4 1 3 300 7))) + ;; Test labels and inlining. (labels ((+ (&rest arguments)