diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-01-22 07:22:55 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-01-22 07:22:55 -0800 |
commit | 3fb32c9a73d407844fb9f7c843f70f85bee5b60e (patch) | |
tree | 211129e7609cf1c3140d915c16c2311529ddb1ce | |
parent | 1e8dc4f05dc5149f682ac16f3d368ec0fc82cf58 (diff) | |
download | txr-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.tl | 20 | ||||
-rw-r--r-- | tests/011/patmatch.tl | 3 | ||||
-rw-r--r-- | 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)) @@ -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 |