summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-01-21 21:00:12 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-01-21 21:00:12 -0800
commit49e6d4d9651f706c517c65e14b00b8a233c59aa1 (patch)
treec4f3e0b58f77854ad4e450d558cb255b59e4bf7d
parent143a9df7c48235a16c8c41a92281701bd5d8c2ff (diff)
downloadtxr-49e6d4d9651f706c517c65e14b00b8a233c59aa1.tar.gz
txr-49e6d4d9651f706c517c65e14b00b8a233c59aa1.tar.bz2
txr-49e6d4d9651f706c517c65e14b00b8a233c59aa1.zip
matcher: new @(coll) operator.
* share/txr/stdlib/match.tl (compile-loop-match): Implement coll semantics. coll fails if it collects nothing, which uses common logic with all*. We just have to move the flipping of the loop-iterated-var into the match, and not do it unconditionally for every iteration. (compile-match): Hook in the coll operator. * tests/011/patmatch.tl: Test case copied from doc example. * txr.1: Documented.
-rw-r--r--share/txr/stdlib/match.tl18
-rw-r--r--tests/011/patmatch.tl4
-rw-r--r--txr.130
3 files changed, 43 insertions, 9 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 55d9d6ef..9d7c1ba1 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -217,42 +217,43 @@
(defun compile-loop-match (exp obj-var var-list)
(mac-param-bind *match-form* (op match) exp
- (let* ((all*-p (eq op 'usr:all*))
+ (let* ((no-vac-p (memq op '(coll usr:all*)))
(some-p (eq op 'some))
+ (coll-p (eq op 'coll))
(item-var (gensym "item-"))
(cm (compile-match match item-var var-list))
(loop-success-p-var (gensym "loop-success-p-"))
(loop-continue-p-var (gensym "loop-terminate-p"))
- (loop-iterated-var (if all*-p (gensym "loop-iterated-p")))
+ (loop-iterated-var (if no-vac-p (gensym "loop-iterated-p")))
(matched-p-var (gensym "matched-p-"))
(iter-var (gensym "iter-"))
(collect-vars [mapcar gensym cm.vars])
(loop ^(for ((,iter-var (iter-begin ,obj-var))
(,loop-continue-p-var t)
- ,*(if all*-p ^((,loop-iterated-var nil))))
+ ,*(if no-vac-p ^((,loop-iterated-var nil))))
((and ,loop-continue-p-var (iter-more ,iter-var))
,(cond
(some-p ^(not ,loop-continue-p-var))
- (all*-p ^(and ,loop-iterated-var
+ (no-vac-p ^(and ,loop-iterated-var
,loop-continue-p-var))
(t loop-continue-p-var)))
((set ,iter-var (iter-step ,iter-var)))
(let ((,cm.obj-var (iter-item ,iter-var))
,matched-p-var
,*(if some-p cm.(get-temps) cm.(get-vars)))
- ,*(if all*-p
- ^((set ,loop-iterated-var t)))
,cm.(wrap-guards
^(progn ,*cm.(assignments)
(if ,cm.test-expr
(progn
(set ,matched-p-var t)
+ ,*(if no-vac-p
+ ^((set ,loop-iterated-var t)))
,*(unless some-p
(mapcar (ret ^(push ,@1 ,@2))
cm.vars
collect-vars))))))
- (,(if some-p 'when 'unless) ,matched-p-var
- (set ,loop-continue-p-var nil)))))
+ ,(unless coll-p ^(,(if some-p 'when 'unless) ,matched-p-var
+ (set ,loop-continue-p-var nil))))))
(guard (new match-guard
vars (append cm.vars (unless some-p collect-vars))
guard-expr ^(seqp ,obj-var))))
@@ -323,6 +324,7 @@
(all (compile-loop-match exp obj-var var-list))
(usr:all* (compile-loop-match exp obj-var var-list))
(some (compile-loop-match exp obj-var var-list))
+ (coll (compile-loop-match exp obj-var var-list))
(or (compile-parallel-match exp obj-var var-list))
(and (compile-parallel-match exp obj-var var-list))
(not (compile-not-match exp obj-var var-list))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index 493f4b2d..11a6a933 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -58,6 +58,10 @@
(list a b))
(2 b))
+(test (when-match @(coll (x @a @b)) '((y 1 a) (x 2 b) (z 3 c) (x 4 d))
+ (list a b))
+ ((2 4) (b d)))
+
(test (if-match @(and (@x 2 3) (1 @y 3) (1 2 @z)) '(1 2 3)
(list x y z))
(1 2 3))
diff --git a/txr.1 b/txr.1
index ce6f045f..5fbf346f 100644
--- a/txr.1
+++ b/txr.1
@@ -40109,7 +40109,7 @@ The specified
.meta pattern
is applied against every element of the sequence. The match is successful if
.meta pattern
-finds a matching element.
+matches at least one element.
Variables are extracted from the first matching which is found.
@@ -40125,6 +40125,34 @@ Variables are extracted from the first matching which is found.
-> (2 b)
.brev
+.coNP Pattern operator @ coll
+.synb
+.mets @(coll << pattern )
+.syne
+.desc
+The
+.code coll
+pattern operator requires the corresponding object to be a sequence.
+The specified
+.meta pattern
+is applied against every element of the sequence. The match is successful if
+.meta pattern
+matches at least one element.
+
+Variables are extracted from all matching elements, and collected into
+parallel lists, just like with the
+.code @(all)
+operator.
+
+.TP* Example:
+
+.verb
+ (when-match @(coll (x @a @b))
+ '((y 1 a) (x 2 b) (z 3 c) (x 4 d))
+ (list a b))
+ -> ((2 4) (b d))
+.brev
+
.coNP Pattern operators @ and and @ or
.synb
.mets @(and << pattern *)