summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--lisplib.c3
-rw-r--r--share/txr/stdlib/doc-syms.tl4
-rw-r--r--share/txr/stdlib/match.tl48
-rwxr-xr-xtags.tl2
-rw-r--r--txr.197
5 files changed, 133 insertions, 21 deletions
diff --git a/lisplib.c b/lisplib.c
index c37cb4a5..a8e8c8de 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -876,7 +876,8 @@ static val match_set_entries(val dlt, val fun)
};
val name[] = {
lit("when-match"), lit("match-case"), lit("if-match"),
- lit("lambda-match"), lit("defun-match"),
+ lit("lambda-match"), lit("defun-match"), lit("defmatch"),
+ lit("*match-macro*"),
nil
};
val match_k = intern(lit("match"), keyword_package);
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)
diff --git a/tags.tl b/tags.tl
index b9321a74..32008e80 100755
--- a/tags.tl
+++ b/tags.tl
@@ -115,7 +115,7 @@
(caseq (car obj)
((progn eval-only compile-only with-dyn-lib macro-time)
(pend [mappend (op process-form path lines) (cdr obj)]))
- ((defun defmacro define-place-macro deffi deffi-cb)
+ ((defun defmacro define-place-macro defmatch deffi deffi-cb)
(add (ntag fun-tag (cadr obj))))
((defvar defvarl defparm defparml defsymacro)
(add (ntag var-tag (cadr obj))))
diff --git a/txr.1 b/txr.1
index b94947c0..11cd5aab 100644
--- a/txr.1
+++ b/txr.1
@@ -40271,6 +40271,25 @@ one for each list position. This is because macro-style parameter lists are
oriented toward writing macros, and macros usually make use of every parameter
position.
+.NP* Application-defined Patterns
+
+Application-defined pattern operators are possible. When the
+.meta operator
+symbol in the
+.mono
+.meti >> @( operator << argument *)
+.onom
+syntax doesn't match any built-in operator, a search takes
+place to determine whether
+.meta operator
+is a pattern macro. If so, the pattern macro is expanded, and
+its result of the expansion treated as a pattern to process recursively,
+unless it is the original macro form, in which case it is treated
+as a predicate pattern. Application-defined pattern macros are defined
+using the
+.code defmatch
+macro.
+
.SS* Pattern Matching Notation
The pattern-matching notation is documented in the following
@@ -41136,9 +41155,14 @@ operator.
.mets >> @(@ rvar >> ( function << arg * . <> @ avar ))
.syne
.desc
-Whenever the operator position of a pattern consists of a symbol which is not
-the name of a pattern operator, the expression denotes a predicate pattern,
-expected to conform to one of the first three syntax variations above.
+Whenever the operator position of a pattern consists of a symbol which is
+neither the name of a pattern operator, nor the name of a macro, the expression
+denotes a predicate pattern. An expression is also a predicate pattern if
+it is handled by a pattern macro which declines to expand it by yielding
+the original expression.
+
+An operator pattern is expected to conform to one of the first three
+syntactic variations above.
Together, these three variations constitute the
.I "first form"
of the pattern predicate operator.
@@ -41810,6 +41834,73 @@ in which case it inserts its own generated symbol.
width 0 height 0)
.brev
+.coNP Macro @ defmatch
+.synb
+.mets (defmatch < name < macro-style-params
+.mets \ \ << body-form *)
+.syne
+.desc
+The
+.code defmatch
+macro allows for the definition of pattern macros: application-defined pattern
+operators which are implemented via expansion into existing operator syntax.
+
+The
+.code defmatch
+macro has the same syntax as
+.codn defmacro .
+It specifies a macro transformation for a compound form which has the
+.meta name
+symbol in its leftmost position.
+
+This macro transformation is performed when
+.meta name
+is used as a pattern operator: an expression of the form
+.mono
+.meti >> @( name << argument *)
+.onom
+occurring in pattern matching syntax.
+
+The behavior is unspecified if
+.meta name
+is the name a built-in pattern operator, or a predefined pattern macro.
+
+The pattern macro bindings are stored in a hash table held by the variable
+.code *match-macro*
+whose keys are symbols, and whose values are expander functions.
+There are no lexically scoped pattern macros.
+
+.TP* Example:
+
+.verb
+ ;; Create an alias called let for the @(as var pattern) operator:
+ ;; Note that the macro produces @(as ...) and not just (as ...)
+
+ (defmatch let (var pattern)
+ ^@(as ,var ,pattern))
+
+ ;; use the macro in matching:
+ (when-match @(let x @(or foo bar)) 'foo x)
+.brev
+
+.coNP Special variable @ *match-macro*
+.desc
+The
+.code *match-macro*
+special variable holds the hash table of associations between
+symbols and pattern macro expanders.
+
+If the expression
+.code "[*place-macro* 'sym]"
+yields a function, then symbol
+.code sym
+has a binding as a pattern macro. If that
+expression yields
+.codn nil ,
+then there is no such binding: pattern operator forms based on
+.code sym
+do not undergo place macro expansion.
+
.SS* Quasiquote Operator Syntax
.coNP Macro @ qquote
.synb