From d1b7254ee6bf59b6ff6a97134f10061cf8090b29 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sun, 18 Apr 2021 16:58:06 -0700
Subject: 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.
---
share/txr/stdlib/doc-syms.tl | 3 ++-
share/txr/stdlib/match.tl | 21 +++++++++++++++++++++
2 files changed, 23 insertions(+), 1 deletion(-)
(limited to 'share')
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]))
--
cgit v1.2.3