matcher: first pattern macro, sme.

* lisplib.c (match_instantiate): Intern sme symbol.

* share/txr/stdlib/doc-syms.tl: Update with sme entry.

* share/txr/stdlib/match.tl (sme): New defmatch macro.

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

* txr.1: Documented.

5 files changed, 210 insertions, 2 deletions

diff --git a/lisplib.c b/lisplib.c
index 95fa9914..422fcaaa 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -871,7 +871,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("with"), lit("scan"),
+    lit("all*"), lit("as"), lit("with"), lit("scan"), lit("sme"),
     nil
   };
   val name[] = {
diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl
index 389ea679..dfd6f178 100644
--- a/share/txr/stdlib/doc-syms.tl
+++ b/share/txr/stdlib/doc-syms.tl
@@ -407,12 +407,12 @@
      ("lset" "N-008216EC")
      ("clock-t" "N-03258244")
      ("ai-v4mapped" "N-020DFFDE")
+     ("pprinl" "N-02FCCE0D")
      ("struct-type-name" "N-00088BD7")
      ("rplacd" "D-0013")
      ("unless" "N-017EFAB6")
      ("log10" "D-0014")
      ("*hash-seed*" "N-0041D85A")
-     ("pprinl" "N-02FCCE0D")
      ("vec-push" "N-01693B82")
      ("base64-stream-enc" "N-03BEDB34")
      ("ftw-stop" "N-03853999")
@@ -1640,6 +1640,7 @@
      ("nzerop" "N-0197FF9D")
      ("*" "N-022396F7")
      ("arraysize" "N-002129D6")
+     ("sme" "N-008C6621")
      ("tcioff" "N-02173FF9")
      ("log-pid" "N-02371913")
      ("typep" "N-03B8D9EE")
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index 91885472..c43f7722 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -756,6 +756,51 @@
                                   ,args ,*body)))
        ',name)))
 
+(defmatch sme (:form f sta mid end : (mobj (gensym)) tobj)
+  (flet ((check (pat)
+           (if (or (not (listp pat))
+                   (meq (car pat) 'sys:expr 'sys:var))
+             (compile-error f
+                            "~s: list pattern expected, not ~s"
+                            'sme pat)
+             pat))
+         (check-end (pat)
+           (if (and (listp pat)
+                    (meq (car pat) 'sys:expr 'sys:var))
+             (compile-error f
+                            "~s: list or atom pattern expected, not ~s"
+                            'sme pat)
+             pat))
+         (check-sym (sym : nil-ok)
+           (cond
+             ((bindable sym) sym)
+             ((and (null sym) nil-ok) sym)
+             (t (compile-error f "~s: bindable symbol expected, not ~s"
+                               'sme sym))))
+         (loosen (pat)
+           (if (proper-list-p pat)
+             (append pat '@nil)
+             pat))
+         (pat-len (pat)
+           (if (consp pat)
+             (let ((var-op-pos (pos-if (op meq 'sys:var 'sys:expr)
+                                       (butlastn 0 pat))))
+               (if var-op-pos var-op-pos (len pat)))
+             0)))
+    (let* ((psta (loosen (check sta)))
+           (pmid (loosen (check mid)))
+           (pend (check-end end))
+           (lsta (pat-len psta))
+           (lmid (pat-len pmid))
+           (lend (pat-len pend))
+           (obj (gensym)))
+      ^@(as ,(check-sym obj)
+            @(and ,psta
+                  @(with @(scan @(as ,(check-sym mobj) ,pmid))
+                         (nthcdr ,lsta ,obj))
+                  @(with @(as ,(check-sym tobj t) ,pend)
+                         (nthlast ,lend (nthcdr ,lmid ,mobj))))))))
+
 (defun non-triv-pat-p (syntax) t)
 
 (defun non-triv-pat-p (syntax)
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index abad6b44..4be407fa 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -277,3 +277,40 @@
                ((@a 2 @b) ^(2 ,a))))
       (local 3 2 1)))
   (2 3))
+
+(test
+  (when-match @(sme (1 2) (3 4) (5 . 6) m e)
+              '(1 2 3 4 5 . 6)
+    (list m e))
+   ((3 4 5 . 6) (5 . 6)))
+
+(test
+  (when-match @(sme (1 2) (3 4) (5 . 6) m d)
+              '(1 2 abc 3 4 def 5 . 6)
+    (list m d))
+  ((3 4 def 5 . 6) (5 . 6)))
+
+(test
+  (when-match @(sme (1 2 @x . @y) (4 @z) 6)
+              '(1 2 abc 3 4 def 5 . 6)
+    (list x y z))
+  (abc (3 4 def 5 . 6) def))
+
+(test (when-match @(sme (1 2) (2 3) (4)) '(1 2 3 4) t) nil)
+(test (when-match @(sme (1 2) (3 4) (4)) '(1 2 3 4) t) nil)
+(test (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) nil)
+(test (when-match @(sme (1 2 . @x) (3 . @y) (4)) '(1 2 3 4) t) t)
+(test (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4) t) t)
+(test (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4 . 5) t) nil)
+
+(test (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2)
+        (list x y z))
+      (1 2 3))
+
+(test (when-match @(and @(sme (1 @x) (3) (7) m n)
+                        @(with @(coll @(oddp @y)) (ldiff m n)))
+                  '(1 2 3 4 5 6 7)
+        (list x y))
+      (2 (3 5)))
+
+(test (when-match @(sme () () 5) 5 t) t)
diff --git a/txr.1 b/txr.1
index 38ab830c..191dd5ef 100644
--- a/txr.1
+++ b/txr.1
@@ -41356,6 +41356,131 @@ is a standard \*(TL notation with the same meaning as
  - > (t (1 2 3))
 .brev
 
+.coNP Pattern macro @ sme
+.synb
+.mets @(sme < spat < mpat < epat >> [ mvar <> [ evar ]])
+.syne
+.desc
+The pattern macro
+.code sme
+(start, middle, end) is a notation defined using the
+.code defmatch
+macro.
+
+The
+.code sme
+macro generates a complex pattern which matches three non-overlapping
+parts of a list object using three patterns. The
+.meta spat
+pattern is required to match a prefix of the input list. If that match is
+successful, then the remainder of the list is searched for a match for
+.metn mpat ,
+using the
+.code scan
+operator. If that match, in turn, is successful, then the suffix of
+the remainder of the list is required to match
+.codn epat .
+
+The optional
+.meta mvar
+and
+.meta evar
+arguments must be bindable symbols, if they are specified.
+These symbols specify lexical variables which are bound to, respectively,
+the object matched by
+.meta mpat
+and
+.metn epat ,
+using the fresh binding semantics of the
+.code as
+pattern operator.
+
+The first two patterns,
+.meta spat
+and
+.metn mpat ,
+must be possibly dotted list patterns.
+The last pattern,
+.metn epat ,
+must be either an atom or a possibly dotted list pattern.
+
+Important to the semantics of
+.code sme
+is the concept of the length of a list pattern.
+
+The length of a pattern with a pattern variable or operator
+in the dotted position is the number of items before that variable
+or operator. The length of
+.code "(1 2 . @(and a b))"
+is 2; likewise the length of
+.code "(1 2 . @nil)"
+is also 2.
+The length of a pattern which does not have a variable or
+operator in the dotted position is simply its list length.
+For instance, the pattern
+.code "(1 2 3)"
+has length 3, and so does the pattern
+.codn "(1 2 3 . 4)" .
+The length is determined by the list object structure of the
+pattern, and not the printed syntax used to express it. Thus,
+.code "(1 . (2 3))"
+is still a length 3 pattern, because it denotes the same
+.code "(1 2 3)"
+object, using the dot notation unnecessarily.
+
+The non-overlapping semantics of
+.code sme
+develops as follows. When the
+.meta spat
+pattern matches a prefix of the input object, then a middle suffix is
+calculated of the input object by dropping leading elements from it. The number
+of elements dropped is equal to the length
+.metn spat .
+The
+.meta mpat
+is then similarly matched against a prefix of this middle suffix. If that match
+is successful, a number of leading elements equal to the length of
+.meta mpat
+is dropped from the middle suffix to determine the final suffix.
+Then
+.meta epat
+is matched against the tail portion of the final suffix which is equal
+to its length. If the final suffix is shorter than
+.metn epat ,
+then the match isn't possible.
+
+.TP* Examples:
+
+.verb
+  (when-match @(sme (1 2) (3 4) (5 . 6) m e)
+              '(1 2 3 4 5 . 6)
+    (list m e))
+  -> ((3 4 5 . 6) (5 . 6))
+
+  (when-match @(sme (1 2) (3 4) (5 . 6) m e)
+              '(1 2 abc 3 4 def 5 . 6)
+    (list m e))
+  ((3 4 def 5 . 6) (5 . 6))
+
+  ;; backreferencing
+  (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2)
+    (list x y z))
+  -> (1 2 3))
+
+  ;; collect odd items starting at 3, before 7
+  (when-match @(and @(sme (1 @x) (3) (7) m e)
+                    @(with @(coll @(oddp @y)) (ldiff m e)))
+              '(1 2 3 4 5 6 7)
+    (list x y))
+  -> (2 (3 5)))
+
+  ;; no overlap
+  (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) -> nil
+
+  ;; The atom 5 is like a "zero-length improper list".
+  (when-match @(sme () () 5) 5 t) -> t
+.brev
+
 .SS* Pattern Matching Macros
 
 .coNP Macros @ when-match and @ if-match