* share/txr/stdlib/txr-case.txr: New file.

* txr.1: Document txr-if, txr-when and txr-case.

* genvim.txr: Added new macro names.

* tests/011/txr-case.expected: New file.

* tests/011/txr-case.txr: New file.

* txr.vim: Regenerated.

7 files changed, 299 insertions, 8 deletions

diff --git a/ChangeLog b/ChangeLog
index 72c52894..98873158 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,17 @@
+2014-10-21  Kaz Kylheku  <kaz@kylheku.com>
+
+	* share/txr/stdlib/txr-case.txr: New file.
+
+	* txr.1: Document txr-if, txr-when and txr-case.
+
+	* genvim.txr: Added new macro names.
+
+	* tests/011/txr-case.expected: New file.
+
+	* tests/011/txr-case.txr: New file.
+
+	* txr.vim: Regenerated.
+
 2014-10-20  Kaz Kylheku  <kaz@kylheku.com>
 
 	Source file inclusion implemented: needed for macros.
diff --git a/genvim.txr b/genvim.txr
index e49f8416..1196620f 100644
--- a/genvim.txr
+++ b/genvim.txr
@@ -39,7 +39,8 @@ static void dir_tables_init(void)
                            "until" "last"
                            "if" "else" "elif"
                            "include")))
-@(do (set [txl-sym 0..0] '("macro-time" "macrolet" "symacrolet")))
+@(do (set [txl-sym 0..0] '("macro-time" "macrolet" "symacrolet"
+                           "txr-if" "txr-when" "txr-case")))
 @(set (txr-sym txl-sym) (@(sort (uniq txr-sym)) @(sort (uniq txl-sym))))
 @(output)
 " VIM Syntax file for txr
diff --git a/share/txr/stdlib/txr-case.txr b/share/txr/stdlib/txr-case.txr
new file mode 100644
index 00000000..4d0081b3
--- /dev/null
+++ b/share/txr/stdlib/txr-case.txr
@@ -0,0 +1,48 @@
+@(do
+   (macro-time
+     (defun bindable (obj)
+       (and obj
+            (symbolp obj)
+            (not (keywordp obj))
+            (not (eq t obj)))))
+
+   (defmacro txr-if (name args input : then else)
+     (let ((syms [keep-if bindable args])
+           (arg-exprs [mapcar [iffi symbolp (ret ^',@1)] args])
+           (result (gensym "res-"))
+           (bindings (gensym "bindings-"))
+           (insym (gensym "input-")))
+       ^(let* ((,insym ,input)
+               (,result (match-fun ',name (list ,*arg-exprs)
+                                   (if (stringp ,insym) (list ,insym) ,insym)
+                                   nil)))
+          (if ,result
+            (let ((,bindings (car ,result)))
+              (let (,*[mapcar (ret ^(,@1 (cdr (assoc ',@1 ,bindings))))
+                              syms])
+                ,then))
+            ,else))))
+
+   (defmacro txr-when (name args input . body)
+     ^(txr-if ,name ,args ,input (progn ,*body)))
+
+   (defmacro txr-case-impl (sym . clauses)
+     (tree-case clauses
+       (((name args . body) . other-clauses)
+        (if (eq name t) :
+          ^(txr-if ,name ,args ,sym
+             (progn ,*body)
+             (txr-case-impl ,sym ,*other-clauses))))
+       (((sym . rest) . other-clauses)
+        (if (eq sym t)
+          (if other-clauses
+            (error "txr-case: clauses after (t ...) clause ignored")
+            ^(progn ,*rest))
+          (error "txr-case: bad syntax: ~s" (car clauses))))
+       (atom
+          (error "txr-case: unexpected atom in syntax: ~s" atom))))
+
+   (defmacro txr-case (input-expr . clauses)
+     (let ((input (gensym "input-")))
+       ^(let ((,input ,input-expr))
+          (txr-case-impl ,input ,*clauses)))))
diff --git a/tests/011/txr-case.expected b/tests/011/txr-case.expected
new file mode 100644
index 00000000..4af473e5
--- /dev/null
+++ b/tests/011/txr-case.expected
@@ -0,0 +1,4 @@
+no match for 09-10-20
+match: year 2009, month 10, day 20
+no match for July-15-2014
+no match for foo
diff --git a/tests/011/txr-case.txr b/tests/011/txr-case.txr
new file mode 100644
index 00000000..f427be9e
--- /dev/null
+++ b/tests/011/txr-case.txr
@@ -0,0 +1,9 @@
+@(include `@stdlib/txr-case`)
+@(define date (year month day))
+@{year /\d\d\d\d/}-@{month /\d\d/}-@{day /\d\d/}
+@(end)
+@(do
+   (each ((date '("09-10-20" "2009-10-20" "July-15-2014" "foo")))
+     (txr-if date (y m d) date
+       (put-line `match: year @y, month @m, day @d`)
+       (put-line `no match for @date`))))
diff --git a/txr.1 b/txr.1
index 066b30a7..d6853dfe 100644
--- a/txr.1
+++ b/txr.1
@@ -253,6 +253,14 @@
 .de syne
 .  cble
 ..
+.\" Require section markup
+.de reqb
+.  TP* Requires:
+.  cblk
+..
+.de reqe
+.  cble
+..
 .\" Used for meta-variables in syntax blocks
 .de mets
 .  nr fsav \\n[.f]
@@ -23958,6 +23966,29 @@ using
 and the result of that is returned.
 
 .SS* Access To TXR Pattern Language From Lisp
+
+It is useful to be able to invoke the abilities of the \*(TX pattern Language
+from \*(TL. An interface for doing this provided in the form of the
+.code match-fun
+function, which is used for invoking a \*(TX pattern function.
+
+The
+.code match-fun
+function has a cumbersome interface which requires the \*(TL program to
+explicitly deal with the variable bindings emerging from the pattern match
+in the form of an association list.
+
+To make it the interface easier to use, \*(TX provides a library of macros:
+the macros
+.codn txr-if ,
+.codn txr-when
+and
+.codn txr-case .
+
+These macros are not in the \*(TX image; they must be included from the
+.code stdlib
+directory.
+
 .coNP Function match-fun
 .synb
 .mets (match-fun < name < args < input << files )
@@ -24078,6 +24109,189 @@ out of the pattern function
 .codn foo ;
 it is local inside it.
 
+.coNP Macro txr-if
+.reqb
+.mets @(include `@stdlib/txr-case`)
+.reqe
+.synb
+.mets (txr-if < name <> ( argument *) < input < then-expr <> [ else-expr ])
+.syne
+.desc
+The
+.code txr-if
+macro invokes the \*(TX pattern matching function
+.metn name
+on some input given by the
+.meta input
+parameter, which is a list of strings, or a single string.
+
+If
+.meta name
+succeeds, then
+.meta then-expr
+is evaluated, and if it fails,
+.meta else-expr
+is evaluated instead.
+
+In the successful case,
+.meta then-expr
+is evaluated in a scope in which the bindings emerging from the
+.meta name
+function are turned into \*(TL variables.
+The result of
+.code txr-if
+is that of
+.metn then-expr .
+
+In the failed case,
+.meta else-expr
+is evaluated in a scope which does not have any new bindings.
+The result of
+.code txr-if
+is that of
+.metn else-expr .
+If
+.meta else-expr
+is missing, the result is
+.codn nil .
+
+The
+.meta argument
+forms supply arguments to the pattern function
+.metn name .
+There must be as many of these arguments as the function
+has parameters.
+
+Any argument which is a symbol is treated, for the purposes
+of calling the pattern function, as an unbound pattern variable.
+The function may or may not produce a binding for that variable.
+Also, every argument which is a symbol also denotes a local variable
+that is established around
+.meta then-expr
+if the function suceeds. For any such pattern variable for which the function
+produces a binding, the corresponding local variable will be initialized
+with the value of that pattern variable. For any such pattern variable
+which is left unbound by the function, the corresponding local variable
+will be set to
+.codn nil .
+
+Any
+.meta argument
+can be a form other than a symbol. In this situation, the argument is
+evaluated, and will be passed to the pattern function as the value of
+the binding for the corresponding argument.
+
+.TP* Example:
+
+.cblk
+  @(include `@stdlib/txr-case`)
+  @(define date (year month day))
+  @{year /\d\d\d\d/}-@{month /\d\d/}-@{day /\d\d/}
+  @(end)
+  @(do
+     (each ((date '("09-10-20" "2009-10-20" "July-15-2014" "foo")))
+       (txr-if date (y m d) date
+         (put-line `match: year @y, month @m, day @d`)
+         (put-line `no match for @date`))))
+
+  Output:
+
+  no match for 09-10-20
+  match: year 2009, month 10, day 20
+  no match for July-15-2014
+  no match for foo
+.cble
+
+.coNP Macro @ txr-when
+.reqb
+.mets @(include `@stdlib/txr-case`)
+.reqe
+.synb
+.mets (txr-when < name <> ( argument *) < input << form *)
+.syne
+.desc
+The
+.code txr-when
+macro is based on
+.codn txr-if .
+It is equivalent to
+.code
+
+.cblk
+.meti \ \ (txr-if < name <> ( argument *) < input (progn << form *))
+.cble
+
+If the pattern function
+.meta name
+produces a match, then each
+.meta form
+is evaluated in the scope of the variables established by the
+.meta argument
+expressions. The result of the
+.code txr-when
+form is that of the last
+.metn form .
+
+If the pattern function fails then the forms are not evaluated,
+adn the result value is
+.codn nil .
+
+.coNP Macro @ txr-case
+.reqb
+.mets @(include `@stdlib/txr-case`)
+.reqe
+.synb
+.mets (txr-case < input-form
+.mets \ \  >> {( name <> ( argument *) << form *)}*
+.mets \ \  >> [( t << form *)])
+.syne
+.desc
+The
+.code txr-case
+macro evaluates
+.meta input-form
+and then uses the value as an input to zero or more test clauses.
+Each test clause invokes the pattern function named by that clause's
+.meta name
+argument.
+
+If the function succeeds, then each
+.meta form
+is evaluated, and the value of the last
+.meta form
+is taken to be the result value of
+.codn txr-case ,
+which terminates. If there are no forms, then
+.code txr-case
+terminates with a
+.code nil
+result.
+
+The forms are evaluated in an environment in which variables are bound
+based on the
+.meta argument
+forms, with values depending on the result of the
+invocation of the
+.meta name
+pattern function, in the same manner as documented in detail for the
+.code txr-if
+macro.
+
+If the function fails, then the forms are not evaluated, and control passes to
+the next clause.
+
+A clause which begins with the symbol
+.code t
+executes unconditionally and causes
+.code txr-case
+to terminate. If it has no forms, then
+.code txr-case
+yields
+.codn nil ,
+otherwise the forms are evaluated in order and the value of the last
+one specifies the result of
+.codn txr-case .
+
 .SS* Quote/Quasiquote Operator Syntax
 .coNP Operator @ quote
 .synb
diff --git a/txr.vim b/txr.vim
index e25a12b1..b4ccba96 100644
--- a/txr.vim
+++ b/txr.vim
@@ -185,13 +185,14 @@ syn keyword txl_keyword contained tok-str tok-where tostring tostringp
 syn keyword txl_keyword contained transpose tree-bind tree-case tree-find
 syn keyword txl_keyword contained trie-add trie-compress trie-lookup-begin trie-lookup-feed-char
 syn keyword txl_keyword contained trie-value-at trim-str true trunc
-syn keyword txl_keyword contained tuples typeof unget-byte unget-char
-syn keyword txl_keyword contained uniq unless unquote until
-syn keyword txl_keyword contained upcase-str update url-decode url-encode
-syn keyword txl_keyword contained usleep uw-protect vec vec-push
-syn keyword txl_keyword contained vec-set-length vecref vector vector-list
-syn keyword txl_keyword contained vectorp when where while
-syn keyword txl_keyword contained with-saved-vars zerop zip
+syn keyword txl_keyword contained tuples txr-case txr-if txr-when
+syn keyword txl_keyword contained typeof unget-byte unget-char uniq
+syn keyword txl_keyword contained unless unquote until upcase-str
+syn keyword txl_keyword contained update url-decode url-encode usleep
+syn keyword txl_keyword contained uw-protect vec vec-push vec-set-length
+syn keyword txl_keyword contained vecref vector vector-list vectorp
+syn keyword txl_keyword contained when where while with-saved-vars
+syn keyword txl_keyword contained zerop zip
 
 syn match txr_error "@[\t ]*[*]\?[\t ]*."
 syn match txr_nested_error "[^\t `]\+" contained