summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2024-02-08 21:16:11 -0800
committerKaz Kylheku <kaz@kylheku.com>2024-02-08 21:16:11 -0800
commitf85a58da998088496c3cb0d3370a35934646ade9 (patch)
treeed74d14093785f22f28faeb12740cbc781b6d54f
parent82cfcfdd91fb1cd8356fd6aaa537d329ecc3b78f (diff)
downloadtxr-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.tl18
-rw-r--r--tests/011/patmatch.tl10
-rw-r--r--txr.13
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)
diff --git a/txr.1 b/txr.1
index c6dfe829..3d02e35d 100644
--- a/txr.1
+++ b/txr.1
@@ -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