matcher: restructuring to fix new broken case.

This one test case requires restructuring. The handling for
the @(or ...) operator is now very different. To support @(or
...), there is now a new variant of the match-guard object
called guard disjunction, which contains multiple match-guard
chains. Furthermore, the separation between both guard-chain
lists and compiled-match having a test expression and
variables is being obliterated. For now, what we do is in a
:postinit handler on compiled-match, we immediately convert
the test-expr, vars and var-exprs slots into a match-guard
object, which is placed into the guard-chain, and then we
clear these slots.  They are now vestigial only and will be
removed.

* tests/011/patmatch.tl: New test case which shows
that (@(or foo bar) ...) does not short immediately short
circuit to a failure when the corresponding element is
neither foo nor bar. Matching proceeds to the right,
wasting cycles and possibly causing errors.

* share/txr/stdlib/match.tl (*match-var*): Move to top, above
structs. There are some methods which refer to this variable
now for throwing internal errors.
(guard-disjunction): New object that is compatible with a
match-guard, and placed into guard-lists as if it were a
match-guard. This handles the bifurcation logic of an
OR match.
(compiled-match): New :postinit handler converts local vars,
var-exprs and test-expr into a match-guard placed into the
chain, and then clears these values. The compilation of code
is done purely from the guard-chain.
(compiled-match get-vars): This method is now complicated due
to the guard-disjunction objects, and so uses a helper
function called get-guard-values.
(compiled-match get-var-exprs): New method accompanying
get-vars to get the accompanying init expressions.
(compiled-match wrap-guards): Two changes are going on here.
One is that the funccion takes on more of the responsibility
which was previously carried out by the callers. The callers
were interpolating the test-expr and vars from a
compiled-match into a piece of code, which was then passed to
wrap-guards. Hence the naming: the job was just to wrap some
guards. Now, wrap-guards is called just with the body forms,
and does all of the work. Secondly, wrap-guards is complicated
due to the handling of the guard-disjunction items.
Also, there is some case handling to generate better code;
we avoid generating an empty (let () ...) and (alet () ...).
(compiled-match add-guard-pre, compiled-match add-guards-pre,
compiled-match add-guards-post): New methods for adding guards
after construction. These interfaces replace hacks of pushing
new variables, tweaking the test-expr, or explicitly pushing
guards onto the list.
(get-guard-values): New function for iterating over a
guard-chain, including match-guard and guard-disjunction
items, retrieving a particular list-valued slot from each one
using the fun argument, and returning a list of all those
lists catenated together.
(compile-struct-match, compile-vec-match,
compile-range-match): Eliminate test-expr, replacing it with
the harmless t.
(compile-op-match): We don't try to extend the test-expr of
the compiled var. Rather we add our guard expressin using the
add-guard-pre interface.
(compile-dwim-predicate-match): Likewise, and also, we
do not calculate the test-expr for the output compiled-match
from the constituent match test-exprs. We ignore those and
just set the test-expr pat-match.obj-var. The constituent
test-exprs have been converted to guard-chain items already,
so there is no point in referring to them.
(compile-predicate-match): Use add-guard-pre method to add
guard instead of pushing it on list.
(compile-cons-structure): Eliminate test-expr being calculated
from constituent test-exprs, and just stub it out to t.
(compile-require-match): Use add-guards-post to push
match-guard onto compiled child mach, instead of tweaking its
test-expr.
(compile-let-match): Oblierate calculation of test-expr from
child test-exprs, replacing with t stub.
(compile-loop-match): Call wrap-guards in the new way,
without generating assignments or test-expr.
(compile-parallel-match): This method is removed; there are
now separate compile-or-match and compile-and-match methods.
(compile-or-match): New method: compiles consitituent
expressions, and converts them into multiple guard-chains
for a guard-disjunction object. Then wrap-guards will finish
the job of emitting the or logic out of those chains.
(compile-and-match): This shares some common logic with
compile-or-match, but is substantially simpler. Pattern
matching is implicitly AND-based: in a pattern, all the
sub-patterns have to match. So there isn't much to do beyond
just evaluating all the patterns against the same object.
They can all be thrown into one combined flat guard chain.
(compile-not-match): Adjust to new wrap-guards interface.
Nothing left to do here but pass the expression t to it.
(copmile-hash-mach): The post-constructon manipulations of
the child compiled matches are done with the appropriate
add-guards-pre. The test-expr is eliminated, replaced with t.
(compile-match): Wire or and and to the new separate methods
compile-or-match and compile-and-match.
(when-match, if-match, match-case): Simplified due to
when-match interface change. The macros depend on a lot less
implementation detail now: they bind the required vars and
generate the code.

2 files changed, 175 insertions, 96 deletions

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 3e254f65..1a86cb9d 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -24,6 +24,8 @@
 ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
+(defvar *match-form*)
+
 (defstruct match-vars ()
   vars
   var-exprs
@@ -31,7 +33,6 @@
   (:method assignments (me)
     (mapcar (ret ^(set ,@1 ,@2)) me.vars me.var-exprs)))
 
-
 (defstruct match-guard (match-vars)
   temps
   pure-temps
@@ -41,25 +42,85 @@
   (:method lets (me)
     (mapcar (ret ^(,@1 ,@2)) me.pure-temps me.pure-temp-exprs)))
 
+(defstruct guard-disjunction ()
+  guard-chains
+  sub-patterns
+  all-vars)
+
 (defstruct compiled-match (match-vars)
   pattern
   obj-var
   guard-chain
   test-expr
 
+  (:postinit (me)
+    (set me.guard-chain
+         (append me.guard-chain
+                 (list
+                   (new match-guard
+                        vars me.vars
+                        var-exprs me.var-exprs)
+                   (new match-guard
+                        guard-expr me.test-expr))))
+    (set me.vars nil
+         me.var-exprs nil
+         me.test-expr t))
+
   (:method get-vars (me)
-    (append me.vars (mappend .vars me.guard-chain)))
-
-  (:method wrap-guards (me exp)
-    (let ((rev-guard-chain (reverse me.guard-chain))
-          (out exp))
-      (each ((g rev-guard-chain))
-        (set out ^(when ,g.guard-expr
-                    (alet ,g.(lets)
-                      (let ,g.temps
-                        ,*g.(assignments)
-                        ,out)))))
-      out)))
+    (append me.vars (get-guard-values me.guard-chain .vars)))
+
+  (:method get-var-exprs (me)
+    (append me.var-exprs (get-guard-values me.guard-chain .var-exprs)))
+
+  (:method wrap-guards (me . forms)
+    (labels ((wrg (rgc exp)
+               (each ((g rgc))
+                 (typecase g
+                   (match-guard
+                     (let ((lets g.(lets))
+                           (temps g.temps))
+                       (cond
+                         ((and lets temps)
+                          (set exp ^(alet ,lets
+                                      (let ,temps
+                                        ,*g.(assignments)
+                                        ,exp))))
+                         (lets
+                          (set exp ^(alet ,lets
+                                      ,*g.(assignments)
+                                      ,exp)))
+                         (temps
+                          (set exp ^(let ,temps
+                                      ,*g.(assignments)
+                                      ,exp)))
+                         (t
+                          (set exp ^(progn ,*g.(assignments)
+                                     ,exp))))
+                       (when (neq t g.guard-expr)
+                         (set exp ^(if ,g.guard-expr ,exp)))))
+                   (guard-disjunction
+                     (let ((branches (collect-each ((gc g.guard-chains))
+                                       (wrg (reverse gc) t))))
+                       (set exp ^(when (or ,*branches)
+                                   ,exp))))
+                   (t (compile-error *match-form*
+                                     "internal error: bad guard ~s" g))))
+               exp))
+      (wrg (reverse me.guard-chain)
+           ^(progn ,*forms))))
+
+  (:method add-guard-pre (me guard)
+    (push guard me.guard-chain))
+
+  (:method add-guards-pre (me . guards)
+    (set me.guard-chain
+         (append guards
+                 me.guard-chain)))
+
+  (:method add-guards-post (me . guards)
+    (set me.guard-chain
+         (append me.guard-chain
+                 guards))))
 
 (defstruct var-list ()
   vars
@@ -67,7 +128,15 @@
   (:method exists (me sym) (member sym me.vars))
   (:method record (me sym) (push sym me.vars)))
 
-(defvar *match-form*)
+(defun get-guard-values (guard-chain fun)
+  (append-each ((g guard-chain))
+    (typecase g
+      (match-guard
+        [fun g])
+      (guard-disjunction
+        (append-each ((gc g.guard-chains))
+          (get-guard-values gc fun)))
+      (t (compile-error *match-form* "internal error: bad guard ~s" g)))))
 
 (defun compile-struct-match (struct-pat obj-var var-list)
   (mac-param-bind *match-form* (op required-type . pairs) struct-pat
@@ -116,7 +185,7 @@
            obj-var obj-var
            guard-chain ^(,*(if guard0 (list guard0)) ,guard1
                          ,*(mappend .guard-chain all-matches))
-           test-expr ^(and ,*(mapcar .test-expr all-matches))
+           test-expr t
            vars [mappend .vars all-matches]
            var-exprs [mappend .var-exprs all-matches]))))
 
@@ -152,7 +221,7 @@
          pattern vec-pat
          obj-var obj-var
          guard-chain (cons guard (mappend .guard-chain elem-matches))
-         test-expr ^(and ,*(mapcar .test-expr elem-matches))
+         test-expr t
          vars (mappend .vars elem-matches)
          var-exprs (mappend .var-exprs elem-matches))))
 
@@ -170,7 +239,7 @@
            obj-var obj-var
            guard-chain (cons guard (append from-match.guard-chain
                                            to-match.guard-chain))
-           test-expr ^(and ,from-match.test-expr ,to-match.test-expr)
+           test-expr t
            vars (append from-match.vars to-match.vars)
            var-exprs (append from-match.var-exprs to-match.var-exprs)))))
 
@@ -193,7 +262,9 @@
 
 (defun compile-op-match (op-expr obj-var var-list)
   (let ((var-match (compile-var-match nil obj-var var-list)))
-    (set var-match.test-expr ^(and ,var-match.test-expr [,op-expr ,obj-var]))
+    var-match.(add-guard-pre (new match-guard
+                                  guard-expr ^(and ,var-match.test-expr
+                                                   [,op-expr ,obj-var])))
     var-match))
 
 (defun compile-dwim-predicate-match (pred-expr obj-var var-list)
@@ -213,11 +284,11 @@
                                                pat-match.guard-chain))
                vars (append var-match.vars pat-match.vars)
                var-exprs (append var-match.var-exprs pat-match.var-exprs)
-               test-expr ^(and ,var-match.test-expr
-                               ,pat-match.test-expr
-                               ,pat-match.obj-var)))
+               test-expr pat-match.obj-var))
         (progn
-          (set var-match.test-expr ^(and ,var-match.test-expr [,fun ,obj-var]))
+          var-match.(add-guard-pre (new match-guard
+                                        guard-expr ^(and ,var-match.test-expr
+                                                         [,fun ,obj-var])))
           var-match)))))
 
 (defun compile-predicate-match (pred-expr obj-var var-list)
@@ -225,8 +296,9 @@
     (or (null sym) (bindable sym)
         (compile-error *match-form* "~s is not a symbol" sym))
     (let ((var-match (compile-var-match sym obj-var var-list)))
-      (push (new match-guard guard-expr ^(and ,var-match.test-expr (,fun ,obj-var)))
-            var-match.guard-chain)
+      var-match.(add-guard-pre (new match-guard
+                                    guard-expr ^(and ,var-match.test-expr
+                                                     (,fun ,obj-var))))
       var-match)))
 
 (defun compile-cons-structure (cons-pat obj-var var-list)
@@ -249,14 +321,15 @@
            obj-var obj-var
            guard-chain (cons guard (append car-match.guard-chain
                                            cdr-match.guard-chain))
-           test-expr ^(and ,car-match.test-expr ,cdr-match.test-expr)
+           test-expr t
            vars (append car-match.vars cdr-match.vars)
            var-exprs (append car-match.var-exprs cdr-match.var-exprs)))))
 
 (defun compile-require-match (exp obj-var var-list)
   (mac-param-bind *match-form* (op match . conditions) exp
     (let ((match (compile-match match obj-var var-list)))
-      (set match.test-expr ^(and ,match.test-expr ,*conditions))
+      match.(add-guards-post (new match-guard
+                                  guard-expr ^(and ,*conditions)))
       match)))
 
 (defun compile-let-match (exp obj-var var-list)
@@ -268,7 +341,7 @@
            obj-var obj-var
            guard-chain (append var-match.guard-chain
                                pat-match.guard-chain)
-           test-expr ^(and ,var-match.test-expr ,pat-match.test-expr)
+           test-expr t
            vars (append var-match.vars pat-match.vars)
            var-exprs (append var-match.var-exprs pat-match.var-exprs)))))
 
@@ -302,18 +375,17 @@
                           ,matched-p-var
                           ,*(unless some-p cm-vars))
                       ,cm.(wrap-guards
-                            ^(progn ,*cm.(assignments)
-                               (if ,cm.test-expr
-                                 (progn
-                                   (set ,matched-p-var t)
-                                   ,*(if no-vac-p
-                                       ^((set ,loop-iterated-var t)))
-                                   ,*(unless some-p
-                                       (mapcar (ret ^(push ,@1 ,@2))
-                                               collect-vars
-                                               collect-gens))))))
-                      ,(unless coll-p ^(,(if some-p 'when 'unless) ,matched-p-var
-                         (set ,loop-continue-p-var nil))))))
+                            ^(progn
+                               (set ,matched-p-var t)
+                               ,*(if no-vac-p
+                                   ^((set ,loop-iterated-var t)))
+                               ,*(unless some-p
+                                   (mapcar (ret ^(push ,@1 ,@2))
+                                           collect-vars
+                                           collect-gens))))
+                      ,(unless coll-p ^(,(if some-p 'when 'unless)
+                                         ,matched-p-var
+                                         (set ,loop-continue-p-var nil))))))
            (guard (new match-guard
                        vars cm-vars
                        temps (unless some-p collect-gens)
@@ -331,37 +403,49 @@
                                     collect-vars collect-gens)
                           t))))))
 
-(defun compile-parallel-match (par-pat obj-var var-list)
+(defun compile-or-match (par-pat obj-var var-list)
   (mac-param-bind *match-form* (op . pats) par-pat
     (let* ((var-lists (mapcar (ret (copy var-list)) pats))
            (par-matches (mapcar (op compile-match @1 obj-var @2)
                                 pats var-lists))
-           (all-vars (uniq (mappend .(get-vars) par-matches))))
-      (flet ((submatch-fun (pm)
-               pm.(wrap-guards
-                    ^(progn ,*pm.(assignments)
-                       (when ,pm.test-expr
-                         ,*(if (eq op 'or)
-                             (mapcar (ret ^(set ,@1 nil))
-                                     (diff all-vars pm.(get-vars))))
-                         t)))))
-        (let ((guard (new match-guard
-                          vars all-vars)))
-          (new compiled-match
-               pattern par-pat
-               obj-var obj-var
-               guard-chain (list guard)
-               test-expr ^(,op ,*[mapcar submatch-fun par-matches])))))))
+           (all-var-exprs [unique [mapcar cons
+                                          (mappend .(get-vars) par-matches)
+                                          (mappend .(get-var-exprs) par-matches)]
+                                  car])
+           (guard (new match-guard
+                       vars [mapcar car all-var-exprs]))
+           (dj-guard (new guard-disjunction
+                          guard-chains (mapcar .guard-chain par-matches)
+                          sub-patterns par-matches)))
+      (new compiled-match
+           pattern par-pat
+           obj-var obj-var
+           guard-chain (list guard dj-guard)
+           test-expr t))))
+
+(defun compile-and-match (par-pat obj-var var-list)
+  (mac-param-bind *match-form* (op . pats) par-pat
+    (let* ((var-lists (mapcar (ret (copy var-list)) pats))
+           (par-matches (mapcar (op compile-match @1 obj-var @2)
+                                pats var-lists))
+           (all-var-exprs [unique [mapcar cons
+                                          (mappend .(get-vars) par-matches)
+                                          (mappend .(get-var-exprs) par-matches)]
+                                  car]))
+      (new compiled-match
+           pattern par-pat
+           obj-var obj-var
+           vars [mapcar car all-var-exprs]
+           var-exprs [mapcar cdr all-var-exprs]
+           guard-chain (mappend .guard-chain par-matches)
+           test-expr t))))
 
 (defun compile-not-match (pattern obj-var var-list)
   (mac-param-bind *match-form* (op pattern) pattern
     (let* ((pm (compile-match pattern obj-var var-list))
            (guard (new match-guard
                        guard-expr ^(not (let ,pm.(get-vars)
-                                          ,pm.(wrap-guards
-                                                ^(progn ,*pm.(assignments)
-                                                   (when ,pm.test-expr
-                                                     t))))))))
+                                          ,pm.(wrap-guards t))))))
       (new compiled-match
            pattern pattern
            obj-var obj-var
@@ -384,14 +468,15 @@
                      ((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)
-                       vm))
+                         vm.(add-guards-pre
+                              (new match-guard
+                                   vars (list vm.obj-var)
+                                   var-exprs ^((gethash ,obj-var ,key-var-sym
+                                                        ,hash-alt-val)))
+                              (new match-guard
+                                   guard-expr ^(neq ,vm.obj-var
+                                                    ,hash-alt-val)))
+                         vm))
                      ((and key-pat-p val-pat-p)
                       (set need-alist-p t)
                       (compile-match ^@(coll (,key . ,val))
@@ -399,23 +484,21 @@
                      (key-pat-p
                        (let ((km (compile-match key (gensym "keys")
                                                 var-list)))
-                         (push
-                           (new match-guard
-                                pure-temps (list km.obj-var)
-                                pure-temp-exprs ^((hash-keys-of ,obj-var ',val)))
-                           km.guard-chain)
+                         km.(add-guards-pre
+                              (new match-guard
+                                   pure-temps (list km.obj-var)
+                                   pure-temp-exprs ^((hash-keys-of ,obj-var
+                                                       ',val))))
                          km))
                      (t
                        (let ((vm (compile-match val (gensym "val") var-list)))
-                         (push
-                           (new match-guard
-                                guard-expr ^(neq ,vm.obj-var ,hash-alt-val))
-                           vm.guard-chain)
-                         (push
-                           (new match-guard
-                                pure-temps (list vm.obj-var)
-                                pure-temp-exprs ^((gethash ,obj-var ',key, hash-alt-val)))
-                           vm.guard-chain)
+                         vm.(add-guards-pre
+                              (new match-guard
+                                   pure-temps (list vm.obj-var)
+                                   pure-temp-exprs ^((gethash ,obj-var ',key,
+                                                              hash-alt-val)))
+                              (new match-guard
+                                   guard-expr ^(neq ,vm.obj-var ,hash-alt-val)))
                          vm)))))))
            (guard (new match-guard
                        guard-expr ^(hashp ,obj-var)
@@ -427,7 +510,7 @@
            pattern hash-expr
            obj-var obj-var
            guard-chain (cons guard (mappend .guard-chain hash-matches))
-           test-expr ^(and ,*(mapcar .test-expr hash-matches))
+           test-expr t
            vars (mappend .vars hash-matches)
            var-exprs (mappend .var-exprs hash-matches)))))
 
@@ -446,8 +529,8 @@
                  (usr:all* (compile-loop-match exp obj-var var-list))
                  (some (compile-loop-match exp obj-var var-list))
                  (coll (compile-loop-match exp obj-var var-list))
-                 (or (compile-parallel-match exp obj-var var-list))
-                 (and (compile-parallel-match exp obj-var var-list))
+                 (or (compile-or-match exp obj-var var-list))
+                 (and (compile-and-match exp obj-var var-list))
                  (not (compile-not-match exp obj-var var-list))
                  (op (compile-op-match exp obj-var var-list))
                  (hash (compile-hash-match exp obj-var var-list))
@@ -466,9 +549,7 @@
   (let ((cm (compile-match pat)))
     ^(alet ((,cm.obj-var ,obj))
        (let ,cm.(get-vars)
-         ,cm.(wrap-guards
-               ^(progn ,*cm.(assignments)
-                  (when ,cm.test-expr ,*body)))))))
+         ,cm.(wrap-guards . body)))))
 
 (defmacro if-match (:form *match-form* pat obj then : else)
   (let ((cm (compile-match pat))
@@ -477,10 +558,8 @@
     ^(alet ((,cm.obj-var ,obj))
        (let* (,match-p ,*cm.(get-vars)
               (,result ,cm.(wrap-guards
-                             ^(progn ,*cm.(assignments)
-                                (when ,cm.test-expr
-                                  (set ,match-p t)
-                                  ,then)))))
+                             ^(set ,match-p t)
+                             then)))
          (if ,match-p ,result ,else)))))
 
 (defmacro match-case (:form *match-form* obj . clauses)
@@ -496,10 +575,8 @@
                           ^(unless ,(unless (zerop i) flag)
                              (let (,*cm.(get-vars))
                                (set ,result ,cm.(wrap-guards
-                                                  ^(progn ,*cm.(assignments)
-                                                     (when ,cm.test-expr
-                                                       (set ,flag t)
-                                                       ,*forms))))))))))
+                                                  ^(set ,flag t)
+                                                  . forms))))))))
     ^(let (,flag ,result)
        ,*clause-code
        ,result)))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index 30f57e4b..6a9c6f18 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -77,6 +77,8 @@
 
 (test (when-match (foo @(all @x)) '(bar (1 2 . 3)) x) nil)
 
+(test (when-match (@(or foo) @(all @x)) '(bar (1 2 . 3)) x) nil)
+
 (test (when-match (@(oddp) @(all @x)) '(2 (1 2 . 3)) x) nil)
 
 (test (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2)