diff options
| -rw-r--r-- | share/txr/stdlib/match.tl | 17 |
1 files changed, 17 insertions, 0 deletions
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)))) |