summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-01-21 07:23:27 -0800
committerKaz Kylheku <kaz@kylheku.com>2021-01-21 07:23:27 -0800
commit625a22dbae0b10eb03cbbbef0fb3a1457f916d7a (patch)
tree6ac91c5f7f703edd47230a684dd2b76dd421b7fa
parent6ab8b9c6f03d13b96b599709f44da798552639c9 (diff)
downloadtxr-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.tl14
-rw-r--r--tests/011/patmatch.tl2
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)