matcher: support @(or pats ..) operator.

* share/txr/stdlib/match.tl (compile-or-match): New function.
(compile-match): Route or operator to new function.

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))))