matcher: add support for range objects.

* share/txr/stdlib/match.tl (compile-atom-match): Handle range
type, via transformation to rcons operator and
compile-range-mach.
(compile-range-match): New function.
(compile-match): Hook in compile-range-match for @(rcons).
(non-triv-pat-p): Handle range case.

* txr.1: Documented.

1 files changed, 24 insertions, 0 deletions

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index af85ef8c..c8990c6a 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -161,6 +161,10 @@
       (vec (if (non-triv-pat-p atom)
              (compile-vec-match atom obj-var var-list)
              (compile-as-atom)))
+      (range (if (non-triv-pat-p atom)
+               (compile-range-match ^(rcons ,(from atom) ,(to atom))
+                                    obj-var var-list)
+               (compile-as-atom)))
       (t (compile-as-atom)))))
 
 (defun compile-op-match (op-expr obj-var var-list)
@@ -379,6 +383,23 @@
            vars (mappend .vars hash-matches)
            var-exprs (mappend .var-exprs hash-matches)))))
 
+(defun compile-range-match (rcons-expr obj-var var-list)
+  (tree-bind (op from to) rcons-expr
+    (let* ((from-match (compile-match from (gensym "from") var-list))
+           (to-match (compile-match to (gensym "to") var-list))
+           (guard (new match-guard
+                       guard-expr ^(rangep ,obj-var)
+                       vars (list from-match.obj-var to-match.obj-var)
+                       var-exprs (list ^(from ,obj-var) ^(to ,obj-var)))))
+      (new compiled-match
+           pattern rcons-expr
+           obj-var obj-var
+           guard-chain (cons guard (append from-match.guard-chain
+                                           to-match.guard-chain))
+           test-expr ^(and ,from-match.test-expr ,to-match.test-expr)
+           vars (append from-match.vars to-match.vars)
+           var-exprs (append from-match.var-exprs to-match.var-exprs)))))
+
 (defun compile-match (pat : (obj-var (gensym)) (var-list (new var-list)))
   (cond
     ((consp pat)
@@ -399,6 +420,7 @@
                  (not (compile-not-match exp obj-var var-list))
                  (op (compile-op-match exp obj-var var-list))
                  (hash (compile-hash-match exp obj-var var-list))
+                 (rcons (compile-range-match exp obj-var var-list))
                  (t (compile-predicate-match exp obj-var var-list)))
                (compile-error *match-form*
                               "unrecognized pattern syntax ~s" pat))))
@@ -469,6 +491,8 @@
     ((@(op eq 'sys:var) @(bindable) . @nil) t)
     ((@pat . @rest) (or (non-triv-pat-p pat)
                         (non-triv-pat-p rest)))
+    (#R(@from @to) (or (non-triv-pat-p from)
+                       (non-triv-pat-p to)))
     (@(some @(non-triv-pat-p)) t)))
 
 (defun var-pat-p (syntax)