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.

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)