diff options
| -rw-r--r-- | lisplib.c | 2 | ||||
| -rw-r--r-- | share/txr/stdlib/doc-syms.tl | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/match.tl | 21 | ||||
| -rw-r--r-- | txr.1 | 64 |
4 files changed, 88 insertions, 2 deletions
@@ -871,7 +871,7 @@ static val match_instantiate(val set_fun) static val match_set_entries(val dlt, val fun) { val name_noload[] = { - lit("all*"), lit("as"), lit("with"), + lit("all*"), lit("as"), lit("with"), lit("scan"), nil }; val name[] = { 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])) @@ -41041,6 +41041,70 @@ operator. -> ((2 4) (b d)) .brev +.coNP Pattern operator @ scan +.synb +.mets @(scan << pattern ) +.syne +.desc +The +.code scan +operator matches +.meta pattern +against the corresponding object. If the match fails, and the object +is a +.code cons +cell, the match is tried on the +.code cdr +of the cons cell. The +.code cdr +traversal repeats until a successful match is found, +or a match failure occurs against against an atom. + +Thus, a list object, possibly improper, matches +.meta pattern +under +.code scan +if any suffix of that object matches. + +.TP* Examples: + +.verb + ;; mismatch: 1 doesn't match 2 + (when-match @(scan 2) 1 t) -> t + + ;; simple atom match: 42 matches 42 + (when-match @(scan 42) 42 t) -> t + + ;; (2 3) is a sublist of (1 2 3 4) + (when-match @(scan (2 3 . @nil)) '(1 2 3 4) t) -> t + + ;; (2 @x 4 . @nil) matches (2 3 4), binding x to 3: + (when-match @(scan (2 @x 4 . @nil)) '(1 2 3 4 5) x) -> 3 + + ;; The entire matching suffix can be captured. + (when-match @(scan @(as sfx (2 @x 4 . @nil))) + '(1 2 3 4 5) + sfx) + -> (2 3 4 5) + + ;; Missing . @nil in pattern anchors search to end: + (when-match @(scan (@x 2)) + '(1 2 3 2 4 2) + x) + + ;; Terminating atom anchors to improper end: + (when-match @(scan (@x . 4)) + '(1 2 3 . 4) + x) + -> 3 + + ;; Atom pattern matches only terminating atom + (when-match @(scan #(@x @y)) + '(1 2 3 . #(4 5)) + (list x y)) + -> (4 5) +.brev + .coNP Pattern operators @ and and @ or .synb .mets @(and << pattern *) |