txr-016 2009-10-16txr-016

9 files changed, 320 insertions, 72 deletions

diff --git a/ChangeLog b/ChangeLog
index 25531be5..ea4a2f86 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,73 @@
+2009-10-16  Kaz Kylheku  <kkylheku@gmail.com>
+
+	Version 016
+
+	Catch clauses with parameters.
+
+	Directive for throwing exceptions: throw.
+
+	Directive for defining exception types: defex.
+
+	-f option renamed to -c.
+
+	* txr.c: (version): Bump to 016
+	* txr.1: Bump version to 016.
+
+2009-10-16  Kaz Kylheku  <kkylheku@gmail.com>
+
+	* txr.c (help, main): Changed -f argument to -c. This
+	is consistent with the -c argument of the shell;
+	-f looks like awk's -f option, which specifies a file,
+	not a literal script body.
+
+	* txr.1: Updated.
+
+2009-10-15  Kaz Kylheku  <kkylheku@gmail.com>
+
+	* txr.1: Grammar, spelling.
+
+2009-10-15  Kaz Kylheku  <kkylheku@gmail.com>
+
+	* parser.y (clauses_opt): Long overdue nonterminal added.
+	(define_clause) simplified with clauses_opt.
+	(try_clause): Error handling improved.
+	(catch_clauses_opt): Catch and finally clauses can be empty.
+	Error cases added.
+	* txr.1: Updated.
+
+2009-10-15  Kaz Kylheku  <kkylheku@gmail.com>
+
+	* match.c (match_files): Use alist_remove1 for a one
+	element removal.
+
+2009-10-15  Kaz Kylheku  <kkylheku@gmail.com>
+
+	* unwind.c (uw_throw): Add program prefix before
+	unhandled exception text. Print it in the
+	standard notation if it's not a string literal.
+	* match.c (sem_error, file_err): Don't stick program
+	prefix into exception text.
+
+2009-10-15  Kaz Kylheku  <kkylheku@gmail.com>
+
+	* unwind.c (uw_exception_subtype_p, uw_init):
+	Slight change in representation for exception subtypes,
+	saving one node in the list.
+
+2009-10-15  Kaz Kylheku  <kkylheku@gmail.com>
+
+	New throw and defex directives, catches with arguments.
+
+	* lib.c (defex, throw): New symbol globals.
+	(obj_init): Symbols interned.
+	* lib.h (defex, throw): Declared.
+	* match.c (match_files): Implemented throw and defex.
+	Argument handling in catches.
+	* unwind.c (uw_register_subtype): Returns right
+	argument, so we can cleverly use it with reduce_left.
+	* unwind.h (uw_register_subtype): Declaration updated.
+	* txr.1: Updated.
+
 2009-10-14  Kaz Kylheku  <kkylheku@gmail.com>
 
 	Version 015
diff --git a/lib.c b/lib.c
index afad3fe2..0072f929 100644
--- a/lib.c
+++ b/lib.c
@@ -50,7 +50,7 @@ obj_t *skip, *trailer, *block, *next, *fail, *accept;
 obj_t *all, *some, *none, *maybe, *cases, *collect, *until, *coll;
 obj_t *define, *output, *single, *frst, *lst, *empty, *repeat, *rep;
 obj_t *flattn, *forget, *local, *mrge, *bind, *cat, *dir;
-obj_t *try, *catch, *finally, *nothrow;
+obj_t *try, *catch, *finally, *nothrow, *throw, *defex;
 obj_t *error, *type_error, *internal_err, *numeric_err, *range_err;
 obj_t *query_error, *file_error;
 
@@ -1521,6 +1521,8 @@ static void obj_init(void)
   catch = intern(string(strdup("catch")));
   finally = intern(string(strdup("finally")));
   nothrow = intern(string(strdup("nothrow")));
+  throw = intern(string(strdup("throw")));
+  defex = intern(string(strdup("defex")));
   error = intern(string(strdup("error")));
   type_error = intern(string(strdup("type_error")));
   internal_err = intern(string(strdup("internal_error")));
diff --git a/lib.h b/lib.h
index 1ecb577d..9473a299 100644
--- a/lib.h
+++ b/lib.h
@@ -149,7 +149,7 @@ extern obj_t *skip, *trailer, *block, *next, *fail, *accept;
 extern obj_t *all, *some, *none, *maybe, *cases, *collect, *until, *coll;
 extern obj_t *define, *output, *single, *frst, *lst, *empty, *repeat, *rep;
 extern obj_t *flattn, *forget, *local, *mrge, *bind, *cat, *dir;
-extern obj_t *try, *catch, *finally, *nothrow;
+extern obj_t *try, *catch, *finally, *nothrow, *throw, *defex;
 extern obj_t *error, *type_error, *internal_err, *numeric_err, *range_err;
 extern obj_t *query_error, *file_error;
 
diff --git a/match.c b/match.c
index d14df9a3..babaab18 100644
--- a/match.c
+++ b/match.c
@@ -85,7 +85,6 @@ static void sem_error(obj_t *line, const char *fmt, ...)
   obj_t *stream = make_string_output_stream();
 
   va_start (vl, fmt);
-  format(stream, "~a: ", prog_string, nao);
   if (line)
     format(stream, "(~a:~a) ", spec_file_str, line, nao);
   (void) vformat(stream, fmt, vl);
@@ -101,7 +100,6 @@ static void file_err(obj_t *line, const char *fmt, ...)
   obj_t *stream = make_string_output_stream();
 
   va_start (vl, fmt);
-  format(stream, "~a: ", prog_string, nao);
   if (line)
     format(stream, "(~a:~a) ", spec_file_str, line, nao);
   (void) vformat(stream, fmt, vl);
@@ -1402,7 +1400,7 @@ repeat_spec_same_data:
 
         {
           uw_block_begin(nil, result);
-          uw_catch_begin(catch_syms, exsym, exception);
+          uw_catch_begin(catch_syms, exsym, exvals);
 
           {
             result = match_files(try_clause, files, bindings,
@@ -1410,32 +1408,54 @@ repeat_spec_same_data:
             uw_do_unwind;
           }
 
-          uw_catch(exsym, exception) {
+          uw_catch(exsym, exvals) {
             {
               obj_t *iter;
 
               for (iter = catch_fin; iter; iter = cdr(iter)) {
                 obj_t *clause = car(iter);
-                obj_t *matches = second(clause);
+                obj_t *type = first(second(clause));
+                obj_t *params = second(second(clause));
                 obj_t *body = third(clause);
+                obj_t *vals = if3(listp(exvals),
+                                  exvals,
+                                  cons(cons(t, exvals), nil));
 
                 if (first(clause) == catch) {
-                  obj_t *match;
-                  for (match = matches; match; match = cdr(match))
-                    if (uw_exception_subtype_p(exsym, car(match)))
-                      break;
-                  if (match) {
-                    cons_bind (new_bindings, success,
-                               match_files(body, files, bindings,
-                                           data, num(data_lineno)));
-                    if (success) {
-                      bindings = new_bindings;
-                      result = t; /* catch succeeded, so try succeeds */
-                      if (consp(success)) {
-                        data = car(success);
-                        data_lineno = c_num(cdr(success));
-                      } else {
-                        data = nil;
+                  if (uw_exception_subtype_p(exsym, type)) {
+                    obj_t *all_bind = t;
+                    obj_t *piter, *viter;
+
+                    for (piter = params, viter = vals;
+                         piter && viter;
+                         piter = cdr(piter), viter = cdr(viter))
+                    {
+                      obj_t *param = car(piter);
+                      obj_t *val = car(viter);
+
+                      if (val) {
+                        bindings = dest_bind(bindings, param, cdr(val));
+
+                        if (bindings == t) {
+                          all_bind = nil;
+                          break;
+                        }
+                      }
+                    }
+
+                    if (all_bind) {
+                      cons_bind (new_bindings, success,
+                                 match_files(body, files, bindings,
+                                             data, num(data_lineno)));
+                      if (success) {
+                        bindings = new_bindings;
+                        result = t; /* catch succeeded, so try succeeds */
+                        if (consp(success)) {
+                          data = car(success);
+                          data_lineno = c_num(cdr(success));
+                        } else {
+                          data = nil;
+                        }
                       }
                     }
                     break;
@@ -1504,6 +1524,25 @@ repeat_spec_same_data:
 
           goto repeat_spec_same_data;
         }
+      } else if (sym == defex) {
+        obj_t *types = rest(first_spec);
+        if (!all_satisfy(types, func_n1(symbolp), nil))
+          sem_error(spec_linenum, "defex arguments must all be symbols", nao);
+        (void) reduce_left(func_n2(uw_register_subtype), types, nil, nil);
+        if ((spec = rest(spec)) == nil)
+          break;
+        goto repeat_spec_same_data;
+      } else if (sym == throw) {
+        obj_t *type = second(first_spec);
+        obj_t *args = rest(rest(first_spec));
+        if (!symbolp(type))
+          sem_error(spec_linenum, "throw: ~a is not a type symbol",
+                    first(first_spec), nao);
+        {
+          obj_t *values = mapcar(bind2other(func_n2(eval_form), bindings),
+                                 args);
+          uw_throw(type, values);
+        }
       } else {
         obj_t *func = uw_get_func(sym);
 
@@ -1532,7 +1571,7 @@ repeat_spec_same_data:
                                         param,
                                         cdr(val));
               } else {
-                bindings_cp = alist_remove(bindings_cp, cons(param, nil));
+                bindings_cp = alist_remove1(bindings_cp, param);
                 ub_p_a_pairs = cons(cons(param, arg), ub_p_a_pairs);
               }
             } else {
diff --git a/parser.y b/parser.y
index 9b440919..405e63d1 100644
--- a/parser.y
+++ b/parser.y
@@ -58,7 +58,8 @@ static obj_t *parsed_spec;
 %token <num> NUMBER
 %token <chr> REGCHAR LITCHAR
 
-%type <obj> spec clauses clause all_clause some_clause none_clause maybe_clause
+%type <obj> spec clauses clauses_opt clause
+%type <obj> all_clause some_clause none_clause maybe_clause
 %type <obj> cases_clause collect_clause clause_parts additional_parts
 %type <obj> output_clause define_clause try_clause catch_clauses_opt
 %type <obj> line elems_opt elems elem var var_op
@@ -80,7 +81,7 @@ static obj_t *parsed_spec;
 %%
 
 spec : clauses                  { parsed_spec = $1; }
-     |                          { parsed_spec = nil; }
+     | /* empty */              { parsed_spec = nil; }
      | error                    { parsed_spec = nil;
                                   yybadtoken(yychar, 0); }
      ;
@@ -89,6 +90,10 @@ clauses : clause                { $$ = cons($1, nil); }
         | clause clauses        { $$ = cons($1, $2);  }
         ;
 
+clauses_opt : clauses           { $$ = $1; }
+            | /* empty */       { $$ = nil; }
+            ;
+
 clause : all_clause             { $$ = list(num(lineno - 1), $1, nao); }
        | some_clause            { $$ = list(num(lineno - 1), $1, nao); }
        | none_clause            { $$ = list(num(lineno - 1), $1, nao); }
@@ -190,15 +195,11 @@ elem : TEXT                     { $$ = string($1); }
      ;
 
 define_clause : DEFINE exprs ')' newl
-                clauses
+                clauses_opt
                 END newl        { $$ = list(define, $2, $5, nao); }
               | DEFINE ')' newl
-                clauses
+                clauses_opt
                 END newl        { $$ = list(define, nil, $4, nao); }
-              | DEFINE exprs ')' newl
-                END newl        { $$ = list(define, $2, nao); }
-              | DEFINE ')' newl
-                END newl        { $$ = list(define, nao); }
               | DEFINE error    { yybadtoken(yychar, "list expression"); }
               | DEFINE exprs ')' newl
                 error           { yybadtoken(yychar, "define"); }
@@ -215,22 +216,36 @@ try_clause : TRY newl
                                             $3, $4, nao); }
            | TRY newl
              error              { $$ = nil;
+                                  if (yychar == END || yychar == CATCH ||
+                                      yychar == FINALLY)
+                                    yyerror("empty try clause");
+                                  else
+                                    yybadtoken(yychar, "try clause"); }
+           | TRY newl
+             clauses
+             error              { $$ = nil;
                                   yybadtoken(yychar, "try clause"); }
            ;
 
 catch_clauses_opt : CATCH ')' newl
-                    clauses
-                    catch_clauses_opt   { $$ = cons(list(catch, nil, $4, nao),
-                                                    $5); }
+                    clauses_opt
+                    catch_clauses_opt   { $$ = cons(list(catch, cons(t, nil),
+                                                         $4, nao), $5); }
                   | CATCH exprs ')' newl
-                    clauses
+                    clauses_opt
                     catch_clauses_opt   { $$ = cons(list(catch, $2, $5, nao),
                                                     $6); }
                   | FINALLY newl
-                    clauses             { $$ = cons(list(finally, nil,
+                    clauses_opt         { $$ = cons(list(finally, nil,
                                                          $3, nao),
                                                     nil); }
                   |                     { $$ = nil; }
+                  | CATCH ')' newl
+                    error               { yybadtoken(yychar, "try clause"); }
+                  | CATCH exprs ')' newl
+                    error               { yybadtoken(yychar, "try clause"); }
+                  | FINALLY newl
+                    error               { yybadtoken(yychar, "try clause"); }
                   ;
 
 
diff --git a/txr.1 b/txr.1
index cbc6887a..6cdc4401 100644
--- a/txr.1
+++ b/txr.1
@@ -21,7 +21,7 @@
 .\"IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
 .\"WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
-.TH txr 1 2009-10-14 "txr v. 015" "Text Extraction Utility"
+.TH txr 1 2009-10-14 "txr v. 016" "Text Extraction Utility"
 .SH NAME
 txr \- text extractor
 .SH SYNOPSIS
@@ -76,7 +76,7 @@ from their subqueries in special ways.
 
 .SH ARGUMENTS AND OPTIONS
 
-Options other than -D, -a and -f may be combined together into a single
+Options other than -D, -a and -c may be combined together into a single
 argument.  The -v and -q options are mutually exclusive. The one which occurs
 in the rightmost position in the argument list dominates.
 
@@ -135,12 +135,12 @@ reported as:
 The leftmost bracketed index is the most major index. That is to say,
 the dimension order is: NAME_m_m+1_..._n[1][2]...[m-1].
 
-.IP -f query
+.IP -c query
 Specifies the query in the form of a command line argument. If this option is
 used, the query-file argument is omitted. The first non-option argument,
 if there is one, now specifies the first input source rather than a query.
 Queries specified as arguments must properly end in a newline, as if they
-were read from a text file, thus -f "@a" is not a properly formed query.
+were read from a text file, thus -c "@a" is not a properly formed query.
 
 Example:
 
@@ -149,7 +149,7 @@ Example:
   # input is specified as - and the data
   # comes from shell "here document" redirection.
 
-  txr -f "@a
+  txr -c "@a
   @b
   " - <<!
   1
@@ -162,7 +162,7 @@ Example:
 
 The @# comment syntax can be used for better formatting:
 
-  txr -f "@#
+  txr -c "@#
   @a
   @b
   "
@@ -263,7 +263,7 @@ comment which follows does. Without this intuitive behavior,
 line comment would give rise to empty lines that must match empty
 lines in the data, leading to spurious mismatches.
 
-.SH Hash Bang Support
+.SS Hash Bang Support
 
 If the first line of a query begins with the characters #!,
 that entire line is deleted from the query. This allows
@@ -772,6 +772,9 @@ handling, discussed in the EXCEPTIONS section below.
 .IP @(catch), @(finally)
 Special clauses within @(try). See EXCEPTIONS below.
 
+.IP @(defex), @(throw)
+Define custom exception types; throw an exception.  See EXCEPTIONS below.
+
 .IP @(flatten)
 Normalizes a set of specified variables to one-dimensional lists. Those
 variables which have scalar value are reduced to lists of that value.
@@ -1919,12 +1922,11 @@ Example:
 
 Here, the function "which" is defined which calls "fun".
 A toplevel definition of "fun" is introduced which
-outputs "toplevel fun!". Then, within the func
-The function "callee" provides its own local definition
-of "fun" which outputs "local fun!" before calling "which".
-When callee is invoked, it calls @(which), whose @(fun) call is routed to
-callee's local definition.  When @(which) is called directly from the top
-level, its @(fun) call goes to the toplevel definition.
+outputs "toplevel fun!".  The function "callee" provides its own local
+definition of "fun" which outputs "local fun!" before calling "which".  When
+callee is invoked, it calls @(which), whose @(fun) call is routed to callee's
+local definition.  When @(which) is called directly from the top level, its
+@(fun) call goes to the toplevel definition.
 
 .SH OUTPUT
 
@@ -2174,7 +2176,7 @@ the try clause terminates, no matter how it terminates.
 
 .SS The Try Directive
 
-The general syntax of the try directive is 
+The general syntax of the try directive is
 
   @(try)
   ... main clause, required ...
@@ -2205,7 +2207,7 @@ A finally clause looks like:
   .
   .
 
-None of the clauses may be empty.
+The main clause may not be empty, but the catch and finally may be.
 
 A try clause is surrounded by an implicit anonymous block (see BLOCKS section
 above). So for instance, the following is a no-op (an operation with no effect,
@@ -2239,7 +2241,7 @@ in order for the block to terminate. But the try has a finally clause,
 which executes unconditionally, no matter how the try block
 terminates. The finally clause performs some output, which is seen.
 
-.SH The Finally Clause
+.SS The Finally Clause
 
 A try directive can terminate in one of three ways. The main clause
 may match successfully, and possibly yield some new variable bindings.
@@ -2350,8 +2352,8 @@ exception which is headed for the @(catch file_error), the finally
 clause performs an anonymous accept. The exit point for the accept
 is the anonymous block surrounding the inner try.  So the original
 transfer to the catch clause is forgotten. The inner try terminates
-sucessfully, and since it constitutes the main clause of the outer try,
-that also terminates sucessfully. The "file error caught" message is
+successfully, and since it constitutes the main clause of the outer try,
+that also terminates successfully. The "file error caught" message is
 never printed.
 
 .SS Catch Clauses
@@ -2406,6 +2408,120 @@ catch clause, which binds variable a to the input line "1".
 Then the finally clause executes, binding b to "2". The try block
 then terminates successfully, and so @c takes "3".
 
+.SS Catch Clauses with Parameters
+
+A catch may have parameters following the type name, like this:
+
+  @(catch pair (a b))
+
+To write a catch-all with parameters, explicitly write the
+master supertype t:
+
+  @(catch t (arg ...))
+
+Parameters are useful in conjunction with throw. The built-in
+error exceptions generate one argument, which is a string containing
+the error message. Using throw, arbitrary parameters can be passed
+from the throw site to the catches.
+
+.SS The Throw Directive
+
+The throw directive generates an exception. A type must be specified,
+followed by optional arguments. For example,
+
+  @(throw pair "a" `@file.txt`)
+
+throws an exception of type pair, with two arguments, being "a"
+and the expansion of the quasiliteral `@file.txt`.
+
+The selection of the target catch is performed purely using the type
+name; the parameters are not involved in the selection.
+
+Binding takes place between the arguments given in throw, and the
+target catch.
+
+If any catch parameter, for which a throw argument is given, is a bound
+variable, it has to be identical to the argument, otherwise the catch fails.
+(Control still passes to the catch, but the catch is a failed match).
+
+  Query:        @(bind a "apple")
+                @(try)
+                @(throw e "banana")
+                @(catch e a)
+                @(end)
+
+  Output:       [unhandled exception diagnostic]
+
+If any argument is an unbound variable, the corresponding parameter
+in the catch is left alone: if it is an unbound variable, it remains
+unbound, and if it is bound, it stays as is.
+
+  Query:        @(try)
+                @(trow e "honda" unbound)
+                @(catch e (car1 car2))
+                @car1 @car2
+                @(end)
+
+  Data:         honda toyota
+
+  Output:       car1="honda"
+                car2="toyota"
+
+If a catch has fewer parameters than there are throw arguments,
+the excess arguments are ignored.
+
+  Query:         @(try)
+                 @(throw e "banana" "apple" "pear")
+                 @(catch e (fruit))
+                 @(end)
+
+  Output:        fruit="banana"
+
+If a catch has more parameters than there are throw arguments, the excess
+parameters are left alone. They may be bound or unbound variables.
+
+  Query:        @(try)
+                @(trow e "honda")
+                @(catch e (car1 car2))
+                @car1 @car2
+                @(end)
+
+  Data:         honda toyota
+
+  Output:       car1="honda"
+                car2="toyota"
+
+A throw argument passing a value to a catch parameter which is unbound causes
+that parameter to be bound to that value.
+
+Throw arguments are evaluated in the context of the throw, and the bindings
+which are available there. Consideration of what parameters are bound
+is done in the context of the catch.
+
+  Query:        @(bind c "c")
+                @(try)
+                @(forget c)
+                @(bind (a c) ("a" "lc"))
+                @(throw e a c)
+                @(catch e (b a))
+                @(end)
+
+   Output:      c="c"
+                b="a"
+                a="lc"
+
+In the above example, c has a toplevel binding to the string "c",
+but is then unbound within the try construct, and rebound to the value "c".
+Since the try construct is terminated by a throw, these modifications of the
+binding environment are discarded. Hence, at the end of the query, variable
+c ends up bound to the original value "c".  The throw still takes place
+within the scope of the bindings set up by the try clause, so the values of
+a and c that are thrown are "a" and "lc".  However, at the catch site, variable
+a does not have a binding.  At that point, the binding to "a" established in
+the try has disappeared already. Being unbound, the catch parameter a can take
+whatever value the corresponding throw argument provides, so it ends up with
+"lc".
+
 .SH NOTES ON FALSE
 
 The reason for printing the word
diff --git a/txr.c b/txr.c
index de4d81a2..c0651f48 100644
--- a/txr.c
+++ b/txr.c
@@ -39,7 +39,7 @@
 #include "match.h"
 #include "txr.h"
 
-const char *version = "015";
+const char *version = "016";
 const char *progname = "txr";
 const char *spec_file = "stdin";
 obj_t *spec_file_str;
@@ -69,10 +69,12 @@ void help(void)
 "  %s [ options ] query-file { data-file }*\n"
 "\n"
 "The query-file or data-file arguments may be specified as -, in which case\n"
-"standard input is used. If these arguments end with a | character, then\n"
-"they are treated as command pipes. Leading arguments which begin with a -\n"
-"followed by one or more characters, and which are not arguments to options\n"
-"are interpreted as options. The -- option indicates the end of the options.\n"
+"standard input is used. All data-file arguments which begin with a !\n"
+"character are treated as command pipes. Those which begin with a $\n"
+"are interpreted as directories to read. Leading arguments which begin\n"
+"with a - followed by one or more characters, and which are not arguments to\n"
+"options are interpreted as options. The -- option indicates the end of the\n"
+"options.\n"
 "\n"
 "If no data-file arguments sare supplied, then the query itself must open a\n"
 "a data source prior to attempting to make any pattern match, or it will\n"
@@ -89,8 +91,9 @@ void help(void)
 "-a num                 Generate array variables up to num-dimensions.\n"
 "                       Default is 1. Additional dimensions are fudged\n"
 "                       by generating numeric suffixes\n"
-"-f query               Specify the query text as an argument.\n"
-"                       The query-file argument is omitted in this case.\n"
+"-c query-text          The query is read from the query-text argument\n"
+"                       itself. The query-file argument is omitted in\n"
+"                       this case; the first argument is a data file.\n"
 "--help                 You already know!\n"
 "--version              Display program version\n"
 "\n"
@@ -211,7 +214,7 @@ int main(int argc, char **argv)
       return 0;
     }
 
-    if (!strcmp(*argv, "-a") || !strcmp(*argv, "-f")) {
+    if (!strcmp(*argv, "-a") || !strcmp(*argv, "-c")) {
       long val;
       char *errp;
       char opt = (*argv)[1];
@@ -235,7 +238,7 @@ int main(int argc, char **argv)
 
         opt_arraydims = val;
         break;
-      case 'f':
+      case 'c':
         specstring = string(strdup(*argv));
         break;
       }
@@ -264,7 +267,7 @@ int main(int argc, char **argv)
           opt_nobindings = 1;
           break;
         case 'a':
-        case 'f':
+        case 'c':
         case 'D':
           fprintf(stderr, "%s: option -%c does not clump\n", progname, *popt);
           return EXIT_FAILURE;
diff --git a/unwind.c b/unwind.c
index c3df021e..0e32a51b 100644
--- a/unwind.c
+++ b/unwind.c
@@ -191,7 +191,7 @@ obj_t *uw_exception_subtype_p(obj_t *sub, obj_t *sup)
     return t;
   } else {
     obj_t *entry = assoc(exception_subtypes, sub);
-    return memq(sup, cdr(entry)) ? t : nil;
+    return memq(sup, entry) ? t : nil;
   }
 }
 
@@ -216,9 +216,11 @@ obj_t *uw_throw(obj_t *sym, obj_t *exception)
 
   if (ex == 0) {
     if (opt_loglevel >= 1) {
+      obj_t *s = stringp(exception);
       format(std_error, "~a: unhandled exception of type ~a:\n",
              prog_string, sym, nao);
-      format(std_error, "~a\n", exception, nao);
+      format(std_error, s ? "~a: ~a\n" : "~a: ~s\n",
+             prog_string, exception, nao);
     }
     if (uw_exception_subtype_p(sym, query_error) ||
         uw_exception_subtype_p(sym, file_error)) {
@@ -301,7 +303,7 @@ obj_t *type_mismatch(const char *fmt, ...)
   abort();
 }
 
-void uw_register_subtype(obj_t *sub, obj_t *sup)
+obj_t *uw_register_subtype(obj_t *sub, obj_t *sup)
 {
   obj_t *t_entry = assoc(exception_subtypes, t);
   obj_t *sub_entry = assoc(exception_subtypes, sub);
@@ -310,11 +312,11 @@ void uw_register_subtype(obj_t *sub, obj_t *sup)
   assert (t_entry != 0);
 
   if (sub == nil)
-    return;
+    return sup;
 
   if (sub == t) {
     if (sup == t)
-      return;
+      return sup;
     abort();
   }
 
@@ -334,6 +336,7 @@ void uw_register_subtype(obj_t *sub, obj_t *sup)
   /* Register sub as an immediate subtype of sup. */
   sub_entry = cons(sub, sup_entry);
   exception_subtypes = cons(sub_entry, exception_subtypes);
+  return sup;
 }
 
 void uw_continue(uw_frame_t *current, uw_frame_t *cont)
@@ -346,7 +349,7 @@ void uw_continue(uw_frame_t *current, uw_frame_t *cont)
 void uw_init(void)
 {
   protect(&toplevel_env.ev.func_bindings, &exception_subtypes, 0);
-  exception_subtypes = cons(cons(t, cons(t, nil)), exception_subtypes);
+  exception_subtypes = cons(cons(t, nil), exception_subtypes);
   uw_register_subtype(type_error, error);
   uw_register_subtype(internal_err, error);
   uw_register_subtype(numeric_err, error);
diff --git a/unwind.h b/unwind.h
index 574794b2..74d3e920 100644
--- a/unwind.h
+++ b/unwind.h
@@ -83,7 +83,7 @@ noreturn obj_t *uw_throwf(obj_t *sym, const char *fmt, ...);
 noreturn obj_t *uw_errorf(const char *fmt, ...);
 noreturn obj_t *uw_throwcf(obj_t *sym, const char *fmt, ...);
 noreturn obj_t *uw_errorcf(const char *fmt, ...);
-void uw_register_subtype(obj_t *sub, obj_t *super);
+obj_t *uw_register_subtype(obj_t *sub, obj_t *super);
 obj_t *uw_exception_subtype_p(obj_t *sub, obj_t *sup);
 void uw_continue(uw_frame_t *curr, uw_frame_t *target);
 void uw_pop_frame(uw_frame_t *);