summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-01-28 19:39:22 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-01-28 19:39:22 -0800
commit1b33bf2abdf88071ff38c3f2c25ba57433257a2a (patch)
tree74bcab46c6a8e4a471b92abec42db0af9f70f01e
parent21babe718d57fda5d036458f96097075c21b2ab7 (diff)
downloadtxr-1b33bf2abdf88071ff38c3f2c25ba57433257a2a.tar.gz
txr-1b33bf2abdf88071ff38c3f2c25ba57433257a2a.tar.bz2
txr-1b33bf2abdf88071ff38c3f2c25ba57433257a2a.zip
matcher: remove duplicate variables in one place.
* share/txr/stdlib/match.tl (compiled-match get-var-exprs): method get-var-exprs removed. This is only used in one place, which is going away. Actually, the value is not even used; it is discarded. (compiled-match get-vars): This method now passes the list of variables thorugh uniq. The logic of get-guard-values is pulled into a local function, since get-guard-values has only one caller now. (get-guard-values): Function removed. (compile-or-match): Removing all-var-exprs variable and all that calculation of the unique names, as well as the extra match-guard which duplicates those names pointlessly.
-rw-r--r--share/txr/stdlib/match.tl32
1 files changed, 11 insertions, 21 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 5105bd2e..920ca14e 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -52,10 +52,16 @@
guard-chain
(:method get-vars (me)
- (get-guard-values me.guard-chain .vars))
-
- (:method get-var-exprs (me)
- (get-guard-values me.guard-chain .var-exprs))
+ (labels ((getv (gc)
+ (append-each ((g gc))
+ (typecase g
+ (match-guard
+ g.vars)
+ (guard-disjunction
+ (append-each ((gc g.guard-chains)) (getv gc)))
+ (t (compile-error *match-form*
+ "internal error: bad guard ~s" g))))))
+ (uniq (getv me.guard-chain))))
(:method wrap-guards (me . forms)
(labels ((wrg (rgc exp)
@@ -115,16 +121,6 @@
(:method exists (me sym) (member sym me.vars))
(:method record (me sym) (push sym me.vars)))
-(defun get-guard-values (guard-chain fun)
- (append-each ((g guard-chain))
- (typecase g
- (match-guard
- [fun g])
- (guard-disjunction
- (append-each ((gc g.guard-chains))
- (get-guard-values gc fun)))
- (t (compile-error *match-form* "internal error: bad guard ~s" g)))))
-
(defun compile-struct-match (struct-pat obj-var var-list)
(mac-param-bind *match-form* (op required-type . pairs) struct-pat
(let* ((loose-p (not (bindable required-type)))
@@ -377,19 +373,13 @@
(let* ((var-lists (mapcar (ret (copy var-list)) pats))
(par-matches (mapcar (op compile-match @1 obj-var @2)
pats var-lists))
- (all-var-exprs [unique [mapcar cons
- (mappend .(get-vars) par-matches)
- (mappend .(get-var-exprs) par-matches)]
- car])
- (guard (new match-guard
- vars [mapcar car all-var-exprs]))
(dj-guard (new guard-disjunction
guard-chains (mapcar .guard-chain par-matches)
sub-patterns par-matches)))
(new compiled-match
pattern par-pat
obj-var obj-var
- guard-chain (list guard dj-guard)))))
+ guard-chain (list dj-guard)))))
(defun compile-and-match (par-pat obj-var var-list)
(mac-param-bind *match-form* (op . pats) par-pat