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.

2 files changed, 53 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)