diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2024-02-08 21:16:11 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2024-02-08 21:16:11 -0800 |
commit | f85a58da998088496c3cb0d3370a35934646ade9 (patch) | |
tree | ed74d14093785f22f28faeb12740cbc781b6d54f | |
parent | 82cfcfdd91fb1cd8356fd6aaa537d329ecc3b78f (diff) | |
download | txr-f85a58da998088496c3cb0d3370a35934646ade9.tar.gz txr-f85a58da998088496c3cb0d3370a35934646ade9.tar.bz2 txr-f85a58da998088496c3cb0d3370a35934646ade9.zip |
match: remove bad restriction from @(sme) and @(end).
The end pattern in @(sme) and @(end) does not have to be a
list pattern, dotted or otherwise. It should support any
pattern whatsoever for a single object, which should match the
terminating atom. The documentation says that, though not very
clearly; it is reworded also.
* stdlib/match.tl (check-end): Remove this function, since
the end pattern can be any pattern.
(pat-len): Bugfix: we are using the meq function incorrectly.
The object being compared against several alternatives
must be the leftmost argument of meq. This bug prevents a
pattern like @(evenp @x) to be correctly considered of
length zero.
(sme, end): Remove calls to check-end, and just refer to
original end variable.
* tests/011/patmatch.tl: New tests.
* txr.1: clarify that the end pattern may be any pattern,
which can match just the terminating atom or a possibly
dotted suffix.
-rw-r--r-- | stdlib/match.tl | 18 | ||||
-rw-r--r-- | tests/011/patmatch.tl | 10 | ||||
-rw-r--r-- | txr.1 | 3 |
3 files changed, 17 insertions, 14 deletions
diff --git a/stdlib/match.tl b/stdlib/match.tl index e535ec45..12479fab 100644 --- a/stdlib/match.tl +++ b/stdlib/match.tl @@ -895,12 +895,6 @@ (compile-error f "~s: list pattern expected, not ~s" op pat) pat)) -(defun check-end (f op pat) - (if (and (listp pat) - (meq (car pat) 'sys:expr 'sys:var 'sys:quasi)) - (compile-error f "~s: list or atom pattern expected, not ~s" op pat) - pat)) - (defun check-sym (f op sym : nil-ok) (cond ((bindable sym) sym) @@ -914,7 +908,7 @@ (defun pat-len (pat) (if (consp pat) - (let ((var-op-pos (pos-if (op meq 'sys:var 'sys:expr 'sys:quasi) + (let ((var-op-pos (pos-if (lop meq 'sys:var 'sys:expr 'sys:quasi) (butlastn 0 pat)))) (if var-op-pos var-op-pos (len pat))) 0)) @@ -922,24 +916,22 @@ (defmatch sme (:form f sta mid end : (mvar (gensym)) eobj) (let* ((psta (loosen (check f 'sme sta))) (pmid (loosen (check f 'sme mid))) - (pend (check-end f 'sme end)) (lsta (pat-len psta)) (lmid (pat-len pmid)) - (lend (pat-len pend)) + (lend (pat-len end)) (obj (gensym))) ^@(as ,(check-sym f 'sme obj) @(and ,psta @(with @(scan @(as ,(check-sym f 'sme mvar) ,pmid)) (nthcdr ,lsta ,obj)) - @(with @(as ,(check-sym f 'sme eobj t) ,pend) + @(with @(as ,(check-sym f 'sme eobj t) ,end) (nthlast ,lend (nthcdr ,lmid ,mvar))))))) (defmatch end (:form f end : evar) - (let* ((pend (check-end f 'end end)) - (lend (pat-len pend)) + (let* ((lend (pat-len end)) (obj (gensym))) ^@(as ,(check-sym f 'end obj) - @(with @(as ,(check-sym f 'end evar t) ,pend) + @(with @(as ,(check-sym f 'end evar t) ,end) (nthlast ,lend ,obj))))) (defun non-triv-pat-p (syntax) diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl index bb67e32e..6d071f3d 100644 --- a/tests/011/patmatch.tl +++ b/tests/011/patmatch.tl @@ -602,6 +602,16 @@ (match @gs 0 gs) :error (match @gs :gs gs) :gs) +(mtest + (match @(end @x) '(1 . 2) x) 2 + (match @(end @(evenp @x)) '(1 . 2) x) 2 + (match @(end (@z . @x)) '(1 . 2) (list z x)) (1 2) + (match @(end (@z . @(evenp @x))) '(1 . 2) (list z x)) (1 2)) + +(mtest + (match @(sme (@a) (@b) @x) '(0 1 . 2) (list a b x)) (0 1 2) + (match @(sme (@a) (@b) @(evenp @x)) '(0 1 . 2) (list a b x)) (0 1 2)) + (compile-only (eval-only (with-compile-opts (nil unused) @@ -47579,7 +47579,8 @@ and must be possibly dotted list patterns. The last pattern, .metn epat , -must be either an atom or a possibly dotted list pattern. +may be any pattern: it may be an atom match for the terminating +atom, or a possibly dotted list pattern matching the list suffix. Important to the semantics of .code sme |