TXR Lisp gets exception handling.

* eval.c (op_catch, expand_catch_clause,
expand_catch): New static functions.
(expand): Handle catch operator.
(eval_init): Added catch operator to op_table,
and registered new functions throw, throwf and error.

* txr.1: Documented catch operator and created
stub section for throw, throwf and error.

* txr.vim: Updated.

* unwind.c (uw_throwfv, uw_errorfv): New functions.

* unwind.h (uw_throwfv, uw_errorfv): Declared.

6 files changed, 153 insertions, 1 deletions

diff --git a/ChangeLog b/ChangeLog
index dff37529..c8198f43 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,22 @@
+2012-02-16  Kaz Kylheku  <kaz@kylheku.com>
+
+	TXR Lisp gets exception handling.
+
+	* eval.c (op_catch, expand_catch_clause,
+	expand_catch): New static functions.
+	(expand): Handle catch operator.
+	(eval_init): Added catch operator to op_table,
+	and registered new functions throw, throwf and error.
+
+	* txr.1: Documented catch operator and created
+	stub section for throw, throwf and error.
+
+	* txr.vim: Updated.
+
+	* unwind.c (uw_throwfv, uw_errorfv): New functions.
+
+	* unwind.h (uw_throwfv, uw_errorfv): Declared.
+
 2012-02-14  Kaz Kylheku  <kaz@kylheku.com>
 
 	* eval.c (rangev_func, rangev, range_star_v_func,
diff --git a/eval.c b/eval.c
index efdc22db..a62353ed 100644
--- a/eval.c
+++ b/eval.c
@@ -1074,6 +1074,42 @@ static val op_dwim(val form, val env)
   return nil;
 }
 
+static val op_catch(val form, val env)
+{
+  val catch_syms = second(form);
+  val try_form = third(form);
+  val result = nil;
+
+  uw_catch_begin (catch_syms, exsym, exvals);
+
+  result = eval(try_form, env, try_form);
+
+  uw_catch(exsym, exvals) {
+    val catches = rest(rest(rest(form)));
+    val iter;
+
+    for (iter = catches; iter; iter = cdr(iter)) {
+      val clause = car(iter);
+      val type = first(clause);
+
+      if (uw_exception_subtype_p(exsym, type)) {
+        val params = second(clause);
+        val clause_env = bind_args(env, params, if3(consp(exvals),
+                                                    exvals, cons(exvals, nil)),
+                                   clause);
+        result = eval_progn(rest(rest(clause)), clause_env, clause);
+        break;
+      }
+    }
+  }
+
+  uw_unwind;
+
+  uw_catch_end;
+
+  return result;
+}
+
 static val subst_vars(val forms, val env)
 {
   list_collect_decl(out, iter);
@@ -1408,6 +1444,34 @@ static val expand_op(val body)
   }
 }
 
+static val expand_catch_clause(val form)
+{
+  val sym = first(form);
+  val vars = second(form);
+  val body = rest(rest(form));
+  val vars_ex = expand_vars(vars);
+  val body_ex = expand_forms(body);
+  if (body == body_ex && vars == vars_ex)
+    return form;
+  return rlcp(cons(sym, cons(vars_ex, body_ex)), form);
+}
+
+static val expand_catch(val body)
+{
+  val try_form = first(body);
+  val catch_clauses = rest(body);
+  val catch_syms = mapcar(car_f, catch_clauses);
+  val try_form_ex = expand(try_form);
+  val catch_clauses_ex = rlcp(mapcar(func_n1(expand_catch_clause), 
+                                     catch_clauses),
+                              catch_clauses);
+
+  val expanded = cons(catch_s, 
+                      cons(catch_syms, 
+                           cons(try_form_ex, catch_clauses_ex)));
+  return rlcp(expanded, body);
+}
+
 val expand(val form)
 {
   if (atom(form)) {
@@ -1538,6 +1602,8 @@ val expand(val form)
       return expand(expand_delay(rest(form)));
     } else if (sym == op_s) {
       return expand_op(rest(form));
+    } else if (sym == catch_s) {
+      return expand_catch(rest(form));
     } else {
       /* funtion call
          also handles: progn, prog1, call, if, and, or, 
@@ -1928,6 +1994,7 @@ void eval_init(void)
   sethash(op_table, return_from_s, cptr((mem_t *) op_return_from));
   sethash(op_table, dwim_s, cptr((mem_t *) op_dwim));
   sethash(op_table, quasi_s, cptr((mem_t *) op_quasi_lit));
+  sethash(op_table, catch_s, cptr((mem_t *) op_catch));
 
   reg_fun(cons_s, func_n2(cons));
   reg_fun(intern(lit("make-lazy-cons"), user_package), func_n1(make_lazy_cons));
@@ -2157,6 +2224,10 @@ void eval_init(void)
   reg_fun(intern(lit("repeat"), user_package), func_n1v(repeatv));
   reg_fun(intern(lit("force"), user_package), func_n1(force));
 
+  reg_fun(throw_s, func_n1v(uw_throw));
+  reg_fun(intern(lit("throwf"), user_package), func_n2v(uw_throwfv));
+  reg_fun(error_s, func_n1v(uw_errorfv));
+
   eval_error_s = intern(lit("eval-error"), user_package);
   uw_register_subtype(eval_error_s, error_s);
 }
diff --git a/txr.1 b/txr.1
index 87a3fa3a..7efd5bbf 100644
--- a/txr.1
+++ b/txr.1
@@ -5428,6 +5428,47 @@ Example:
   Output:
   1 2 3
 
+.SS Operator catch
+
+.TP
+Syntax:
+
+  (catch <try-expression>
+    {(<symbol> (<arg>*) <body-form>*)}*)
+
+.TP
+Description:
+
+The catch operator establishes an exception catching block around
+the <try-expression>. The <try-expression> is followed by zero or more
+catch clauses. Each catch clause consists of a symbol which denotes
+an exception type, an argument list, and zero or more body forms.
+
+If <try-expression> terminates normally, then the catch clauses
+are ignored. The catch itself terminates, and its return value is
+that of the <try-expression>.
+
+If <try-expression> throws an exception which is a subtype of one or more of
+the type symbols given in the exception clauses, then the first (leftmost) such
+clause becomes the exit point where the exception is handled.
+The exception is converted into arguments for the clause, and the clause
+body is executed. When the clause body terminates, the catch terminates,
+and the return value of the catch is that of the clause body.
+
+If <try-expression> throws an exception which is not a subtype of any of
+the symbols given in the clauses, then the search for an exit point for
+the exception continues through the enclosing forms. The catch clauses
+are not involved in the handling of that exception.
+
+When a clause catches an exception, the number of arguments in the catch must
+match the number of elements in the exception.  A catch argument list
+resembles a function or lambda argument list, and may be dotted.  For instance
+the clause (foo (a . b)) catches an exception subtyped from foo, with one or
+more elements. The first element binds to parameter a, and the rest, if any,
+bind to parameter b.  If there is only one element, b takes on the value nil.
+
+Also see: the unwind-protect operator, and the functions throw, throwf
+and error.
 
 .SS Lisp Functions and Variables
 
@@ -6585,6 +6626,8 @@ Certain object types have a custom equal function.
 
 .SS Function repeat
 
+.SS Functions throw, throwf and error
+
 .SH APPENDIX A: NOTES ON EXOTIC REGULAR EXPRESSIONS
 
 Users familiar with regular expressions may not be familiar with the complement
diff --git a/txr.vim b/txr.vim
index e3effa0b..f20c58b5 100644
--- a/txr.vim
+++ b/txr.vim
@@ -26,7 +26,7 @@ syn keyword txr_keyword contained define try catch finally throw
 syn keyword txr_keyword contained defex throw deffilter filter eof eol do
 
 syn keyword txl_keyword contained progn prog1 let syn let* lambda call fun 
-syn keyword txl_keyword contained cond if and or dwim op
+syn keyword txl_keyword contained cond if and or dwim op catch
 syn keyword txl_keyword contained defvar defun inc dec set push pop flip
 syn keyword txl_keyword contained for for* dohash unwind-protect block
 syn keyword txl_keyword contained return return-from gen delay
@@ -81,6 +81,7 @@ syn keyword txl_keyword contained make-random-state random-state-p
 syn keyword txl_keyword contained random-fixnum random
 
 syn keyword txl_keyword contained range range* generate repeat force
+syn keyword txl_keyword contained throw throwf error 
 
 syn match txr_hash "#" contained
 syn match txr_quote "[,']" contained
diff --git a/unwind.c b/unwind.c
index ac99665a..ac4bb79d 100644
--- a/unwind.c
+++ b/unwind.c
@@ -295,6 +295,14 @@ val uw_throwf(val sym, val fmt, ...)
   abort();
 }
 
+val uw_throwfv(val sym, val fmt, val args)
+{
+  val stream = make_string_output_stream();
+  (void) formatv(stream, fmt, args);
+  uw_throw(sym, get_string_from_stream(stream));
+  abort();
+}
+
 val uw_errorf(val fmt, ...)
 {
   va_list vl;
@@ -308,6 +316,14 @@ val uw_errorf(val fmt, ...)
   abort();
 }
 
+val uw_errorfv(val fmt, val args)
+{
+  val stream = make_string_output_stream();
+  (void) formatv(stream, fmt, args);
+  uw_throw(error_s, get_string_from_stream(stream));
+  abort();
+}
+
 val type_mismatch(val fmt, ...)
 {
   va_list vl;
diff --git a/unwind.h b/unwind.h
index f9c69ad0..307c030f 100644
--- a/unwind.h
+++ b/unwind.h
@@ -95,7 +95,9 @@ val uw_block_return(val tag, val result);
 void uw_push_catch(uw_frame_t *, val matches);
 noreturn val uw_throw(val sym, val exception);
 noreturn val uw_throwf(val sym, val fmt, ...);
+noreturn val uw_throwfv(val sym, val fmt, val args);
 noreturn val uw_errorf(val fmt, ...);
+noreturn val uw_errorfv(val fmt, val args);
 val uw_register_subtype(val sub, val super);
 val uw_exception_subtype_p(val sub, val sup);
 void uw_continue(uw_frame_t *curr, uw_frame_t *target);