diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-02-01 21:33:36 -0800 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-02-01 21:33:36 -0800 |
| commit | 6968ea83c5bfb11b725e3ab638a66ff2681ce6f6 (patch) | |
| tree | 64c1fa4d08a70714556d98bc2f2803772eb9d3c5 | |
| parent | 4a03ee8d1fde18336c288ee48241e786c7330f09 (diff) | |
| download | txr-6968ea83c5bfb11b725e3ab638a66ff2681ce6f6.tar.gz txr-6968ea83c5bfb11b725e3ab638a66ff2681ce6f6.tar.bz2 txr-6968ea83c5bfb11b725e3ab638a66ff2681ce6f6.zip | |
matcher: restore nulling out of vars in @(or).
* share/txr/stdlib/match.tl (compiled-match get-vars): Local
function here becomes stand-alone defun, because we need it
elsewhere.
(compiled-mach wrap-guards): When processing the
guard-disjunction object to produce the or branches, we
calculate, for each branch, its own variables, and the variables
of the preceding clauses. We generate code to set the previous
variables to nil. Not all the previous variables, just those
that are not also in the current clause.
(get-vars): New function.
| -rw-r--r-- | share/txr/stdlib/match.tl | 35 |
1 files changed, 23 insertions, 12 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index b2d7b2c1..864401c0 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -52,16 +52,7 @@ guard-chain (:method get-vars (me) - (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)))) + (uniq (get-vars me.guard-chain))) (:method wrap-guards (me . forms) (labels ((wrg (rgc exp) @@ -92,8 +83,18 @@ (when (neq t g.guard-expr) (set exp ^(if ,g.guard-expr ,exp))))) (guard-disjunction - (let ((branches (collect-each ((gc g.guard-chains)) - (wrg (reverse gc) t)))) + (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)))) (t (compile-error *match-form* @@ -121,6 +122,16 @@ (:method exists (me sym) (member sym me.vars)) (:method record (me sym) (push sym me.vars))) +(defun get-vars (guard-chain) + (append-each ((g guard-chain)) + (typecase g + (match-guard + g.vars) + (guard-disjunction + (append-each ((gc g.guard-chains)) (get-vars gc))) + (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))) |