diff options
| -rw-r--r-- | lisplib.c | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/doc-syms.tl | 4 | ||||
| -rw-r--r-- | share/txr/stdlib/match.tl | 48 | ||||
| -rwxr-xr-x | tags.tl | 2 | ||||
| -rw-r--r-- | txr.1 | 97 |
5 files changed, 133 insertions, 21 deletions
@@ -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) @@ -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)))) @@ -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 |