matcher: new pattern operator @(end)

* share/txr/stdlib/doc-syms.tl: New entry for end.

* share/txr/stdlib/match.tl (check, check-end, check-sym,
loosen, pat-len): New functions, taken from original local
functions of sme macro.
(sme): Refactored by hoisting local functions out. Some
local variable renaming.
(end): New pattern macro.

* tests/011/patmatch.tl: New test for end.

* txr.1: Documented.

4 files changed, 118 insertions, 44 deletions

diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl
index dfd6f178..b980e6b3 100644
--- a/share/txr/stdlib/doc-syms.tl
+++ b/share/txr/stdlib/doc-syms.tl
@@ -405,6 +405,7 @@
      ("*args-full*" "N-03DEE18A")
      ("atom" "N-0076C7BE")
      ("lset" "N-008216EC")
+     ("end" "N-037C6608")
      ("clock-t" "N-03258244")
      ("ai-v4mapped" "N-020DFFDE")
      ("pprinl" "N-02FCCE0D")
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index c43f7722..3026ab0a 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -756,50 +756,58 @@
                                   ,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 check (f op pat)
+  (if (or (not (listp pat))
+          (meq (car pat) 'sys:expr 'sys:var))
+    (compile-error f "~s: list pattern expected, not ~s" op pat)
+    pat))
+
+(defun check-end (f op pat)
+  (if (and (listp pat)
+           (meq (car pat) 'sys:expr 'sys:var))
+    (compile-error f "~s: list or atom pattern expected, not ~s" op pat)
+    pat))
+
+(defun check-sym (f op sym : nil-ok)
+  (cond
+    ((bindable sym) sym)
+    ((and (null sym) nil-ok) sym)
+    (t (compile-error f "~s: bindable symbol expected, not ~s" op sym))))
+
+(defun loosen (f pat)
+  (if (proper-list-p pat)
+    (append pat '@nil)
+    pat))
+
+(defun pat-len (f 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))
+
+(defmatch sme (:form f sta mid end : (mvar (gensym)) eobj)
+  (let* ((psta (loosen f (check f 'sme sta)))
+         (pmid (loosen f (check f 'sme mid)))
+         (pend (check-end f 'sme end))
+         (lsta (pat-len f psta))
+         (lmid (pat-len f pmid))
+         (lend (pat-len f pend))
+         (obj (gensym)))
+    ^@(as ,(check-sym f 'sme obj)
+          @(and ,psta
+                @(with @(scan @(as ,(check-sym f 'sme mvar) ,pmid))
+                       (nthcdr ,lsta ,obj))
+                @(with @(as ,(check-sym f 'sme eobj t) ,pend)
+                       (nthlast ,lend (nthcdr ,lmid ,mvar)))))))
+
+(defmatch end (:form f end : evar)
+  (let* ((pend (check-end f 'end end))
+         (lend (pat-len f pend))
+         (obj (gensym)))
+    ^@(as ,(check-sym f 'end obj)
+          @(with @(as ,(check-sym f 'end evar t) ,pend)
+                 (nthlast ,lend ,obj)))))
 
 (defun non-triv-pat-p (syntax) t)
 
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index 4be407fa..346b21b6 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -314,3 +314,10 @@
       (2 (3 5)))
 
 (test (when-match @(sme () () 5) 5 t) t)
+
+(test (when-match @(end 3 x) 3 x) 3)
+(test (when-match @(end (2 @x) y) '(1 2 3) (list x y)) (3 (2 3)))
+(test (when-match @(end (2 . @x) y) '(1 2 . 3) (list x y)) (3 (2 . 3)))
+
+(test (when-match @(as z @(end (2 @x) y)) '(1 2 3) (list x y z))
+      (3 (2 3) (1 2 3)))
diff --git a/txr.1 b/txr.1
index 191dd5ef..34b68440 100644
--- a/txr.1
+++ b/txr.1
@@ -41481,6 +41481,64 @@ then the match isn't possible.
   (when-match @(sme () () 5) 5 t) -> t
 .brev
 
+.coNP Pattern macro @ end
+.synb
+.mets @(end < pattern <> [ var ])
+.syne
+.desc
+The pattern macro
+.code end
+is a notation defined using the
+.code defmatch
+macro, which matches
+.meta pattern
+against the suffix of a corresponding list object,
+which may be an improper list or atom.
+
+The optional argument
+.meta var
+specifies the name of a variable which captures the matched portion of the
+object.
+
+The
+.code end
+macro is related to the
+.code sme
+macro according to the following equivalence:
+
+.verb
+  @(end pat var)  <-->  @(sme () () pat : : var)
+.brev
+
+All of the requirements given for
+.code sme
+apply accordingly.
+
+.TP* Examples:
+
+.verb
+  ;; atom match
+  (when-match @(end 3 x) 3 x) -> 3
+
+  ;; y captures (2 3)
+  (when-match @(end (2 @x) y)
+             '(1 2 3)
+    (list x y))
+  -> (3 (2 3))
+
+  ;; variable in dot position
+  (when-match @(end (2 . @x) y)
+              '(1 2 . 3)
+    (list x y))
+  -> (3 (2 . 3))
+
+  ;; z captures entire object
+  (when-match @(as z @(end (2 @x) y))
+             '(1 2 3)
+    (list x y z))
+  -> (3 (2 3) (1 2 3)))
+.brev
+
 .SS* Pattern Matching Macros
 
 .coNP Macros @ when-match and @ if-match