From eb11c7d3acb1b37decf10455115440ff31881243 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Fri, 15 Jan 2021 17:30:01 -0800 Subject: matcher: support @(or pats ..) operator. * share/txr/stdlib/match.tl (compile-or-match): New function. (compile-match): Route or operator to new function. --- share/txr/stdlib/match.tl | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index 3af557e6..f86acb09 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -204,6 +204,22 @@ var-exprs (unless (eq op 'some) (mapcar (ret ^(nreverse ,@1)) collect-vars)))))) +(defun compile-or-match (or-pat obj-var) + (flet ((submatch-fun (om) + ^(let ,om.(get-temps) + ,om.(wrap-guards + ^(progn ,*om.(assignments) + (if ,om.test-expr t)))))) + (let* ((or-matches (mapcar (op compile-match @1 obj-var) (cdr or-pat))) + (guard (new match-guard + guard-expr ^(or ,*[mapcar submatch-fun or-matches])))) + (new compiled-match + pattern or-pat + obj-var obj-var + guard-chain (list guard) + test-expr t + vars (uniq (mappend .vars or-matches)))))) + (defun compile-match (pat : (obj-var (gensym))) (cond ((consp pat) @@ -218,6 +234,7 @@ (all (compile-loop-match exp obj-var)) (usr:all* (compile-loop-match exp obj-var)) (some (compile-loop-match exp obj-var)) + (or (compile-or-match exp obj-var)) (t (compile-predicate-match exp obj-var))) (compile-error *match-form* "unrecognized pattern syntax ~s" pat)))) -- cgit v1.2.3