diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-01-21 07:23:27 -0800 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-01-21 07:23:27 -0800 |
commit | 625a22dbae0b10eb03cbbbef0fb3a1457f916d7a (patch) | |
tree | 6ac91c5f7f703edd47230a684dd2b76dd421b7fa | |
parent | 6ab8b9c6f03d13b96b599709f44da798552639c9 (diff) | |
download | txr-625a22dbae0b10eb03cbbbef0fb3a1457f916d7a.tar.gz txr-625a22dbae0b10eb03cbbbef0fb3a1457f916d7a.tar.bz2 txr-625a22dbae0b10eb03cbbbef0fb3a1457f916d7a.zip |
matcher: fix broken @(let @a @(some @a)) test case.
This is caused by the way the loop match compiler moves the
matching logic into a guard, which causes a re-ordering of the
variable assignments which interferes with backreferencing
when @(some) is embedded into a @(let), and probably other
situations. The issues is that the backreferencing equal
tests can be reordered to occur before the assignment which
sets the intial value of the backreferenced variable:
cart before the horse kind of thing.
* share/txr/stdlib/match.tl (compile-loop-match): Do not add
the submatch into the guard sequence. Thus guard1's vars and
var-exprs, move into into the main compiled-match,
and guard1's guard-expr moves into guard0. Thus guard1
disappears, guard0 becomes guard.
* tests/011/patmatch.tl: New test case that is also fixed,
and which was not fixed by a different approach to the problem
that I scrapped.
-rw-r--r-- | share/txr/stdlib/match.tl | 14 | ||||
-rw-r--r-- | tests/011/patmatch.tl | 2 |
2 files changed, 8 insertions, 8 deletions
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl index 63fa75e1..e59cb156 100644 --- a/share/txr/stdlib/match.tl +++ b/share/txr/stdlib/match.tl @@ -247,17 +247,15 @@ collect-vars)))))) (,(if some-p 'when 'unless) ,matched-p-var (set ,loop-continue-p-var nil))))) - (guard0 (new match-guard - vars (append cm.vars (unless some-p collect-vars)) - guard-expr t)) - (guard1 (new match-guard - vars (list loop-success-p-var) - var-exprs (list loop) - guard-expr ^(,list-test ,obj-var)))) + (guard (new match-guard + vars (append cm.vars (unless some-p collect-vars)) + guard-expr ^(,list-test ,obj-var)))) (new compiled-match pattern exp obj-var obj-var - guard-chain (list guard0 guard1) + guard-chain (list guard) + vars (list loop-success-p-var) + var-exprs (list loop) test-expr (if some-p loop-success-p-var ^(when ,loop-success-p-var diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl index 7d0482b2..84d59381 100644 --- a/tests/011/patmatch.tl +++ b/tests/011/patmatch.tl @@ -88,3 +88,5 @@ (set *print-circle* t) (test (when-match @(let a @(some @a)) '#1=(1 2 #1# 3) :yes) :yes) + +(test (when-match (@a @(let a @(some @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes) |