summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-02-09 07:36:25 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-02-09 07:36:25 -0800
commita824ded1de5099e860e119bec1d3a2ed5e12a1ba (patch)
treea1784d41af85abc46b8f5d1c08c84b631d051d5c
parent9f34bd9798550af88893ad165f9792198c48163d (diff)
downloadtxr-a824ded1de5099e860e119bec1d3a2ed5e12a1ba.tar.gz
txr-a824ded1de5099e860e119bec1d3a2ed5e12a1ba.tar.bz2
txr-a824ded1de5099e860e119bec1d3a2ed5e12a1ba.zip
matcher: replace wrg function with reduce-right.
* share/txr/stdlib/match.tl (wrap-expr): Remove wrg local function. Replace call with simple reduce-right, which doesn't require a reversal of the original list. (compiled-match): Likewise.
-rw-r--r--share/txr/stdlib/match.tl37
1 files changed, 14 insertions, 23 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index b90666e3..d31b0fdb 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -73,23 +73,19 @@
all-vars
(:method wrap-expr (g exp)
- (labels ((wrg (rgc exp)
- (each ((g rgc))
- (set exp g.(wrap-expr exp)))
- exp))
- (let* ((vars [mapcar get-vars g.guard-chains])
- (back-vars (cons nil
- (reverse
- [mapcar (ap append) (conses (reverse vars))])))
- (branches (collect-each ((gc g.guard-chains)
- (v vars)
- (bv back-vars))
- ^(progn
- (set ,*(mappend (ret ^(,@1 nil)) (diff bv v)))
- ,(wrg (reverse gc) t)))))
- (set exp ^(when (or ,*branches)
- ,exp))
- exp))))
+ (let* ((vars [mapcar get-vars g.guard-chains])
+ (back-vars (cons nil
+ (reverse
+ [mapcar (ap append) (conses (reverse vars))])))
+ (branches (collect-each ((gc g.guard-chains)
+ (v vars)
+ (bv back-vars))
+ ^(progn
+ (set ,*(mappend (ret ^(,@1 nil)) (diff bv v)))
+ ,(reduce-right (umeth wrap-expr) gc t)))))
+ (set exp ^(when (or ,*branches)
+ ,exp))
+ exp)))
(defstruct compiled-match ()
pattern
@@ -100,12 +96,7 @@
(uniq (get-vars me.guard-chain)))
(:method wrap-guards (me . forms)
- (labels ((wrg (rgc exp)
- (each ((g rgc))
- (set exp g.(wrap-expr exp)))
- exp))
- (wrg (reverse me.guard-chain)
- ^(progn ,*forms))))
+ (reduce-right (umeth wrap-expr) me.guard-chain ^(progn ,*forms)))
(:method add-guard-pre (me guard)
(push guard me.guard-chain))