exceptions: allow description field in catch frames.

* eval.c (op_catch): Extra argument in sys:catch syntax
specifies an expression that evaluates to a description
field.
(expand_catch): Expand the desc expression in sys:catch
syntax.

* parser.c (read_file_common): Increase acceptance of compiled
files from versions 1-4 to 1-5, since we are now marking
compiled files with version 5.0 rather than 4.0.

* share/txr/stdlib/asm.tl (op-catch catch): Support new
argument in the opcode syntax. Turns out we have a spare field
in the instruction format which was previously set to zero
We can use that for the description. Thus, the instruction
set and VM remain backward compatible: old code works.

* share/txr/stdlib/compiler.tl (compiler comp-catch): Handle
the desc argument introduced into the sys:catch form.
We must compile it as an expression, then inject the code into
the instruction template, and reference the output register of
that code block in the catch instruction.
(%tlo-ver%): Bump up the compiled file version to 5.0.

* share/txr/stdlib/except.tl (usr:catch, catch*): Add desc
argument to generated sys:catch form, specifying it as nil.

* unwind.c (desc_s): New symbol variable.
(uw_find_frames_impl): Set the desc member of the extracted
catch structure from the corresponding field in the catch
frame.
(uw_late_init): Initialize desc_s with interned symbol.
Add desc slot to catch-frame type.

* unwind.h (struct uw_catch): New member, desc.
(uw_catch_begin_w_desc): New macro.

* vm.c (vm_catch): Extract the desc field from the catch
instruction, and use uw_catch_begin_w_desc to propagate that
to the catch frame.

8 files changed, 49 insertions, 22 deletions

diff --git a/eval.c b/eval.c
index b9db0d8e..f57b084f 100644
--- a/eval.c
+++ b/eval.c
@@ -2595,17 +2595,19 @@ static val op_dwim(val form, val env)
 
 static val op_catch(val form, val env)
 {
-  val catch_syms = second(form);
-  val try_form = third(form);
+  val args = cdr(form);
+  val catch_syms = pop(&args);
+  val try_form = pop(&args);
+  val desc = pop(&args);
+  val catches = args;
   val result = nil;
 
-  uw_catch_begin (catch_syms, exsym, exvals);
+  uw_catch_begin_w_desc (catch_syms, exsym, exvals, desc);
 
   result = eval(try_form, env, try_form);
 
   uw_catch(exsym, exvals) {
     args_decl(args, ARGS_MIN);
-    val catches = rest(rest(rest(form)));
     val iter;
 
     args_add(args, exsym);
@@ -4437,19 +4439,23 @@ static val expand_catch(val form, val menv)
   val sym = pop(&args);
   val catch_syms = pop(&args);
   val try_form = pop(&args);
+  val desc = pop(&args);
   val catch_clauses = args;
   val try_form_ex = expand(try_form, menv);
+  val desc_ex = expand(desc, menv);
   val catch_clauses_ex = rlcp(mapcar(curry_12_1(func_n2(expand_catch_clause),
                                                 menv),
                                      catch_clauses),
                               catch_clauses);
 
-  if (try_form_ex == try_form && catch_clauses_ex == catch_clauses)
+  if (try_form_ex == try_form && desc_ex == desc &&
+      catch_clauses_ex == catch_clauses)
     return form;
 
   return rlcp(cons(sym,
                    cons(catch_syms,
-                        cons(try_form_ex, catch_clauses_ex))), form);
+                        cons(try_form_ex,
+                             cons(desc_ex, catch_clauses_ex)))), form);
 }
 
 static val expand_list_of_form_lists(val lofl, val menv, val ss_hash)
diff --git a/parser.c b/parser.c
index b7713f64..4ac341b7 100644
--- a/parser.c
+++ b/parser.c
@@ -645,7 +645,7 @@ static val read_file_common(val self, val stream, val error_stream, val compiled
 
     if (compiled && first) {
       val major = car(form);
-      if (lt(major, one) || gt(major, four))
+      if (lt(major, one) || gt(major, num_fast(5)))
         uw_throwf(error_s,
                   lit("cannot load ~s: version number mismatch"),
                   stream, nao);
diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl
index 75d84471..b270c4bf 100644
--- a/share/txr/stdlib/asm.tl
+++ b/share/txr/stdlib/asm.tl
@@ -653,11 +653,12 @@
 
 (defopcode op-catch catch auto
   (:method asm (me asm syntax)
-    me.(chk-arg-count 4 syntax)
-    (tree-bind (sym args catch-syms dst) asm.(parse-args me syntax '(d d r l))
+    me.(chk-arg-count 5 syntax)
+    (tree-bind (sym args catch-syms desc dst)
+               asm.(parse-args me syntax '(d d r r l))
       asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))
       asm.(put-pair sym args)
-      asm.(put-pair 0 catch-syms)))
+      asm.(put-pair desc catch-syms)))
 
   (:method backpatch (me asm at dst)
     asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))
@@ -665,9 +666,10 @@
  (:method dis (me asm high16 low16)
    (let ((dst (logior (ash high16 16) low16)))
      (tree-bind (sym args) asm.(get-pair)
-       (let ((catch-syms (cadr asm.(get-pair))))
+       (tree-bind (desc catch-syms) asm.(get-pair)
          ^(,me.symbol ,(operand-to-sym sym) ,(operand-to-sym args)
-                      ,(operand-to-sym catch-syms) ,dst))))))
+                      ,(operand-to-sym catch-syms)
+                      ,(operand-to-sym desc) ,dst))))))
 
 (defopcode op-handle handle auto
   (:method asm (me asm syntax)
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 3d906866..eea91b62 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -658,12 +658,13 @@
                  (uni ffrag.ffuns bfrag.ffuns))))))
 
 (defmeth compiler comp-catch (me oreg env form)
-  (mac-param-bind form (op symbols try-expr . clauses) form
+  (mac-param-bind form (op symbols try-expr desc-expr . clauses) form
     (with-gensyms (ex-sym-var ex-args-var)
       (let* ((nenv (new env up env co me))
              (esvb (cdar nenv.(extend-var ex-sym-var)))
              (eavb (cdar nenv.(extend-var ex-args-var)))
              (tfrag me.(compile oreg env try-expr))
+             (dfrag me.(compile oreg env desc-expr))
              (lhand (gensym "l"))
              (lhend (gensym "l"))
              (treg me.(alloc-treg))
@@ -691,7 +692,9 @@
         me.(free-treg treg)
         (new (frag tfrag.oreg
                    ^((frame ,nenv.lev ,nenv.v-cntr)
-                     (catch ,esvb.loc ,eavb.loc ,me.(get-dreg symbols) ,lhand)
+                     ,*dfrag.code
+                     (catch ,esvb.loc ,eavb.loc
+                            ,me.(get-dreg symbols) ,dfrag.oreg ,lhand)
                      ,*tfrag.code
                      (jmp ,lhend)
                      ,lhand
@@ -1580,7 +1583,7 @@
 
 (defvarl %big-endian% (equal (ffi-put 1 (ffi uint32)) #b'00000001'))
 
-(defvarl %tlo-ver% ^(4 0 ,%big-endian%))
+(defvarl %tlo-ver% ^(5 0 ,%big-endian%))
 
 (defvarl %package-manip% '(make-package delete-package
                            use-package unuse-package
diff --git a/share/txr/stdlib/except.tl b/share/txr/stdlib/except.tl
index 83506232..a2cc684c 100644
--- a/share/txr/stdlib/except.tl
+++ b/share/txr/stdlib/except.tl
@@ -35,11 +35,11 @@
                                                                    e nil form)
                                        ^(,type (,(gensym) ,*args-ex) ,*body-ex)))
                                    catch-clauses)))
-    ^(sys:catch ,catch-syms ,try-form ,*sys-catch-clauses)))
+    ^(sys:catch ,catch-syms ,try-form nil ,*sys-catch-clauses)))
 
 (defmacro catch* (try-form . catch-clauses)
   (let ((catch-syms [mapcar car catch-clauses]))
-    ^(sys:catch ,catch-syms ,try-form ,*catch-clauses)))
+    ^(sys:catch ,catch-syms ,try-form nil ,*catch-clauses)))
 
 (defun sys:expand-handle (form try-form handle-clauses)
   (let* ((oper (car form))
diff --git a/unwind.c b/unwind.c
index f8887c80..f3a4df24 100644
--- a/unwind.c
+++ b/unwind.c
@@ -57,7 +57,8 @@ static uw_frame_t *uw_exit_point;
 static uw_frame_t toplevel_env;
 static uw_frame_t unhandled_ex;
 
-static val unhandled_hook_s, types_s, jump_s, sys_cont_s, sys_cont_poison_s;
+static val unhandled_hook_s, types_s, jump_s, desc_s;
+static val sys_cont_s, sys_cont_poison_s;
 static val sys_cont_free_s, sys_capture_cont_s;
 
 static val frame_type, catch_frame_type, handle_frame_type;
@@ -363,10 +364,12 @@ static val uw_find_frames_impl(val extype, val frtype, val just_one)
         args_decl(args, ARGS_MIN);
         val fr = make_struct(frtype, nil, args);
         slotset(fr, types_s, ex->ca.matches);
-        if (et == UW_CATCH)
+        if (et == UW_CATCH) {
+          slotset(fr, desc_s, ex->ca.desc);
           slotset(fr, jump_s, cptr(coerce(mem_t *, ex)));
-        else
+        } else {
           slotset(fr, fun_s, ex->ha.fun);
+        }
         if (just_one)
           return fr;
         ptail = list_collect(ptail, fr);
@@ -1054,6 +1057,7 @@ void uw_late_init(void)
           &deferred_warnings, &tentative_defs, convert(val *, 0));
   types_s = intern(lit("types"), user_package);
   jump_s = intern(lit("jump"), user_package);
+  desc_s = intern(lit("desc"), user_package);
   sys_cont_s = intern(lit("cont"), system_package);
   sys_cont_poison_s = intern(lit("cont-poison"), system_package);
   sys_cont_free_s = intern(lit("cont-free"), system_package);
@@ -1062,7 +1066,7 @@ void uw_late_init(void)
   catch_frame_type = make_struct_type(intern(lit("catch-frame"),
                                              user_package),
                                       frame_type, nil,
-                                      list(types_s, jump_s, nao),
+                                      list(types_s, desc_s, jump_s, nao),
                                       nil, nil, nil, nil);
   handle_frame_type = make_struct_type(intern(lit("handle-frame"),
                                               user_package),
diff --git a/unwind.h b/unwind.h
index 074b79fe..0dfeea17 100644
--- a/unwind.h
+++ b/unwind.h
@@ -61,6 +61,7 @@ struct uw_catch {
   int visible;
   val sym;
   val args;
+  val desc;
   uw_frame_t *cont;
   extended_jmp_buf jb;
 };
@@ -203,6 +204,16 @@ noreturn val type_mismatch(val, ...);
     switch (extended_setjmp(uw_catch.ca.jb)) {  \
     case 0:
 
+#define uw_catch_begin_w_desc(MATCHES, SYMVAR,  \
+                              EXCVAR, DESC)     \
+  do {                                          \
+    obj_t *SYMVAR = nil;                        \
+    obj_t *EXCVAR = nil;                        \
+    uw_frame_t uw_catch;                        \
+    uw_push_catch(&uw_catch, MATCHES);          \
+    uw_catch.ca.desc = (DESC);                  \
+    switch (extended_setjmp(uw_catch.ca.jb)) {  \
+    case 0:
 #define uw_catch(SYMVAR, EXCVAR)        \
     goto uw_unwind_label;               \
       break;                            \
diff --git a/vm.c b/vm.c
index 26d52edd..90b99210 100644
--- a/vm.c
+++ b/vm.c
@@ -859,9 +859,10 @@ NOINLINE static void vm_catch(struct vm *vm, vm_word_t insn)
   unsigned sym_reg = vm_arg_operand_hi(arg1);
   unsigned args_reg = vm_arg_operand_lo(arg1);
   val catch_syms = vm_get(vm->dspl, vm_arg_operand_lo(arg2));
+  val desc = vm_get(vm->dspl, vm_arg_operand_hi(arg2));
   int saved_lev = vm->lev;
 
-  uw_catch_begin (catch_syms, exsym, exvals);
+  uw_catch_begin_w_desc (catch_syms, exsym, exvals, desc);
 
   vm_execute(vm);