diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-01-28 19:39:22 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-01-28 19:39:22 -0800 |
commit | 1b33bf2abdf88071ff38c3f2c25ba57433257a2a (patch) | |
tree | 74bcab46c6a8e4a471b92abec42db0af9f70f01e | |
parent | 21babe718d57fda5d036458f96097075c21b2ab7 (diff) | |
download | txr-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.tl | 32 |
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 |