From 4e75a47ab99be3d003a241964ad14b63fe0faab3 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Mon, 1 Feb 2021 21:33:36 -0800
Subject: 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.
---
 share/txr/stdlib/match.tl | 35 +++++++++++++++++++++++------------
 1 file 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)))
-- 
cgit v1.2.3