match: remove bad restriction from @(sme) and @(end).

The end pattern in @(sme) and @(end) does not have to be a
list pattern, dotted or otherwise. It should support any
pattern whatsoever for a single object, which should match the
terminating atom. The documentation says that, though not very
clearly; it is reworded also.

* stdlib/match.tl (check-end): Remove this function, since
the end pattern can be any pattern.
(pat-len): Bugfix: we are using the meq function incorrectly.
The object being compared against several alternatives
must be the leftmost argument of meq. This bug prevents a
pattern like @(evenp @x) to be correctly considered of
length zero.
(sme, end): Remove calls to check-end, and just refer to
original end variable.

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

* txr.1: clarify that the end pattern may be any pattern,
which can match just the terminating atom or a possibly
dotted suffix.

3 files changed, 17 insertions, 14 deletions

diff --git a/stdlib/match.tl b/stdlib/match.tl
index e535ec45..12479fab 100644
--- a/stdlib/match.tl
+++ b/stdlib/match.tl
@@ -895,12 +895,6 @@
     (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 'sys:quasi))
-    (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)
@@ -914,7 +908,7 @@
 
 (defun pat-len (pat)
   (if (consp pat)
-    (let ((var-op-pos (pos-if (op meq 'sys:var 'sys:expr 'sys:quasi)
+    (let ((var-op-pos (pos-if (lop meq 'sys:var 'sys:expr 'sys:quasi)
                               (butlastn 0 pat))))
       (if var-op-pos var-op-pos (len pat)))
     0))
@@ -922,24 +916,22 @@
 (defmatch sme (:form f sta mid end : (mvar (gensym)) eobj)
   (let* ((psta (loosen (check f 'sme sta)))
          (pmid (loosen (check f 'sme mid)))
-         (pend (check-end f 'sme end))
          (lsta (pat-len psta))
          (lmid (pat-len pmid))
-         (lend (pat-len pend))
+         (lend (pat-len end))
          (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)
+                @(with @(as ,(check-sym f 'sme eobj t) ,end)
                        (nthlast ,lend (nthcdr ,lmid ,mvar)))))))
 
 (defmatch end (:form f end : evar)
-  (let* ((pend (check-end f 'end end))
-         (lend (pat-len pend))
+  (let* ((lend (pat-len end))
          (obj (gensym)))
     ^@(as ,(check-sym f 'end obj)
-          @(with @(as ,(check-sym f 'end evar t) ,pend)
+          @(with @(as ,(check-sym f 'end evar t) ,end)
                  (nthlast ,lend ,obj)))))
 
 (defun non-triv-pat-p (syntax)
diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl
index bb67e32e..6d071f3d 100644
--- a/tests/011/patmatch.tl
+++ b/tests/011/patmatch.tl
@@ -602,6 +602,16 @@
   (match @gs 0 gs) :error
   (match @gs :gs gs) :gs)
 
+(mtest
+  (match @(end @x) '(1 . 2) x) 2
+  (match @(end @(evenp @x)) '(1 . 2) x) 2
+  (match @(end (@z . @x)) '(1 . 2) (list z x)) (1 2)
+  (match @(end (@z . @(evenp @x))) '(1 . 2) (list z x)) (1 2))
+
+(mtest
+  (match @(sme (@a) (@b) @x) '(0 1 . 2) (list a b x)) (0 1 2)
+  (match @(sme (@a) (@b) @(evenp @x)) '(0 1 . 2) (list a b x)) (0 1 2))
+
 (compile-only
   (eval-only
     (with-compile-opts (nil unused)
diff --git a/txr.1 b/txr.1
index c6dfe829..3d02e35d 100644
--- a/txr.1
+++ b/txr.1
@@ -47579,7 +47579,8 @@ and
 must be possibly dotted list patterns.
 The last pattern,
 .metn epat ,
-must be either an atom or a possibly dotted list pattern.
+may be any pattern: it may be an atom match for the terminating
+atom, or a possibly dotted list pattern matching the list suffix.
 
 Important to the semantics of
 .code sme