matcher: new @(with) operator.

* lisplib.c (match_instantiate): Ensure usr:with is interned.

* share/txr/stdlib/match.tl (compile-with-match): New
function.
(compile-match): Wire in with operator.

* tests/011/patmatch.tl: Test cases.

* txr.1: Documented.

4 files changed, 74 insertions, 1 deletions

diff --git a/lisplib.c b/lisplib.c
index 60612575..c0d6ded0 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -870,7 +870,7 @@ static val match_instantiate(val set_fun)
 static val match_set_entries(val dlt, val fun)
 {
   val name_noload[] = {
-    lit("all*"), lit("as"),
+    lit("all*"), lit("as"), lit("with"),
     nil
   };
   val name[] = {
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 6c57e0b9..06f028c7 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -329,6 +329,24 @@
            guard-chain (append var-match.guard-chain
                                pat-match.guard-chain)))))
 
+(defun compile-with-match (exp obj-var var-list)
+  (mac-param-bind *match-form* (op side-pat-var side-expr main-pat) exp
+    (let* ((side-var (gensym))
+           (side-pat (if (or (null side-pat-var) (bindable side-pat-var))
+                       ^(sys:var ,side-pat-var)
+                       side-pat-var))
+           (side-match (compile-match side-pat side-var var-list))
+           (main-match (compile-match main-pat obj-var var-list))
+           (guard (new match-guard
+                      pure-temps (list side-var)
+                      pure-temp-exprs (list side-expr))))
+      (new compiled-match
+           pattern exp
+           obj-var obj-var
+           guard-chain (append (list guard)
+                               side-match.guard-chain
+                               main-match.guard-chain)))))
+
 (defun compile-loop-match (exp obj-var var-list)
   (mac-param-bind *match-form* (op match) exp
     (let* ((no-vac-p (memq op '(coll usr:all*)))
@@ -489,6 +507,7 @@
                  (struct (compile-struct-match exp obj-var var-list))
                  (require (compile-require-match exp obj-var var-list))
                  (usr:as (compile-as-match exp obj-var var-list))
+                 (usr:with (compile-with-match exp obj-var var-list))
                  (all (compile-loop-match exp obj-var var-list))
                  (usr:all* (compile-loop-match exp obj-var var-list))
                  (some (compile-loop-match exp obj-var var-list))
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index f8f6b03f..0068eabb 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -116,6 +116,14 @@
 
 (test (when-match (@a @(as a @(or x @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes)
 
+(test (when-match (@(with x 42 @a) @b @c) '(1 2 3) (list a b c x))
+      (1 2 3 42))
+
+(test (let ((o 3))
+        (when-match (@(evenp x) @(with @(oddp y) o @z)) '(4 6)
+          (list x y z)))
+      (4 3 6))
+
 (defstruct node ()
   left right)
 
diff --git a/txr.1 b/txr.1
index 10b9bdd1..85711d4c 100644
--- a/txr.1
+++ b/txr.1
@@ -40266,6 +40266,52 @@ as its value.
   -> ((1 2 3) 1 2 3)
 .brev
 
+.coNP Pattern operator @ with
+.synb
+.mets @(with >> [ side-pattern | << name ] < expr << main-pattern )
+.syne
+.desc
+The
+.code with
+pattern operator matches the
+.meta main-pattern
+against a corresponding object, while matching a
+.meta side-pattern
+or
+.meta name
+against the value of the expression
+.meta expr
+which is embedded in the syntax.
+
+
+First,
+.meta expr
+is evaluated in the scope of earlier pattern variables. It is unspecified
+whether later pattern variables are visible. The matching of
+.meta side-pattern
+follows, and if that succeeds, then the matching of
+.meta main-pattern
+against the corresponding object takes place.
+
+If a
+.meta name
+is specified instead of a
+.metn side-pattern ,
+it must be a bindable symbol or else
+.metn nil .
+
+.TP* Examples:
+
+.verb
+  (when-match (@(with x 42 @a) @b @c) '(1 2 3) (list a b c x))
+  --> (1 2 3 42)
+
+  (let ((o 3))
+    (when-match (@(evenp x) @(with @(oddp y) o @z)) '(4 6)
+      (list x y z)))
+  --> (4 3 6)
+.brev
+
 .coNP Pattern operator @ require
 .synb
 .mets @(require < pattern << condition *)