diff options
| -rw-r--r-- | autoload.c | 3 | ||||
| -rw-r--r-- | stdlib/match.tl | 28 | ||||
| -rw-r--r-- | tests/011/patmatch.tl | 8 | ||||
| -rw-r--r-- | txr.1 | 21 |
4 files changed, 57 insertions, 3 deletions
@@ -840,7 +840,8 @@ static val quips_instantiate(void) static val match_set_entries(val fun) { val name_noload[] = { - lit("all*"), lit("as"), lit("with"), lit("scan"), lit("sme"), + lit("all*"), lit("as"), lit("with"), lit("scan"), lit("scan-all"), + lit("sme"), nil }; val name[] = { diff --git a/stdlib/match.tl b/stdlib/match.tl index eb283771..a382a5e6 100644 --- a/stdlib/match.tl +++ b/stdlib/match.tl @@ -571,6 +571,33 @@ obj-var obj-var guard-chain (list guard)))))) +(defun compile-scan-all-match (scan-syntax obj-var var-list) + (mac-param-bind *match-form* (t pattern) scan-syntax + (with-gensyms (iter) + (let* ((in-vars var-list.vars) + (cm (compile-match pattern iter var-list)) + (cm-vars cm.(get-vars)) + (collect-vars (diff cm-vars in-vars)) + (collect-gens [mapcar gensym collect-vars]) + (loop ^(for ((,iter ,obj-var)) + (,iter t) + ((set ,iter (cdr ,iter))) + ,cm.(wrap-guards + ^(progn ,*(mapcar (ret ^(push ,@1 ,@2)) + collect-vars + collect-gens))))) + (guard (new match-guard + vars cm-vars + temps collect-gens + test-expr ^(progn + ,loop + ,*(mapcar (ret ^(set ,@1 (nreverse ,@2))) + collect-vars collect-gens))))) + (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))) @@ -609,6 +636,7 @@ (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)) + (usr:scan-all (compile-scan-all-match exp obj-var var-list)) (exprs (compile-exprs-match exp obj-var var-list)) (sys:quasi (compile-match exp obj-var var-list)) (t (iflet ((xfun [*match-macro* op])) diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl index 6d071f3d..731a8796 100644 --- a/tests/011/patmatch.tl +++ b/tests/011/patmatch.tl @@ -612,6 +612,14 @@ (match @(sme (@a) (@b) @x) '(0 1 . 2) (list a b x)) (0 1 2) (match @(sme (@a) (@b) @(evenp @x)) '(0 1 . 2) (list a b x)) (0 1 2)) +(mtest + (match @(scan (b @x)) '(1 2 3 4 b 5 b 6 7 8) x) :error + (match @(scan (b @x . @nil)) '(1 2 3 4 b 5 b 6 7 8) x) 5) + +(mtest + (match @(scan-all (b @x)) '(1 2 3 4 b 5 b 6 7 8) x) :error + (match @(scan-all (b @x . @nil)) '(1 2 3 4 b 5 b 6 7 8) x) (5 6)) + (compile-only (eval-only (with-compile-opts (nil unused) @@ -47666,9 +47666,10 @@ operator. -> ((2 4) (b d)) .brev -.coNP Pattern Operator @ scan +.coNP Pattern Operators @ scan and @ scan-all .synb -.mets @(scan << pattern ) +.mets @(scan << pattern )) +.mets @(scan-all << pattern )) .syne .desc The @@ -47691,6 +47692,14 @@ under .code scan if any suffix of that object matches. +The +.code scan-all +pattern matches the object in the same way. However, instead of +finding the leftmost match, it finds all matches. Every variable +that occurs inside +.meta pattern +is bound to a list of the matches which correspond to that variable. + .TP* Examples: .verb @@ -47728,6 +47737,14 @@ if any suffix of that object matches. '(1 2 3 . #(4 5)) (list x y)) -> (4 5) + + ;; Pattern doesn't match list: + (match @(scan-all (b @x)) '(1 2 3 4 b 5 b 6 7 8) x) + -> error + + ;; x bound to list of items that follow b symbol: + (match @(scan-all (b @x . @nil)) '(1 2 3 4 b 5 b 6 7 8) x) + -> (5 6) .brev .coNP Pattern Operators @ and and @ or |