matcher: new looping macros.

* lisplib.c (match_set_entries): Autoload on new while-match,
while-match-case and while-true-match-case symbols.

* share/txr/stdlib/match.tl (while-match, while-match-case,
while-true-match-case): New macros.

* tests/011/patmatch.tl: Tests.

* txr.1: Documented.

* share/txr/stdlib/doc-syms.tl: Updated.

5 files changed, 163 insertions, 0 deletions

diff --git a/lisplib.c b/lisplib.c
index 9ca2773c..37b21ba0 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -882,6 +882,7 @@ static val match_set_entries(val dlt, val fun)
   };
   val name[] = {
     lit("when-match"), lit("match-case"), lit("if-match"),
+    lit("while-match"), lit("while-match-case"), lit("while-true-match-case"),
     lit("lambda-match"), lit("defun-match"), lit("defmatch"),
     lit("each-match"), lit("append-matches"),
     lit("keep-matches"), lit("each-match-product"),
diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl
index 31e71438..5bf473ee 100644
--- a/share/txr/stdlib/doc-syms.tl
+++ b/share/txr/stdlib/doc-syms.tl
@@ -2040,6 +2040,9 @@
       ("where" "N-0208F1DE")
       ("while" "N-01026F48")
       ("while*" "N-01F7BF0B")
+      ("while-match" "N-015B0AD0")
+      ("while-match-case" "N-007220BC")
+      ("while-true-match-case" "N-007220BC")
       ("whilet" "N-0154DC75")
       ("width" "D-0019")
       ("width-check" "N-01A9EA49")
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index baa65f0d..3502688b 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -643,6 +643,14 @@
            ,result
            ,else)))))
 
+(defmacro while-match (:form *match-form* :env e pat obj . body)
+  (let ((cm (compile-match pat : (get-var-list e))))
+    ^(for ()
+          ((alet ((,cm.obj-var ,obj))
+             (let ,cm.(get-vars)
+               ,cm.(wrap-guards ^(progn ,*body t)))))
+          ())))
+
 (defmacro match-case (:form *match-form* :env e obj . clauses)
   (unless [all clauses [andf proper-listp [chain len plusp]]]
     (compile-error *match-form* "bad clause syntax"))
@@ -666,6 +674,23 @@
          (or ,*clause-code)
          ,result-temp))))
 
+(defmacro while-match-case (:form *match-form* :env e obj . clauses)
+  (unless [all clauses [andf proper-listp [chain len plusp]]]
+    (compile-error *match-form* "bad clause syntax"))
+  ^(for ()
+        ((match-case ,obj
+           ,*(mapcar (ret ^(,(car @1) ,*(cdr @1) t)) clauses)))
+        ()))
+
+(defmacro while-true-match-case (:form *match-form* :env e obj . clauses)
+  (unless [all clauses [andf proper-listp [chain len plusp]]]
+    (compile-error *match-form* "bad clause syntax"))
+  ^(for ()
+        ((match-case ,obj
+           (nil)
+           ,*(mapcar (ret ^(,(car @1) ,*(cdr @1) t)) clauses)))
+        ()))
+
 (defmacro when-exprs-match (:form *match-form* :env e pats exprs . forms)
   (let ((em (compile-match ^@(exprs ,*pats) exprs (get-var-list e))))
     ^(let* (,*em.(get-vars))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index aea891c3..9647c52b 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -488,6 +488,31 @@
               datum) (42.0)
   (when-match ^#J{"foo" : {"x" : ~val}} #J{"foo" : {"x" : "y"}} val) "y")
 
+(test
+  (let ((a '(1 2 3 4)))
+    (build
+      (while-match @(true @x) (pop a)
+        (add (* 10 x)))))
+  (10 20 30 40))
+
+(test
+  (let ((a '(1 (2 3) 4 (5 6))))
+    (build
+      (while-match-case (pop a)
+        ((@x @y) (add :pair x y))
+        (@(numberp @x) (add :num x)))))
+  (:num 1 :pair 2 3 :num 4 :pair 5 6))
+
+(test
+  (let ((a '(1 (2 3) 4 (5 6))))
+    (build
+      (while-true-match-case (pop a)
+        ((@x @y) (add :pair x y))
+        (@(evenp @x) (add :even x))
+        (@(oddp @x) (add :odd x))
+        (@else (error "unhandled case")))))
+  (:odd 1 :pair 2 3 :even 4 :pair 5 6))
+
 (compile-only
   (eval-only
     (compile-file (base-name *load-path*) "temp.tlo")
diff --git a/txr.1 b/txr.1
index 79d3c78e..8aaed565 100644
--- a/txr.1
+++ b/txr.1
@@ -43599,6 +43599,115 @@ and
   --> ((1 2) (1 4) (3 2) (3 4) (5 2) (5 4))
 .brev
 
+.coNP Macro @ while-match
+.synb
+.mets (when-match < pattern < expr << form *)
+.syne
+.desc
+The
+.code while-match
+macro evaluates
+.meta expr
+and matches it against
+.meta pattern
+similarly to
+.codn when-match .
+
+If the match is successful, every
+.meta form
+is evaluated in an environment in which new bindings from
+.meta pattern
+are visible. In this case, the process repeats:
+.meta expr
+is evaluated again, and tested against
+.metn pattern .
+
+If the match fails,
+.code while-match
+terminates and produces
+.code nil
+as its result value.
+
+Each iteration produces fresh bindings for any variables
+that are implicated for binding in
+.metn pattern .
+
+The
+.meta expr
+and
+.meta form
+expressions are surrounded by an anonymous block.
+
+.coNP Macros @ while-match-case and @ while-true-match-case
+.synb
+.mets (while-match-case < expr >> {( pattern << form *)}*)
+.mets (while-true-match-case < expr >> {( pattern << form *)}*)
+.syne
+.desc
+The macros
+.code while-match-case
+and
+.code while-true-match-case
+combine iteration with the semantics of
+.codn match-case .
+
+The
+.code while-match-case
+evaluates
+.meta expr
+and matches it against zero or more clauses in the manner of
+.code match-case.
+If there is a match, this process is repeated.
+If there is no match,
+.code while-match-case
+terminates, and returns
+.codn nil .
+
+In each iteration, the matching clause produces fresh bindings for any
+variables implicated for binding in its respective
+.metn pattern .
+
+The
+.meta expr
+and
+.meta form
+expressions are surrounded by an anonymous block.
+
+The
+.code while-true-match-case
+macro is identical in almost every respect to
+.codn while-match-case ,
+except that it terminates the loop if
+.meta expr
+evaluates to
+.codn nil ,
+without attempting to match that value against the clauses.
+
+Note: the semantics of
+.code while-true-match-case
+can be obtained in
+.code while-match-case
+by inserting a
+.code return
+clause. That is to say, a construct of the form
+
+.verb
+  (while-true-match-case expr
+    ...)
+.brev
+
+may be rewritten into
+
+.verb
+  (while-match-case expr
+    (nil (return)) ;; match nil and return
+    ...)
+.brev
+
+except that
+.code while-true-match-case
+isn't required to rely on performing a block return.
+
 .SS* Quasiquote Operator Syntax
 .coNP Macro @ qquote
 .synb