From 6957fdc990012441842d42ad37f8f61ea87a6d44 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 14 Jan 2021 19:27:20 -0800
Subject: matcher: factor out vars into common base.

* share/txr/stdlib/match.tl (match-vars): New struct.
Holds vars and expressions, and provides the method to
zipper them up into the assignments.
(match-guard, compiled-match): Inherit from match vars.
match-guard loses temps and temp-exprs. It now has
vars and var-exprs from the base and those are used
instead.
(compiled-match get-temps): Follow temps vars rename.
(compiled-match wrap-guards): Use assignments method
inherited from base instead of assignments function.
(assignments): Function removed.
(compile-struct-match, compile-vec-match,
compile-cons-structure): Follow vars temps rename in
match-guard struct.
(when-mach): Use assignments method of compiled-match instead
of assignments function.
---
 share/txr/stdlib/match.tl | 36 ++++++++++++++++++------------------
 1 file changed, 18 insertions(+), 18 deletions(-)

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index d65700ca..220732cb 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -24,21 +24,24 @@
 ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-(defstruct match-guard ()
-  temps
-  temp-exprs
+(defstruct match-vars ()
+  vars
+  var-exprs
+
+  (:method assignments (me)
+    (mapcar (ret ^(set ,@1 ,@2)) me.vars me.var-exprs)))
+
+(defstruct match-guard (match-vars)
   guard-expr)
 
-(defstruct compiled-match ()
+(defstruct compiled-match (match-vars)
   pattern
   obj-var
   guard-chain
   test-expr
-  vars
-  var-exprs
 
   (:method get-temps (me)
-    (mappend .temps me.guard-chain))
+    (mappend .vars me.guard-chain))
 
   (:method get-vars (me)
     (append me.(get-temps) me.vars))
@@ -49,13 +52,10 @@
       (each ((g rev-guard-chain))
         (set out ^(when ,g.guard-expr
                     (progn
-                      ,*(assignments g.temps g.temp-exprs)
+                      ,*g.(assignments)
                       ,out))))
       out)))
 
-(defun assignments (vars exprs)
-  (mapcar (ret ^(set ,@1 ,@2)) vars exprs))
-
 (defun compile-struct-match (struct-pat obj-var)
   (let* ((required-type (cadr struct-pat))
          (slot-pairs (plist-to-alist (cddr struct-pat)))
@@ -66,8 +66,8 @@
          (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1))
                                  required-slots])
          (guard (new match-guard
-                     temps slot-gensyms
-                     temp-exprs slot-val-exprs
+                     vars slot-gensyms
+                     var-exprs slot-val-exprs
                      guard-expr  ^(subtypep (typeof ,obj-var)
                                             ',required-type))))
     (new compiled-match
@@ -90,8 +90,8 @@
   (let* ((elem-gensyms (mapcar (op gensym `elem-@1-`) (range* 0 (len vec-pat))))
          (elem-matches (list-vec [mapcar compile-match vec-pat elem-gensyms]))
          (guard (new match-guard
-                     temps elem-gensyms
-                     temp-exprs (mapcar (ret ^[,obj-var ,@1])
+                     vars elem-gensyms
+                     var-exprs (mapcar (ret ^[,obj-var ,@1])
                                         (range* 0 (len vec-pat)))
                      guard-expr ^(and (vectorp ,obj-var)
                                       (eql (len ,obj-var) ,(len vec-pat))))))
@@ -130,8 +130,8 @@
                           (t (compile-cons-structure cdr cdr-gensym)))
                         (compile-atom-match cdr cdr-gensym)))
            (guard (new match-guard
-                       temps ^(,car-gensym ,cdr-gensym)
-                       temp-exprs ^((car ,obj-var) (cdr ,obj-var))
+                       vars ^(,car-gensym ,cdr-gensym)
+                       var-exprs ^((car ,obj-var) (cdr ,obj-var))
                        guard-expr ^(consp ,obj-var))))
       (new compiled-match
            pattern cons-pat
@@ -180,5 +180,5 @@
     ^(let ((,cm.obj-var ,obj)
            ,*cm.(get-vars))
        ,cm.(wrap-guards
-             ^(progn ,*(assignments cm.vars cm.var-exprs)
+             ^(progn ,*cm.(assignments)
                 (if ,cm.test-expr ,*body))))))
-- 
cgit v1.2.3