matcher: redesign predicate pattern.

* share/txr/stdlib/match.tl (compile-dwim-predicate-match):
Function removed. There is no more special @(dwim ...)
or @[...] pattern.
(compile-predicate-match): Function rewritten, providing
different syntax and semantics.
(compile-match): dwim dispatch removed.
(non-triv-pat-p): Replaced @(op ...) calls with new-style
predicate syntax.
(var-pat-p): Likewise, and upgraded one instance of old-style
predicate syntax to new.

* share/txr/stdlib/compiler.tl (reduce-or): Adjust predicate
pattern to new style.

* share/txr/stdlib/optimize.tl (dedup-labels): Likewise.

* tests/011/patmatch.tl: All test cases with predicate syntax
are updated to new style. One test case removed; some added.

* txr.1: Predicate patterns re-documented. All examples
involving predicate patterns updated.

5 files changed, 142 insertions, 110 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index e858ade1..855b3004 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1309,7 +1309,7 @@
     ((or) form)
     ((or @a) form)
     ((or nil . @rest) (reduce-or ^(or ,*rest)))
-    ((or @(true-const-p c) . @rest) ^(or ,c))
+    ((or @(true-const-p @c) . @rest) ^(or ,c))
     ((or @a . @rest) ^(or ,a ,*(cdr (reduce-or ^(or ,*rest)))))
     (@else else)))
 
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index f99a8fe6..8fbac8f8 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -276,35 +276,43 @@
                                   guard-expr ^ [,op-expr ,obj-var]))
     var-match))
 
-(defun compile-dwim-predicate-match (pred-expr obj-var var-list)
-  (mac-param-bind *match-form* (dwim fun : sym pat) pred-expr
-    (let ((var-match (compile-var-match sym obj-var var-list)))
-      (if pat
-        (let* ((pat-match (if (symbolp pat)
-                            (compile-var-match pat (gensym) var-list)
-                            (compile-match pat (gensym) var-list)))
-               (guard (new match-guard
-                           pure-temps (list pat-match.obj-var)
-                           pure-temp-exprs (list ^[,fun ,obj-var])
-                           test-expr pat-match.obj-var)))
-          (new compiled-match
-               pattern pred-expr
-               obj-var obj-var
-               guard-chain (cons guard (append var-match.guard-chain
-                                               pat-match.guard-chain))))
-        (progn
-          var-match.(add-guard-pre (new match-guard
-                                        guard-expr ^[,fun ,obj-var]))
-          var-match)))))
-
-(defun compile-predicate-match (pred-expr obj-var var-list)
-  (mac-param-bind *match-form* (fun : sym) pred-expr
-    (or (null sym) (bindable sym)
-        (compile-error *match-form* "~s is not a bindable symbol" sym))
-    (let ((var-match (compile-var-match sym obj-var var-list)))
-      var-match.(add-guard-pre (new match-guard
-                                    guard-expr ^(,fun ,obj-var)))
-      var-match)))
+(defun compile-predicate-match (exp obj-var var-list)
+  (let ((head (car exp)))
+    (if (and (consp head) (eq (car head) 'sys:var))
+      (tree-case exp
+        (((sv rvar) (op . args))
+         (let* ((avar
+                  (condlet
+                    (((vm (member-if [andf consp (op eq (car @1) 'sys:var)]
+                                     args)))
+                     (let ((sym (cadar vm)))
+                       (set args (append (ldiff args vm)
+                                         (list sym)
+                                         (cdr vm)))
+                       sym))
+                    (((vm (memq 'sys:var args)))
+                     (let ((sym (cadr vm)))
+                       (set args (append (ldiff args vm) sym))
+                       sym))))
+                (res-var (if rvar rvar (gensym "res-")))
+                (arg-var (if avar avar (gensym "obj-"))))
+           (unless avar
+             (set args (append args (list arg-var))))
+           (let* ((guard (new match-guard
+                              pure-temps (list res-var)
+                              pure-temp-exprs ^((alet ((,arg-var ,obj-var))
+                                                  (,op ,*args)))
+                              test-expr res-var))
+                  (avar-match (compile-var-match avar obj-var var-list))
+                  (rvar-match (compile-var-match rvar res-var var-list)))
+             (new compiled-match
+                  pattern exp
+                  obj-var obj-var
+                  guard-chain  (append avar-match.guard-chain
+                                       (list guard)
+                                       rvar-match.guard-chain)))))
+        (els (compile-error *match-form* "invalid predicate syntax: ~s" exp)))
+      (compile-predicate-match (list '@nil exp) obj-var var-list))))
 
 (defun compile-cons-structure (cons-pat obj-var var-list)
   (mac-param-bind *match-form* (car . cdr) cons-pat
@@ -556,7 +564,6 @@
                  (op (compile-op-match exp obj-var var-list))
                  (hash (compile-hash-match exp obj-var var-list))
                  (rcons (compile-range-match exp obj-var var-list))
-                 (dwim (compile-dwim-predicate-match exp obj-var var-list))
                  (exprs (compile-exprs-match exp obj-var var-list))
                  (t (compile-predicate-match exp obj-var var-list)))
                (compile-error *match-form*
@@ -733,8 +740,8 @@
 
 (defun non-triv-pat-p (syntax)
   (match-case syntax
-    ((@(op eq 'sys:expr) (@(bindable) . @nil)) t)
-    ((@(op eq 'sys:var) @(or @(bindable) nil) . @nil) t)
+    ((@(eq 'sys:expr) (@(bindable) . @nil)) t)
+    ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t)
     ((@pat . @rest) (or (non-triv-pat-p pat)
                         (non-triv-pat-p rest)))
     (#R(@from @to) (or (non-triv-pat-p from)
@@ -742,5 +749,5 @@
     (@(some @(non-triv-pat-p)) t)))
 
 (defun var-pat-p (syntax)
-  (when-match (@(op eq 'sys:var) @(bindable sym) . @nil) syntax
+  (when-match (@(eq 'sys:var) @(bindable @sym) . @nil) syntax
     sym))
diff --git a/share/txr/stdlib/optimize.tl b/share/txr/stdlib/optimize.tl
index 4f69d424..5a50f495 100644
--- a/share/txr/stdlib/optimize.tl
+++ b/share/txr/stdlib/optimize.tl
@@ -124,7 +124,7 @@
 (defun dedup-labels (insns)
   (rewrite (lambda (tail)
               (match-case tail
-                ((@(symbolp label0) @(symbolp label1) . @rest)
+                ((@(symbolp @label0) @(symbolp @label1) . @rest)
                  (set insns (mapcar [iffi listp (op subst label1 label0)]
                                     (remq label1 insns)))
                  (list* label0 rest))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index 870a3a0b..d30f5aec 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -13,7 +13,7 @@
 (test (when-match (@a @b @c) '(1 2 3) (list c b a)) (3 2 1))
 (test (if-match (@a @b @c . @d) '(1 2 3 . 4) (list d c b a)) (4 3 2 1))
 
-(test (if-match (@(oddp a) @b @c . @d) '(2 x y z)
+(test (if-match (@(oddp @a) @b @c . @d) '(2 x y z)
         (list a b c d)
         :no-match)
       :no-match)
@@ -85,8 +85,9 @@
 (test (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2)
 (test (if-match @(op <= 10 @1 13) 11 :yes :no) :yes)
 (test (when-match @(as x @(op <= 10 @1 13)) 11 x) 11)
-(test (when-match (@(evenp) @(oddp x)) '(2 3) x) 3)
-
+(test (when-match (@(evenp) @(oddp @x)) '(2 3) x) 3)
+(test (when-match @(<= 1 @x 10) 4 x) 4)
+(test (when-match @(@d (chr-digit @c)) #\5 (list d c)) (5 #\5))
 (test (when-match @(or @(require @a (oddp a)) @b @c) 2 (list a b c))
       (nil 2 nil))
 
@@ -124,12 +125,12 @@
       (1 2 3 42))
 
 (test (let ((o 3))
-        (when-match (@(evenp x) @(with @z @(oddp y) o)) '(4 6)
+        (when-match (@(evenp @x) @(with @z @(oddp @y) o)) '(4 6)
           (list x y z)))
       (4 3 6))
 
 (test (let ((o 3))
-        (when-match (@(evenp x) @(with @(oddp y) o)) '(4 6)
+        (when-match (@(evenp @x) @(with @(oddp @y) o)) '(4 6)
           (list x y)))
       (4 3))
 
@@ -154,7 +155,7 @@
     (match-case obj
       (@(struct @s year 2021 day @d) (list d (struct-type-name s)))
       (@(struct time year @y month @x day @x) (list y x))
-      (#(@(integerp x) @(require @y (succ x))) (list x y))
+      (#(@(integerp @x) @(require @y (succ x))) (list x y))
       (#(@x @y) (list x y))
       ((@x @nil @x) x)
       ((@nil @nil @x) x)
@@ -165,7 +166,7 @@
 (test (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum)
       42)
 
-(test (when-match @(hash (x @y) (@(symbolp y) @datum)) #H(() (x k) (k 42)) datum)
+(test (when-match @(hash (x @y) (@(symbolp @y) @datum)) #H(() (x k) (k 42)) datum)
       (42))
 
 (test (if-match #R(10 20) 10..20 :yes :no) :yes)
@@ -181,15 +182,11 @@
 (test (when-match (rcons @a @b) '(rcons 1 2) (list a b)) (1 2))
 
 (test (let ((h #H(() (a 1) (b 2))))
-        (when-match @[h x] 'a x))
+        (when-match @[h @x] 'a x))
       a)
 
 (test (let ((h #H(() (a 1) (b 2))))
-        (when-match @[h x y] 'a (list x y)))
-      (a 1))
-
-(test (let ((h #H(() (a 1) (b 2))))
-        (when-match @[h x @(oddp y)] 'a (list x y)))
+        (when-match @(@y [h @x]) 'a (list x y)))
       (a 1))
 
 (test
diff --git a/txr.1 b/txr.1
index 762e886c..03eab8fe 100644
--- a/txr.1
+++ b/txr.1
@@ -39951,7 +39951,7 @@ and therefore is not a list pattern.
   --> (4 3 2 1)
 
   ;; 2 doesn't satisfy oddp
-  (if-match (@(oddp a) @b @c . @d) '(2 x y z)
+  (if-match (@(oddp @a) @b @c . @d) '(2 x y z)
     (list a b c d)
     :no-match)
   --> :no-match
@@ -40250,7 +40250,8 @@ operator matching against an association list.
   ;; a single entry matching the value of @y. This
   ;; is the k entry, whose value is 42. The @datum
   ;; value match takes this 42.
-  (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum)
+  (when-match @(hash (x @y) (@y @datum))
+              #H(() (x k) (k 42)) datum)
   --> 42
 
   ;; Again, (x @y) has a trivial key pattern so the x
@@ -40262,7 +40263,8 @@ operator matching against an association list.
   ;; hash table. The @y variable has a binding to k,
   ;; so only the (k 42) entry is matched. The 42
   ;; value matches @datum, and is collected into a list.
-  (when-match @(hash (x @y) (@(symbolp y) @datum)) #H(() (x k) (k 42)) datum)
+  (when-match @(hash (x @y) (@(symbolp @y) @datum))
+              #H(() (x k) (k 42)) datum)
   --> (42)
 .brev
 
@@ -40379,7 +40381,7 @@ it must be a bindable symbol or else
   --> (1 2 3 42)
 
   (let ((o 3))
-    (when-match (@(evenp x) @(with @z @(oddp y) o)) '(4 6)
+    (when-match (@(evenp @x) @(with @z @(oddp y) o)) '(4 6)
       (list x y z)))
   --> (4 3 6)
 .brev
@@ -40708,85 +40710,111 @@ function is capable of being called with exactly one argument.
 
 .NP* Pattern predicate operator
 .synb
-.mets >> @( function <> [ variable ])
-.mets >> @[ expression >> [ variable >> [ pattern | << variable ]]]
+.mets >> @( function << arg *)
+.mets >> @( function << arg * >> @ avar << arg *)
+.mets >> @(@ rvar >> ( function << arg *))
+.mets >> @(@ rvar >> ( function << arg * >> @ avar << arg *))
 .syne
 .desc
-Whenever the operator of a pattern predicate is not recognized and is
-a bindable symbol, that operator is assumed to be the name of a function, and
-the syntax is treated as the predicate operator.
+Whenever the operator position of a pattern consists of a symbol which is not
+the name of a predicate operator, the expression denotes a predicate pattern,
+expected to conform to one of the first two syntax descriptions above.  Whenever
+the operator position of a pattern consists of a meta-variable, it is also a
+predicate pattern, expected to conform to one of the second two syntax
+descriptions.
 
-The pattern predicate operator invokes the function, passing it the
-corresponding object as an argument. The match is successful if the function
-returns true.
-
-Optionally, if the
-.meta variable
-is specified, and is not
-.codn nil ,
-it is bound to the corresponding object.
-
-The
-.meta variable
-argument, if present, must be a
-.code bindable
-symbol, or else
+The first form of the predicate pattern consists of a compound form consisting
+of an operator and arguments. Exactly one of the arguments may be a pattern
+variable
+.meta avar
+("argument variable") which must be a bindable symbol. The role of
+.meta avar
+and the consequences of omitting it are described below.
+
+The second form of the predicate pattern consists of a meta-variable
+.meta rvar
+("result variable")
+which must be a bindable symbol or else
 .codn nil .
+This is followed by a compound form which consists of an operator
+symbol, followed by arguments, one of which may be a pattern
+.code avar
+as in the simple form.
+If
+.meta rvar
+is
+.codn nil ,
+then the predicate pattern is equivalent to the first form. That is to say,
+the following are equivalent:
 
-The
-.meta function
-must be capable of accepting exactly one argument.
+.verb
+  @(@nil (f ...))  <-->  @(f ...)
+.brev
 
-The
-.mono
-.mets >> @[ expression >> [ variable >> [ pattern | << variable ]]]
-.onom
-variant of the predicate syntax is always a predicate. It denotes the evaluation of
+The matching of the predicate pattern is processed as follows.
+If the
+.meta avar
+variable is present, then the predicate pattern first binds the
+corresponding object to the
+.meta avar
+variable, performing an ordinary variable match with the potential
+back-referencing which that implies. If that succeeds, then the object is
+inserted into the compound form, substituted in the position indicated by the
 .mono
-.meti >> [ expression << arg ]
+.meti >> @ avar
 .onom
-where
-.meta arg
-is the corresponding object, that evaluation being required to
-yield true. The
-.meta variable
-plays the same role.
+variable. This form is then evaluated. If it yields true, then the
+match is successful, otherwise the match fails.
 
-This syntax supports an optional third argument, which may be a
-.meta pattern
-or another
-.metn variable .
-This pattern or variable, if present, is matched against the value of applying
-.meta expression
-to its argument. It allows that value to be captured and subject to
-pattern matching. The restriction that this value must be true
-continues to apply.
+If the
+.meta avar
+variable is absent, then no initial variable matching takes place.
+The corresponding object is inserted as an implicit extra argument into the
+compound form, which is evaluated. Its truth value then determines the success
+of the match, just like in the case with
+.metn avar .
+
+If the second form is being processed, and specifies a
+.meta rvar
+that is not
+.codn nil ,
+and if the predicate has succeeded, then then an extra processing step takes
+place. A variable match is performed to bind the
+.meta rvar
+variable to the result of the predicate, with potential back-referencing.
+If that match succeeds, then the predicate pattern succeeds.
 
-Note: a
-.code lambda
-expression may be used as either
-.meta function
-or
-.metn expression .
+The compound form may be headed by the
+.code dwim
+operator, and therefore the DWIM bracket notation may be used.
+For instance
+.code "@[f @x]"
+is equivalent to
+.code "@(dwim f @x)"
+and is processed accordingly. Similarly,
+.code "@(@y [f @x])"
+is equivalent to
+.codn "@(@y (dwim f @x))" .
 
 .TP* Examples:
 
 .verb
-  (when-match (@(evenp) @(oddp x)) '(2 3) x) -> 3
+  (when-match (@(evenp) @(oddp @x)) '(2 3) x) -> 3
+
+  (when-match @(<= 1 @x 10) 4 x) -> 4
+
+  (when-match @(@d (chr-digit @c)) #\e5 (list d c)) -> (5 #\e5)
+
+  (when-match @(<= 1 @x 10) 11 x) -> nil
 
   ;; use hash table as predicate:
   (let ((h #H(() (a 1) (b 2))))
-    (when-match @[h x] 'a x))
+    (when-match @[h @x] 'a x))
   -> a
 
   ;; as above, also capture hash value
   (let ((h #H(() (a 1) (b 2))))
-    (when-match @[h x y] 'a (list x y)))
-  -> (a 1)
-
-  ;; as above, also capture hash value, if odd
-  (let ((h #H(() (a 1) (b 2))))
-    (when-match @[h x @(oddp y)] 'a (list x y)))
+    (when-match @(@y [h @x]) 'a (list x y)))
   -> (a 1)
 .brev