From 3fb32c9a73d407844fb9f7c843f70f85bee5b60e Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 22 Jan 2021 07:22:55 -0800
Subject: matcher: add optimized special case to hash pattern.

This change causes a key-value pattern like (@a @b)
to be treated specially when @a already has a binding from a
previous pattern. In this case, it behaves like the
trivial key case: the value of @a is looked up to try to find
a single value. If @a is not bound, then the exhaustive
search takes place, using equal equality.

* share/txr/stdlib/match.tl (compile-hash-match): Implement
special case.
(var-pat-p): New function.

* tests/011/patmatch.tl: Existing test case now changes
value. New test case added.

* txr.1: Documented.
---
 share/txr/stdlib/match.tl | 20 +++++++++++++++++++-
 tests/011/patmatch.tl     |  3 +++
 txr.1                     | 36 +++++++++++++++++++++++++++++++++---
 3 files changed, 55 insertions(+), 4 deletions(-)

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 32f8b7ca..8873062b 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -320,8 +320,22 @@
              (collect-each ((pair pairs))
                (mac-param-bind *match-form* (key val) pair
                  (let ((key-pat-p (non-triv-pat-p key))
-                       (val-pat-p (non-triv-pat-p val)))
+                       (val-pat-p (non-triv-pat-p val))
+                       (key-var-sym (var-pat-p key)))
                    (cond
+                     ((and key-var-sym var-list.(exists key-var-sym))
+                       (let ((vm (compile-match val (gensym "val") var-list))
+                             (val-sym (gensym "val")))
+                         (push
+                           (new match-guard
+                                guard-expr ^(neq ,vm.obj-var ,hash-alt-val))
+                           vm.guard-chain)
+                         (push vm.obj-var vm.vars)
+                         (push ^(gethash ,obj-var ,key-var-sym
+                                         ,hash-alt-val) vm.var-exprs)
+                         (set vm.test-expr ^(and (neq ,vm.obj-var ,hash-alt-val)
+                                                 ,vm.test-expr))
+                       vm))
                      ((and key-pat-p val-pat-p)
                       (set need-alist-p t)
                       (compile-match ^@(coll (,key . ,val))
@@ -448,3 +462,7 @@
     ((@pat . @rest) (or (non-triv-pat-p pat)
                         (non-triv-pat-p rest)))
     (@(some @(non-triv-pat-p)) t)))
+
+(defun var-pat-p (syntax)
+  (when-match (@(op eq 'sys:var) @(bindable sym) . @nil) syntax
+    sym))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index a9bd57fa..d045c45b 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -131,4 +131,7 @@
   (3 5 3 6 (11 12) (2 time) (2020 1) (vec tor)))
 
 (test (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum)
+      42)
+
+(test (when-match @(hash (x @y) (@(symbolp y) @datum)) #H(() (x k) (k 42)) datum)
       (42))
diff --git a/txr.1 b/txr.1
index 45f3d5c0..45ed9dea 100644
--- a/txr.1
+++ b/txr.1
@@ -40001,7 +40001,24 @@ which may be trivial or non-trivial.
 
 If
 .meta key-pattern
-is a non-trivial pattern, but
+is a simple variable pattern
+.mono
+.meti >> @ sym
+.onom
+and if
+.meta sym
+has an existing binding, then the value of
+.meta sym
+is looked up in the hash table. If it is not found, then
+the match fails, otherwise the corresponding value is matched
+against
+.metn value-pattern ,
+which may be trivial or non-trivial.
+
+If
+.meta key-pattern
+is a non-trivial pattern other than a variable pattern
+for a variable which has an existing binding, and if
 .meta value-pattern
 is trivial, then
 .meta value-pattern
@@ -40056,11 +40073,24 @@ operator matching against an association list.
   ;; First, (x @y) has a trivial key pattern so the x
   ;; entry from the hash table is retrieved, the
   ;; value being the symbol k. This k is bound to @y.
-  ;; Then the pattern (@y @datum) searches the entire
+  ;; Because y now a bound variable the pattern (@y @datum)
+  ;; is interpreted as search of the hash table for
+  ;; a single entry matching the value of @y. This
+  ;; is the k entry, whose value is 42. The @datum
+  ;; value match takes this 42.
+  (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum)
+  --> 42
+
+  ;; Again, (x @y) has a trivial key pattern so the x
+  ;; entry from the hash table is retrieved, the
+  ;; value being the symbol k. This k is bound to @y.
+  ;; This time the second pattern has a @(symbolp)
+  ;; predicate operator. This is not a variable, and
+  ;; so the pattern searches the entire
   ;; hash table. The @y variable has a binding to k,
   ;; so only the (k 42) entry is matched. The 42
   ;; value matches @datum, and is collected into a list.
-  (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum)
+  (when-match @(hash (x @y) (@(symbolp y) @datum)) #H(() (x k) (k 42)) datum)
   --> (42)
 .brev
 
-- 
cgit v1.2.3