matcher: new @(scan) operator.

* share/txr/stdlib/match.tl (compile-scan-match): New
function.
(compile-match): Hook scan operator into compiler.

* lisplib.c (match_set_entries): Ensure scan is interned in
usr package.

* txr.1: Documented.

* share/txr/stdlib/doc-syms.tl: Updated with new entry for
scan.

2 files changed, 23 insertions, 1 deletions

diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl
index 939976de..389ea679 100644
--- a/share/txr/stdlib/doc-syms.tl
+++ b/share/txr/stdlib/doc-syms.tl
@@ -1149,6 +1149,7 @@
      ("make-random-state" "N-032BEE6C")
      ("dir-name" "N-02C01721")
      ("rfind-if" "N-0301CDB6")
+     ("scan" "N-03E989D0")
      ("vmin" "N-01812D70")
      ("copy-list" "N-006ED237")
      ("sinh" "D-0045")
@@ -1473,10 +1474,10 @@
      ("tree-delete-node" "N-00772FAE")
      ("f-dupfd" "N-025E55E7")
      (":key" "N-01697547")
+     ("tostring" "N-02FCCE0D")
      ("succ" "N-038E636C")
      ("obtain" "N-01556613")
      ("hash-count" "N-00766C80")
-     ("tostring" "N-02FCCE0D")
      ("make-zstruct" "N-03855D2D")
      ("fnm-leading-dir" "N-0330E15A")
      ("enametoolong" "N-036B1BDB")
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index bfb0ef2a..d8af1baf 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -520,6 +520,26 @@
            obj-var obj-var
            guard-chain (cons guard (mappend .guard-chain hash-matches))))))
 
+(defun compile-scan-match (scan-syntax obj-var var-list)
+  (mac-param-bind *match-form* (op pattern) scan-syntax
+    (with-gensyms (iter found-p cont-p success-p)
+      (let* ((cm (compile-match pattern iter var-list))
+             (loop ^(for ((,iter ,obj-var) (,cont-p t) ,found-p)
+                         (,cont-p ,found-p)
+                         ((cond
+                            ((null ,cont-p))
+                            ((consp ,iter) (set ,iter (cdr ,iter)))
+                            (t (zap ,cont-p))))
+                       ,cm.(wrap-guards ^(set ,found-p t ,cont-p nil))))
+             (guard (new match-guard
+                         vars (cons success-p cm.(get-vars))
+                         var-exprs (list loop)
+                         test-expr success-p)))
+      (new compiled-match
+           pattern scan-syntax
+           obj-var obj-var
+           guard-chain (list guard))))))
+
 (defun compile-exprs-match (exprs-syntax uexprs var-list)
   (let ((upats (cdr exprs-syntax))
         (utemps (mapcar (ret (gensym)) uexprs)))
@@ -557,6 +577,7 @@
                    (and (compile-and-match exp obj-var var-list))
                    (not (compile-not-match exp obj-var var-list))
                    (hash (compile-hash-match exp obj-var var-list))
+                   (usr:scan (compile-scan-match exp obj-var var-list))
                    (exprs (compile-exprs-match exp obj-var var-list))
                    (t (iflet ((xfun [*match-macro* op]))
                         (let ((xexp [xfun exp]))