New way of handling exceptions without unwinding.

* eval.c (handler_bind_s): New symbol variable.
(op_handler_bind): New static function.
(do_expand): Traverse handler-bind forms.
(eval_init): Initialize handler_bind_s variable and register handler-bind
operator.

* lisplib.c (except_set_entries, except_instantiate): New functions.
(lisplib_init): Register new functions in dl_table.

* parser.c (intr_s): New symbol variable.
(repl_intr): Throw exception of type intr, rather than error.
This way we can interrupt accidental exception handling loops involving
exceptions derived from error.
(parse_init): Initialize intr_s.

* share/txr/stdlib/except.tl: New file, defines handle macro.

* unwind.c (uw_push_handler): New function.
(invoke_handler): New static function.
(uw_throw): Search loop looks for and processes handlers in addition to
catches.

* unwind.h (uw_frtype_t): New enum member, UW_HANDLE.
(struct uw_catch): Move member visible so it
is in the same position as in struct uw_handler.
(struct uw_handler): New struct type.
(union uw_frame): New member ha of type struct uw_handler.
(uw_push_handler): Function declared.

* txr.1: Added introductory paragraphs to Exception Handling section.
Documented handler-bind and handle. Some minor errors corrected.

7 files changed, 350 insertions, 7 deletions

diff --git a/eval.c b/eval.c
index f16be7ec..8fa4120a 100644
--- a/eval.c
+++ b/eval.c
@@ -73,7 +73,7 @@ val eval_initing;
 
 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, iflet_s, when_s;
+val handler_bind_s, cond_s, if_s, iflet_s, when_s;
 val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s;
 val tree_case_s, tree_bind_s;
 val sys_mark_special_s;
@@ -1911,6 +1911,24 @@ static val op_catch(val form, val env)
   return result;
 }
 
+static val op_handler_bind(val form, val env)
+{
+  val args = rest(form);
+  val fun = pop(&args);
+  val handle_syms = pop(&args);
+  val body = args;
+  val result;
+  uw_frame_t uw_handler;
+
+  uw_push_handler(&uw_handler, handle_syms, eval(fun, env, form));
+
+  result = eval_progn(body, env, form);
+
+  uw_pop_frame(&uw_handler);
+
+  return result;
+}
+
 static val subst_vars(val forms, val env)
 {
   list_collect_decl(out, iter);
@@ -3152,6 +3170,25 @@ tail:
       return rlcp(cons(sym, quasi_ex), form);
     } else if (sym == catch_s) {
       return expand_catch(rest(form), menv);
+    } else if (sym == handler_bind_s) {
+      val args = rest(form);
+      val fun = pop(&args);
+      val handle_syms = pop(&args);
+      val body = args;
+      val fun_ex = expand(fun, menv);
+      val body_ex = expand_forms(body, menv);
+
+      if (!cddr(form))
+        eval_error(form, lit("~s: missing arguments"), sym, nao);
+
+      if (fun == fun_ex && body == body_ex)
+        return form;
+
+      return rlcp(cons(sym, cons(if3(fun == fun_ex,
+                                     fun, fun_ex),
+                                 cons(handle_syms,
+                                      if3(body == body_ex,
+                                          body, body_ex)))), form);
     } else if (sym == macro_time_s) {
       val args = rest(form);
       val args_ex = expand_forms(args, menv);
@@ -4076,6 +4113,7 @@ void eval_init(void)
   flet_s = intern(lit("flet"), user_package);
   labels_s = intern(lit("labels"), user_package);
   call_s = intern(lit("call"), user_package);
+  handler_bind_s = intern(lit("handler-bind"), user_package);
   cond_s = intern(lit("cond"), user_package);
   caseq_s = intern(lit("caseq"), user_package);
   caseql_s = intern(lit("caseql"), user_package);
@@ -4214,6 +4252,7 @@ void eval_init(void)
   reg_op(dwim_s, op_dwim);
   reg_op(quasi_s, op_quasi_lit);
   reg_op(catch_s, op_catch);
+  reg_op(handler_bind_s, op_handler_bind);
   reg_op(with_saved_vars_s, op_with_saved_vars);
   reg_op(prof_s, op_prof);
 
diff --git a/lisplib.c b/lisplib.c
index 53898c08..cb4fdb48 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -228,6 +228,21 @@ static val hash_instantiate(val set_fun)
   return nil;
 }
 
+static val except_set_entries(val dlt, val fun)
+{
+  val name[] = { lit("handle"), nil };
+  set_dlt_entries(dlt, name, fun);
+  return nil;
+}
+
+static val except_instantiate(val set_fun)
+{
+  funcall1(set_fun, nil);
+  load(format(nil, lit("~a/except.tl"), stdlib_path, nao));
+  return nil;
+}
+
+
 val dlt_register(val dlt,
                  val (*instantiate)(val),
                  val (*set_entries)(val, val))
@@ -248,6 +263,7 @@ void lisplib_init(void)
   dlt_register(dl_table, struct_instantiate, struct_set_entries);
   dlt_register(dl_table, with_stream_instantiate, with_stream_set_entries);
   dlt_register(dl_table, hash_instantiate, hash_set_entries);
+  dlt_register(dl_table, except_instantiate, except_set_entries);
 }
 
 val lisplib_try_load(val sym)
diff --git a/parser.c b/parser.c
index ccff6a3f..9cdb0a85 100644
--- a/parser.c
+++ b/parser.c
@@ -57,6 +57,7 @@
 
 val parser_s, unique_s;
 val listener_hist_len_s, listener_multi_line_p_s;
+val intr_s;
 
 static val stream_parser_hash;
 
@@ -587,7 +588,7 @@ static char *provide_atom(lino_t *l, const char *str, int n, void *ctx)
 
 static val repl_intr(val signo, val async_p)
 {
-  uw_throw(error_s, lit("intr"));
+  uw_throw(intr_s, lit("intr"));
 }
 
 static val read_eval_ret_last(val env, val in_stream, val out_stream)
@@ -793,6 +794,7 @@ val parser_eof(val parser)
 void parse_init(void)
 {
   parser_s = intern(lit("parser"), user_package);
+  intr_s = intern(lit("intr"), user_package);
   listener_hist_len_s = intern(lit("*listener-hist-len*"), user_package);
   listener_multi_line_p_s = intern(lit("*listener-multi-line-p*"), user_package);
   unique_s = gensym(nil);
diff --git a/share/txr/stdlib/except.tl b/share/txr/stdlib/except.tl
new file mode 100644
index 00000000..e710cacd
--- /dev/null
+++ b/share/txr/stdlib/except.tl
@@ -0,0 +1,45 @@
+;; Copyright 2015
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution of this software in source and binary forms, with or without
+;; modification, is permitted provided that the following two conditions are met.
+;;
+;; Use of this software in any manner constitutes agreement with the disclaimer
+;; which follows the two conditions.
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;;    notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;;    notice, this list of conditions and the following disclaimer in
+;;    the documentation and/or other materials provided with the
+;;    distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
+;; WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
+;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED,
+;; AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(defun sys:handle-bad-syntax (item)
+  (throwf 'eval-error "~s: bad clause syntax: ~s" 'handle item))
+
+(defmacro handle (:whole form try-form . handle-clauses)
+  (let* ((exc-sym (gensym))
+         (exc-args (gensym))
+         (syms-fragments (collect-each ((hc handle-clauses))
+                          (tree-case hc
+                            ((name arglist . body)
+                             (unless (symbolp name)
+                               (sys:handle-bad-syntax hc))
+                             (list name ^(apply (lambda ,arglist ,*body)
+                                                ,exc-sym ,exc-args)))
+                            (else (sys:handle-bad-syntax hc))))))
+    ^(handler-bind (lambda (,exc-sym . ,exc-args)
+                     (cond
+                       ,*(mapcar (aret ^((exception-subtype-p ,exc-sym ',@1) ,@2))
+                                 syms-fragments)))
+                   ,[mapcar car syms-fragments]
+                   ,try-form)))
diff --git a/txr.1 b/txr.1
index bd72db80..442a42fb 100644
--- a/txr.1
+++ b/txr.1
@@ -26319,7 +26319,83 @@ two's complement bitfield 01 denotes 1, and 10 denotes -2.
 
 The argument may be a character.
 
-.SS* Exceptions
+.SS* Exception Handling
+
+An
+.I exception
+in \*(TX is a special event in the execution of the program which
+results in transfer of control. An exception is identified by a symbol,
+known as the
+.IR "exception type" ,
+and it carries zero or more arguments, called the
+.IR "exception arguments" .
+
+When an exception is initiated, it is said to be
+.IR thrown .
+When an exception is thrown, \*(TX enters into exception processing
+mode. Exception processing mode terminates in one of several ways:
+.IP -
+A
+.I catch
+is found which matches the exception, and control is transferred
+to the catch. Catches are defined by the
+.code catch
+operator.
+.IP -
+A handler accepts the exception by performing a non-local transfer.
+Handlers are defined by the
+.code handler-bind
+operator or
+.code handle
+macro.
+.IP -
+If no catch or accepting handler is found, control is transferred
+to the function stored in the
+.code *unhandled-hook*
+variable. If that function returns, the process terminates.
+.IP -
+If no catch or accepting handler is found and
+.code *unhandled-hook*
+is
+.codn nil ,
+then a built-in strategy for handling the exception is invoked,
+consisting of printing some informational messages and terminating.
+.PP
+
+From the above it should be evident that there are two ways by which exceptions
+are handled: catches and handlers. Catches and handlers are similar, but different.
+A catch is an exit point associated with an active scope. When an exception is
+handled by a catch, the form which threw the exception is abandoned, and unwinding
+takes place to the catch site, which receives the exception type and arguments.
+A handler is also associated with an active scope. However, it is a function,
+and not a dynamic exit point.  When an exception is passed to handler,
+unwinding does not take place; rather, the function is called. The function then
+either completes the exception handling by performing a non-local transfer,
+or else declines the exception by performing an ordinary return.
+
+Catches and handlers are identified by exception type symbols. A catch or
+handler is eligible to process an exception if it handles a type which is
+a supertype of the exception which is being processed. Handles and catches
+are located in a combined search which proceeds from the innermost nesting
+to the outermost. When an eligible handle is encountered, it is called. If
+it returns, the search continues. When an eligible catch is encountered,
+the search stops and a control transfer takes place to the catch site.
+
+Exception types are arranged
+in an inheritance hierarchy, at whose top the symbol
+.code t
+is is the supertype of every exception type, and the
+.code nil
+symbol is at the bottom, the subtype of every exception type.
+
+Keyword symbols may be used as exception types.
+
+Every symbol is its own supertype and subtype. Thus whenever X is known to be a
+subtype of Y, it is possible that X is exactly Y.
+The
+.code defex
+macro registers exception supertype/subtype relationships among symbols.
+
 .coNP Functions @, throw @ throwf and @ error
 .synb
 .mets (throw < symbol << arg *)
@@ -26426,7 +26502,12 @@ operator, and the functions
 .codn throw ,
 .code throwf
 and
-.codn error .
+.codn error ,
+as well as the
+.code handler-bind
+operator and
+.code handler
+macro.
 
 .coNP Operator @ unwind-protect
 .synb
@@ -26514,6 +26595,114 @@ form terminates without evaluating the remaining
 forms, and yields
 .codn nil .
 
+.coNP Operator @ handler-bind
+.synb
+.mets (handler-bind < function-form < symbol-list << body-form *)
+.syne
+.desc
+The
+.code handler-bind
+operator establishes a handler for one or more
+exception types, and evaluates zero or more
+.metn body-form -s
+in a dynamic scope in which that handler is visible.
+
+When the
+.code handler-bind
+form terminates normally, the handler is removed. The value of the
+last
+.meta body-form
+is returned, or else
+.code nil
+if there are no forms.
+
+The
+.meta function-form
+argument is an expression which must evaluate to a function. The function
+must be capable of accepting the exception arguments. All exceptions functions
+require at least one argument, since the leftmost argument in an exception handler
+call is the exception type symbol.
+
+The
+.meta symbol-list
+argument is a list of symbols, not evaluated. If it is empty, then the handler
+isn't eligible for any exceptions. Otherwise it is eligible for any exception
+whose exception type is a subtype of any of the symbols.
+
+If the evaluation of any
+.meta body-form
+throws an exception which is not handled within that form, and the handler
+is eligible for that exception, then the function is invoked. It receives
+the exception's type symbol as the leftmost argument. If the exception has
+arguments, they appear as additional arguments in the function call.
+If the function returns normally, then the exception search continues.
+The handler remains established until the exception is handled in such a way
+that a dynamic control transfer abandons the
+.code handler-bind
+form.
+
+Note: while a handler's function is executing, the handler is disabled.
+If the function throws an exception for which the handler is eligible,
+the handler will not receive that exception; it will be skipped by the
+exception search as if it didn't exist.  When the handler function terminates,
+either via a normal return or a nonlocal control transfer, then the handler is
+re-enabled.
+
+.coNP Macro @ handle
+.synb
+.mets (handle < try-expression
+.mets \ \  >> {( symbol <> ( arg *) << body-form *)}*)
+.syne
+.desc
+The
+.code handle
+macro is a syntactic sugar for the
+.code handler-bind
+operator. Its syntax is exactly like that of
+.codn catch .
+The difference between
+.code handle
+and
+.code catch
+is that the clauses in
+.code handle
+are invoked without unwinding. That is to say,
+.code handle
+does not establish an exit point for an exception. When control passes to
+a clause, it is by means of an ordinary function call and not a dynamic
+control transfer. No evaluation frames are yet unwound when this takes place.
+
+The
+.code handle
+macro establishes a handler, by
+.code handler-bind
+whose
+.meta symbol-list
+consists of every
+.meta symbol
+gathered from every clause.
+
+The handler function established in the generated
+.code handler-bind
+is synthesized from of all of the clauses, together with dispatch logic which
+which passes the exception and its arguments to the first
+eligible clause.
+
+The
+.meta try-expression
+is evaluated in the context of this handler.
+
+The clause of the
+.code handle
+syntax can return normally, like a function, in which case the handler
+is understood to have declined the exception, and exception processing
+continues. To handle an exception, the clause of the
+.code handle
+macro must perform a dynamic control transfer, such returning from a block
+via
+.code return
+or throwing an exception.
+
 .coNP Macro @ with-resources
 .synb
 .mets (with-resources >> ({ sym >> [ init-form <> [ cleanup-form ])}*)
@@ -26599,7 +26788,7 @@ When an exception occurs which has no handler, this function is called,
 with the following arguments: the exception type symbol, the exception object,
 and a third value which is either
 .code nil
-or else the form which was being evaluated the exception was thrown.
+or else the form which was being evaluated when the exception was thrown.
 
 Otherwise, if the variable is
 .code nil
diff --git a/unwind.c b/unwind.c
index 6f488ae3..ab307dd0 100644
--- a/unwind.c
+++ b/unwind.c
@@ -247,6 +247,17 @@ void uw_push_catch(uw_frame_t *fr, val matches)
   uw_stack = fr;
 }
 
+void uw_push_handler(uw_frame_t *fr, val matches, val fun)
+{
+  memset(fr, 0, sizeof *fr);
+  fr->ha.type = UW_HANDLE;
+  fr->ha.matches = matches;
+  fr->ha.fun = fun;
+  fr->ha.visible = 1;
+  fr->ha.up = uw_stack;
+  uw_stack = fr;
+}
+
 static val exception_subtypes;
 
 val uw_exception_subtype_p(val sub, val sup)
@@ -259,6 +270,21 @@ val uw_exception_subtype_p(val sub, val sup)
   }
 }
 
+static void invoke_handler(uw_frame_t *fr, struct args *args)
+{
+  fr->ha.visible = 0;
+
+  uw_simple_catch_begin;
+
+  generic_funcall(fr->ha.fun, args);
+
+  uw_unwind {
+    fr->ha.visible = 1;
+  }
+
+  uw_catch_end;
+}
+
 val uw_throw(val sym, val args)
 {
   uw_frame_t *ex;
@@ -285,6 +311,20 @@ val uw_throw(val sym, val args)
       if (match)
         break;
     }
+    if (ex->uw.type == UW_HANDLE && ex->ha.visible) {
+      val matches = ex->ha.matches;
+      val match;
+      for (match = matches; match; match = cdr(match))
+        if (uw_exception_subtype_p(sym, car(match)))
+          break;
+      if (match) {
+        args_decl(gf_args, ARGS_MAX);
+        args_init_list(gf_args, ARGS_MAX, cons(sym, args));
+        --reentry_count;
+        invoke_handler(ex, gf_args);
+        ++reentry_count;
+      }
+    }
   }
 
   if (ex == 0) {
diff --git a/unwind.h b/unwind.h
index 2089608a..207b8ce9 100644
--- a/unwind.h
+++ b/unwind.h
@@ -31,7 +31,9 @@
 #endif
 
 typedef union uw_frame uw_frame_t;
-typedef enum uw_frtype { UW_BLOCK, UW_ENV, UW_CATCH, UW_DBG } uw_frtype_t;
+typedef enum uw_frtype {
+  UW_BLOCK, UW_ENV, UW_CATCH, UW_HANDLE, UW_DBG
+} uw_frtype_t;
 
 struct uw_common {
   uw_frame_t *up;
@@ -59,13 +61,21 @@ struct uw_catch {
   uw_frame_t *up;
   uw_frtype_t type;
   val matches;
+  int visible;
   val sym;
   val args;
   uw_frame_t *cont;
-  int visible;
   extended_jmp_buf jb;
 };
 
+struct uw_handler {
+  uw_frame_t *up;
+  uw_frtype_t type;
+  val matches; /* Same position as in uw_catch! */
+  int visible; /* Likewise. */
+  val fun;
+};
+
 struct uw_debug {
   uw_frame_t *up;
   uw_frtype_t type;
@@ -83,6 +93,7 @@ union uw_frame {
   struct uw_block bl;
   struct uw_dynamic_env ev;
   struct uw_catch ca;
+  struct uw_handler ha;
   struct uw_debug db;
 };
 
@@ -98,6 +109,7 @@ INLINE val uw_block_return(val tag, val result)
    return uw_block_return_proto(tag, result, nil);
 }
 void uw_push_catch(uw_frame_t *, val matches);
+void uw_push_handler(uw_frame_t *, val matches, val fun);
 noreturn val uw_throw(val sym, val exception);
 noreturn val uw_throwv(val sym, struct args *);
 noreturn val uw_throwf(val sym, val fmt, ...);