diff options
| -rw-r--r-- | lisplib.c | 1 | ||||
| -rw-r--r-- | share/txr/stdlib/doc-syms.tl | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/match.tl | 25 | ||||
| -rw-r--r-- | tests/011/patmatch.tl | 25 | ||||
| -rw-r--r-- | txr.1 | 109 |
5 files changed, 163 insertions, 0 deletions
@@ -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") @@ -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 |