matcher: allow user-defined patterns via defmatch

* lisplib.c (match_set_entries): Register defmatch
and *match-symbol* to autoload match.tl.

* share/txr/stdlib/doc-syms.tl: Updated with entries for
defmatch and *match-macro*.

* share/txr/stdlib/match.tl (*match-macro*): New special
variable holding hash.
(compile-match): Handle macros via *match-macro* hash.
(defmatch): New macro.

* txr.1: Documented.

* tags.tl: Recognize defmatch forms.

2 files changed, 36 insertions, 16 deletions

diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl
index 923d6ba2..939976de 100644
--- a/share/txr/stdlib/doc-syms.tl
+++ b/share/txr/stdlib/doc-syms.tl
@@ -544,6 +544,7 @@
      ("fun-variadic" "N-02AA3799")
      ("sock-family" "N-0323EB36")
      ("keyword-package" "N-0383342A")
+     ("*match-macro*" "N-012A473F")
      ("get-prop" "N-00663AE2")
      ("caseq" "N-017EB9A1")
      ("test-clear" "N-036C7E9E")
@@ -917,6 +918,7 @@
      ("w-ifsignaled" "N-0243C575")
      ("ors" "N-02D33A3D")
      ("symbolp" "N-01C0BF69")
+     ("defmatch" "N-0049315A")
      ("poll" "N-0386D39D")
      ("path-cat" "N-0033B27E")
      ("command-get-buf" "N-00FA177D")
@@ -1094,12 +1096,12 @@
      ("long" "N-018C7C8C")
      ("enobufs" "N-036B1BDB")
      ("unuse-sym" "N-01AF42B7")
+     ("tostringp" "N-02FCCE0D")
      ("call-super-method" "N-016185D1")
      ("struct-type-p" "N-00717410")
      ("buf-put-ushort" "N-035696C9")
      ("sum" "N-0163FFE2")
      ("with-hash-iter" "N-001B79C0")
-     ("tostringp" "N-02FCCE0D")
      ("eval" "N-0286C8B8")
      ("test-inc" "N-01A4228F")
      ("stdlib" "N-008E4BC2")
diff --git a/share/txr/stdlib/match.tl b/share/txr/stdlib/match.tl
index ad983bb0..bfb0ef2a 100644
--- a/share/txr/stdlib/match.tl
+++ b/share/txr/stdlib/match.tl
@@ -26,6 +26,8 @@
 
 (defvar *match-form*)
 
+(defvar *match-macro* (hash))
+
 (defstruct match-guard ()
   temps
   vars
@@ -541,21 +543,27 @@
          (sys:expr
            (let ((exp (cadr pat)))
              (if (consp exp)
-               (caseq (car exp)
-                 (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))
-                 (coll (compile-loop-match exp obj-var var-list))
-                 (or (compile-or-match exp obj-var var-list))
-                 (and (compile-and-match exp obj-var var-list))
-                 (not (compile-not-match exp obj-var var-list))
-                 (hash (compile-hash-match exp obj-var var-list))
-                 (exprs (compile-exprs-match exp obj-var var-list))
-                 (t (compile-predicate-match exp obj-var var-list)))
+               (let ((op (car exp)))
+                 (caseq op
+                   (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))
+                   (coll (compile-loop-match exp obj-var var-list))
+                   (or (compile-or-match exp obj-var var-list))
+                   (and (compile-and-match exp obj-var var-list))
+                   (not (compile-not-match exp obj-var var-list))
+                   (hash (compile-hash-match exp obj-var var-list))
+                   (exprs (compile-exprs-match exp obj-var var-list))
+                   (t (iflet ((xfun [*match-macro* op]))
+                        (let ((xexp [xfun exp]))
+                          (if (neq xexp exp)
+                            (compile-match xexp obj-var var-list)
+                            (compile-predicate-match exp obj-var var-list)))
+                        (compile-predicate-match exp obj-var var-list)))))
                (compile-error *match-form*
                               "unrecognized pattern syntax ~s" pat))))
          (sys:var (compile-var-match (cadr pat) obj-var var-list))
@@ -717,6 +725,16 @@
                       (nthlast 0 lparams))
               body)))))
 
+(defmacro defmatch (name destructuring-args . body)
+  (with-gensyms (name-dummy args)
+    ^(progn
+       (sethash *match-macro* ',name
+                (lambda (,args)
+                  (mac-param-bind ,args
+                                  (,name-dummy ,*destructuring-args)
+                                  ,args ,*body)))
+       ',name)))
+
 (defun non-triv-pat-p (syntax) t)
 
 (defun non-triv-pat-p (syntax)