From 3fb32c9a73d407844fb9f7c843f70f85bee5b60e Mon Sep 17 00:00:00 2001 From: Kaz Kylheku 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 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) (limited to 'share') 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)) -- cgit v1.2.3