diff options
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/match.tl | 24 |
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) |