From 49e6d4d9651f706c517c65e14b00b8a233c59aa1 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 21 Jan 2021 21:00:12 -0800
Subject: 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.
---
 share/txr/stdlib/match.tl | 18 ++++++++++--------
 tests/011/patmatch.tl     |  4 ++++
 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))
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 *)
-- 
cgit v1.2.3