diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-01-21 21:00:12 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-01-21 21:00:12 -0800 |
commit | 49e6d4d9651f706c517c65e14b00b8a233c59aa1 (patch) | |
tree | c4f3e0b58f77854ad4e450d558cb255b59e4bf7d | |
parent | 143a9df7c48235a16c8c41a92281701bd5d8c2ff (diff) | |
download | txr-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.tl | 18 | ||||
-rw-r--r-- | tests/011/patmatch.tl | 4 | ||||
-rw-r--r-- | txr.1 | 30 |
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)) @@ -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 *) |