From 26d3a5ddd0d1b0aeb0f7976039fdf236ea0e82de Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 28 Jan 2021 18:59:02 -0800
Subject: matcher: add test-expr to match-guard.

* share/txr/stdlib/match.tl (match-guard): New slot,
test-expr. This provides a bottom test, with all the variables
bound, allowing us to allocate just one match guard in a few
instances where we are allocating two. This will be important
in the upcoming refactoring.
(compiled-match :postinit): Allocate just one match-guard
with test-expr instead of a separate one with a guard-expr.
(wrap-guards): Wrap the test-expr to the code, if it is
not t.
(compile-hash-match): Reduce two match guards to one in two
instances.
---
 share/txr/stdlib/match.tl | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 1a86cb9d..a12fb6e1 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -38,6 +38,7 @@
   pure-temps
   pure-temp-exprs
   (guard-expr t)
+  (test-expr t)
 
   (:method lets (me)
     (mapcar (ret ^(,@1 ,@2)) me.pure-temps me.pure-temp-exprs)))
@@ -59,9 +60,8 @@
                  (list
                    (new match-guard
                         vars me.vars
-                        var-exprs me.var-exprs)
-                   (new match-guard
-                        guard-expr me.test-expr))))
+                        var-exprs me.var-exprs
+                        test-expr me.test-expr))))
     (set me.vars nil
          me.var-exprs nil
          me.test-expr t))
@@ -79,6 +79,8 @@
                    (match-guard
                      (let ((lets g.(lets))
                            (temps g.temps))
+                       (if (neq t g.test-expr)
+                         (set exp ^(if ,g.test-expr ,exp)))
                        (cond
                          ((and lets temps)
                           (set exp ^(alet ,lets
@@ -472,10 +474,9 @@
                               (new match-guard
                                    vars (list vm.obj-var)
                                    var-exprs ^((gethash ,obj-var ,key-var-sym
-                                                        ,hash-alt-val)))
-                              (new match-guard
-                                   guard-expr ^(neq ,vm.obj-var
-                                                    ,hash-alt-val)))
+                                                        ,hash-alt-val))
+                                   test-expr ^(neq ,vm.obj-var
+                                                   ,hash-alt-val)))
                          vm))
                      ((and key-pat-p val-pat-p)
                       (set need-alist-p t)
@@ -496,9 +497,8 @@
                               (new match-guard
                                    pure-temps (list vm.obj-var)
                                    pure-temp-exprs ^((gethash ,obj-var ',key,
-                                                              hash-alt-val)))
-                              (new match-guard
-                                   guard-expr ^(neq ,vm.obj-var ,hash-alt-val)))
+                                                              hash-alt-val))
+                                   test-expr ^(neq ,vm.obj-var ,hash-alt-val)))
                          vm)))))))
            (guard (new match-guard
                        guard-expr ^(hashp ,obj-var)
-- 
cgit v1.2.3