summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-01-22 07:22:55 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-01-22 07:22:55 -0800
commit3fb32c9a73d407844fb9f7c843f70f85bee5b60e (patch)
tree211129e7609cf1c3140d915c16c2311529ddb1ce
parent1e8dc4f05dc5149f682ac16f3d368ec0fc82cf58 (diff)
downloadtxr-3fb32c9a73d407844fb9f7c843f70f85bee5b60e.tar.gz
txr-3fb32c9a73d407844fb9f7c843f70f85bee5b60e.tar.bz2
txr-3fb32c9a73d407844fb9f7c843f70f85bee5b60e.zip
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.
-rw-r--r--share/txr/stdlib/match.tl20
-rw-r--r--tests/011/patmatch.tl3
-rw-r--r--txr.136
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