New destructuring operators.

* eval.c (tree_case_s, tree_bind_s): New symbol variables.
(bind_macro_params): Bugfix: inappropriate exception thrown when atom
matched against parameter list. Bugfix: nil being returned when
atom matches empty parameter list. Added support for a new convention:
if loose_p is the colon keyword, then exceptions are not thrown
for destructuring mismatches; nil is returned instad.
(op_tree_case, expand_tree_cases, expand_tree_case, op_tree_bind):
New static functions.
(expand): Handle tree_case_s and tree_bind_s.
(eval_init): Intern tree-case and tree-bind symbols.
Register the corresponding operator functions op_tree_case and
op_tree_bind under these symbols in op_table.

* txr.1: Documented tree-case and tree-bind operators.

3 files changed, 202 insertions, 11 deletions

diff --git a/ChangeLog b/ChangeLog
index ce00aecb..83be43f8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,24 @@
 2014-02-16  Kaz Kylheku  <kaz@kylheku.com>
 
+	New destructuring operators.
+
+	* eval.c (tree_case_s, tree_bind_s): New symbol variables.
+	(bind_macro_params): Bugfix: inappropriate exception thrown when atom
+	matched against parameter list. Bugfix: nil being returned when
+	atom matches empty parameter list. Added support for a new convention:
+	if loose_p is the colon keyword, then exceptions are not thrown
+	for destructuring mismatches; nil is returned instad.
+	(op_tree_case, expand_tree_cases, expand_tree_case, op_tree_bind):
+	New static functions.
+	(expand): Handle tree_case_s and tree_bind_s.
+	(eval_init): Intern tree-case and tree-bind symbols.
+	Register the corresponding operator functions op_tree_case and
+	op_tree_bind under these symbols in op_table.
+
+	* txr.1: Documented tree-case and tree-bind operators.
+
+2014-02-16  Kaz Kylheku  <kaz@kylheku.com>
+
 	* eval.c (bind_macro_params): Bugfix: enforce mismatch on
 	superfluous material.
 
diff --git a/eval.c b/eval.c
index 22e81926..e7ad031d 100644
--- a/eval.c
+++ b/eval.c
@@ -76,7 +76,7 @@ val op_table;
 
 val eval_error_s;
 val dwim_s, progn_s, prog1_s, let_s, let_star_s, lambda_s, call_s;
-val cond_s, if_s, defvar_s, defun_s, defmacro_s;
+val cond_s, if_s, defvar_s, defun_s, defmacro_s, tree_case_s, tree_bind_s;
 val inc_s, dec_s, push_s, pop_s, flip_s, gethash_s, car_s, cdr_s;
 val del_s, vecref_s;
 val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s;
@@ -565,12 +565,12 @@ static val bind_macro_params(val env, val mac_env, val params, val form,
       continue;
     } 
 
-    if (car(form) == colon_k) {
-      form = cdr(form);
-      goto noarg;
-    }
-
     if (consp(form)) {
+      if (car(form) == colon_k) {
+        form = cdr(form);
+        goto noarg;
+      }
+
       if (bindable(param)) {
         env_vbind(new_env, param, car(form));
       } else if (consp(param)) {
@@ -595,6 +595,8 @@ static val bind_macro_params(val env, val mac_env, val params, val form,
           new_env = bind_macro_params(new_env, mac_env,
                                       param, car(form),
                                       loose_p, ctx_form);
+          if (!new_env)
+            return nil;
         }
       } else {
         err_sym = param;
@@ -605,13 +607,19 @@ static val bind_macro_params(val env, val mac_env, val params, val form,
       continue;
     }
 
-    if (form)
+    if (form) {
+      if (loose_p == colon_k)
+        return nil;
       eval_error(ctx_form, lit("~s: atom ~s not matched by parameter list"),
                  car(ctx_form), form, nao);
+    }
 
-    if (!optargs && !loose_p) {
-      eval_error(ctx_form, lit("~s: insufficient number of arguments"),
-                 car(ctx_form), nao);
+    if (!optargs) {
+      if (!loose_p)
+        eval_error(ctx_form, lit("~s: insufficient number of arguments"),
+                   car(ctx_form), nao);
+      if (loose_p == colon_k)
+        return nil;
     }
 
 noarg:
@@ -652,12 +660,16 @@ noarg:
       goto nbind;
     }
     env_vbind(new_env, params, form);
+    return new_env;
   }
 
-  if (form)
+  if (form) {
+    if (loose_p == colon_k)
+      return nil;
     eval_error(ctx_form,
                lit("~s: extra form part ~s not matched by parameter list"),
                car(ctx_form), form, nao);
+  }
 
   return new_env;
 
@@ -1085,6 +1097,83 @@ static val expand_macro(val form, val expander, val mac_env)
   debug_leave;
 }
 
+static val op_tree_case(val form, val env)
+{
+  val cases = form;
+  val expr = (pop(&cases), pop(&cases));
+
+  val expr_val = eval(expr, env, form);
+
+  for (; consp(cases); cases = cdr(cases)) {
+    val onecase = car(cases);
+    cons_bind (params, forms, onecase);
+
+    if (!params) {
+      if (!expr_val)
+        return eval_progn(forms, env, forms);
+    } else {
+      val new_env = bind_macro_params(env, nil, params, expr_val,
+                                      colon_k, onecase);
+      if (new_env)
+        return eval_progn(forms, new_env, forms);
+    }
+  }
+
+  return nil;
+}
+
+static val expand_tree_cases(val cases)
+{
+  if (atom(cases)) {
+    return cases;
+  } else {
+    val onecase = car(cases);
+
+    if (atom(onecase)) {
+      val rest_ex = expand_tree_cases(cdr(cases));
+      if (rest_ex == cdr(cases))
+        return cases;
+      return rlcp(cons(onecase, rest_ex), cases);
+    } else {
+      val dstr_args = car(onecase);
+      val forms = cdr(onecase);
+      val dstr_args_ex = expand_params(dstr_args);
+      val forms_ex = expand_forms(forms);
+      val rest_ex = expand_tree_cases(cdr(cases));
+
+      if (dstr_args_ex == dstr_args && forms_ex == forms &&
+          rest_ex == cdr(cases))
+        return cases;
+
+      return rlcp(cons(cons(dstr_args_ex, forms_ex), rest_ex), cases);
+    }
+  }
+}
+
+static val expand_tree_case(val form)
+{
+  val sym = first(form);
+  val expr = second(form);
+  val tree_cases = rest(rest(form));
+  val expr_ex = expand(expr);
+  val tree_cases_ex = expand_tree_cases(tree_cases);
+
+  if (expr_ex == expr && tree_cases_ex == tree_cases)
+    return form;
+
+  return rlcp(cons(sym, cons(expr_ex, tree_cases_ex)), form);
+}
+
+static val op_tree_bind(val form, val env)
+{
+  val params = second(form);
+  val expr = third(form);
+  val body = rest(rest(rest(form)));
+  val expr_val = eval(expr, env, expr);
+  val new_env = bind_macro_params(env, nil, params, expr_val, nil, form);
+  return eval_progn(body, new_env, body);
+}
+
 static val op_modplace(val form, val env);
 
 static val *dwim_loc(val form, val env, val op, val newform, val *retval)
@@ -2001,6 +2090,19 @@ tail:
         return cons(quote_s, cons(result, nil));
       }
       return form_ex;
+    } else if (sym == tree_case_s) {
+      return expand_tree_case(form);
+    } else if (sym == tree_bind_s) {
+      val params = second(form);
+      val expr = third(form);
+      val body = rest(rest(rest(form)));
+      val params_ex = expand_params(params);
+      val expr_ex = expand(expr);
+      val body_ex = expand_forms(body);
+
+      if (params_ex == params && expr_ex == expr && body_ex == body)
+        return form;
+      return rlcp(cons(sym, cons(params_ex, cons(expr_ex, body_ex))), form);
     } else if (sym == set_s || sym == inc_s || sym == dec_s) {
       val place = second(form);
       val inc = third(form);
@@ -2529,6 +2631,8 @@ void eval_init(void)
   defvar_s = intern(lit("defvar"), user_package);
   defun_s = intern(lit("defun"), user_package);
   defmacro_s = intern(lit("defmacro"), user_package);
+  tree_case_s = intern(lit("tree-case"), user_package);
+  tree_bind_s = intern(lit("tree-bind"), user_package);
   inc_s = intern(lit("inc"), user_package);
   dec_s = intern(lit("dec"), user_package);
   push_s = intern(lit("push"), user_package);
@@ -2591,6 +2695,8 @@ void eval_init(void)
   sethash(op_table, defvar_s, cptr((mem_t *) op_defvar));
   sethash(op_table, defun_s, cptr((mem_t *) op_defun));
   sethash(op_table, defmacro_s, cptr((mem_t *) op_defmacro));
+  sethash(op_table, tree_case_s, cptr((mem_t *) op_tree_case));
+  sethash(op_table, tree_bind_s, cptr((mem_t *) op_tree_bind));
   sethash(op_table, inc_s, cptr((mem_t *) op_modplace));
   sethash(op_table, dec_s, cptr((mem_t *) op_modplace));
   sethash(op_table, set_s, cptr((mem_t *) op_modplace));
diff --git a/txr.1 b/txr.1
index 710d7aa7..d47af3a8 100644
--- a/txr.1
+++ b/txr.1
@@ -12652,6 +12652,72 @@ Examples:
           (let ((,var (car i)))
             ,*body))))
 
+.SS Operator tree-bind
+
+.TP
+Syntax:
+
+  (tree-bind <macro-style-params> <expr> <form>*)
+
+.TP
+Description:
+
+The tree-bind operator evaluates <expr>, and then uses the
+resulting value as a counterpart to a macro-style parameter list.
+If the value has a tree structure which matches the parameters,
+then those parameters are established as bindings, and the
+<form>-s, if any, are evaluated in the scope of those bindings.  The value
+of the last <form> is returned. If there are no forms,
+nil is returned.
+
+Note: this operator throws an exception if there is a mismatch
+between the parameters and the value of <expr>.
+
+.SS Operator tree-case
+
+.TP
+Syntax:
+
+  (tree-case <expr> { (<macro-style-params> <form>*) }*)
+
+.TP
+Description:
+
+The tree case operator evaluates <expr> and matches it against a succession
+of zero or more cases. Each case defines a pattern match, expressed as a macro
+style parameter list <macro-style-params>. 
+
+If the object produced by <expr> matches <macro-style-params>, then the
+parameters are bound, becoming local variables, and the <form>-s, if any, are
+evaluated in order in the environment in which those variables are visible. The
+evaluation of tree-case then ends, returning the value of the last <form>, or
+else nil if there are no forms.
+
+If the value of <expr> does not match the <macro-style-params> parameter
+list, then the usual exception is thrown; instead, processing continues
+with the next case.
+
+If no cases match, then tree-case terminates, returning nil.
+
+.SS
+Example:
+
+   ;; reverse function implemented using tree-case
+
+   (defun tb-reverse (obj)
+     (tree-case obj
+       (() ())      ;; the empty list is just returned
+       ((a) obj)    ;; one-element list just returned (unnecessary case)
+       ((a . b) '(,*(tb-reverse b) ,a)) ;; car/cdr recursion
+       (a a)))     ;; atom is just returned
+
+Note that in this example, the atom case is placed last, because an
+argument list which consists of a symbol is a "catch all" match
+that matches any object. We know that it matches an atom, because
+the previous (a . b) case matches conses. In general, the order of the cases in
+tree-case is important. Also note that the one-element case can be
+removed.
+
 .SH DEBUGGING FUNCTIONS
 
 .SS Functions source-loc and source-loc-str