matcher: allow pat/var argument: @[expr var pat]

* share/txr/stdlib/match.tl (compile-dwim-predicate-match):
Drop redundant bindable check of sym, since compile-var-match
checks this. Support third argument which gives a pattern or
variable which captures the value from the predicate function,
which might be interesting (not just true/false).

* tests/011/patmatch.tl: New tests.

* txr.1: Documented.

3 files changed, 60 insertions, 13 deletions

diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 00918f37..04118c64 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -195,12 +195,28 @@
     var-match))
 
 (defun compile-dwim-predicate-match (pred-expr obj-var var-list)
-  (mac-param-bind *match-form* (dwim fun : sym) pred-expr
-    (or (null sym) (bindable sym)
-        (compile-error *match-form* "~s is not a symbol" sym))
+  (mac-param-bind *match-form* (dwim fun : sym pat) pred-expr
     (let ((var-match (compile-var-match sym obj-var var-list)))
-      (set var-match.test-expr ^(and ,var-match.test-expr [,fun ,obj-var]))
-      var-match)))
+      (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
+                           vars (list pat-match.obj-var)
+                           var-exprs (list ^[,fun ,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))
+               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)))
+        (progn
+          (set var-match.test-expr ^(and ,var-match.test-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
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index c9326eda..784588ad 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -147,3 +147,11 @@
 
 (test (when-match @a..@b '1..2 (list a b)) (1 2))
 (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 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)))
+      (a 1))
diff --git a/txr.1 b/txr.1
index 48473af6..a660a675 100644
--- a/txr.1
+++ b/txr.1
@@ -40519,8 +40519,8 @@ function is capable of being called with exactly one argument.
 
 .NP* Pattern predicate operator
 .synb
-.mets >> @( function <> [ symbol ])
-.mets >> @[ expression <> [ symbol ]]
+.mets >> @( function <> [ variable ])
+.mets >> @[ expression >> [ variable >> [ pattern | << variable ]]]
 .syne
 .desc
 Whenever the operator of a pattern predicate is not recognized and is
@@ -40532,13 +40532,13 @@ corresponding object as an argument. The match is successful if the function
 returns true.
 
 Optionally, if the
-.meta symbol
+.meta variable
 is specified, and is not
 .codn nil ,
 it is bound to the corresponding object.
 
 The
-.meta symbol
+.meta variable
 argument, if present, must be a
 .code bindable
 symbol, or else
@@ -40550,15 +40550,28 @@ must be capable of accepting exactly one argument.
 
 The
 .mono
-.meti >> @[ expression <> [ symbol ]]
+.mets >> @[ expression >> [ variable >> [ pattern | << variable ]]]
 .onom
-version of the syntax is always a predicate. It denotes the evaluation of
+variant of the predicate syntax is always a predicate. It denotes the evaluation of
 .mono
 .meti >> [ expression << arg ]
 .onom
 where
 .meta arg
-is the corresponding object.
+is the corresponding object, that evaluation being required to
+yield true. The
+.meta variable
+plays the same role.
+
+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.
 
 Note: a
 .code lambda
@@ -40567,7 +40580,7 @@ expression may be used as either
 or
 .metn expression .
 
-.TP* Example:
+.TP* Examples:
 
 .verb
   (when-match (@(evenp) @(oddp x)) '(2 3) x) -> 3
@@ -40576,6 +40589,16 @@ or
   (let ((h #H(() (a 1) (b 2))))
    (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 @(odd y)] 'a (list x y)))
+  -> (a 1)
 .brev
 
 .coNP Macros @ when-match and @ if-match