New catch*, giving access to exception symbol.

* eval.c (op_catch): The sys:catch operator now passes the
exception symbol as the first argument of each clause.
This means the catch macro must be adjusted.

* share/txr/stdlib/except.tl (catch): Macro now inserts
a gensym dummy first argument into each clause to take the
symbol passed by the sys:catch operator.
(catch*): New macro, which is identical to the previous
catch macro, and thus exposes the symbol passed as the
first argument.

* txr.1: Documented catch*.

* tests/012/struct.tl: Some gensym numbers need adjusting
in one test case.

4 files changed, 41 insertions, 17 deletions

diff --git a/eval.c b/eval.c
index b46cfb05..74521190 100644
--- a/eval.c
+++ b/eval.c
@@ -2285,10 +2285,13 @@ static val op_catch(val form, val env)
   result = eval(try_form, env, try_form);
 
   uw_catch(exsym, exvals) {
-    args_decl_list(args, ARGS_MIN, exvals);
+    args_decl(args, ARGS_MIN);
     val catches = rest(rest(rest(form)));
     val iter;
 
+    args_add(args, exsym);
+    args_add_list(args, exvals);
+
     for (iter = catches; iter; iter = cdr(iter)) {
       val clause = car(iter);
       val type = first(clause);
diff --git a/share/txr/stdlib/except.tl b/share/txr/stdlib/except.tl
index 17055207..abba8bdb 100644
--- a/share/txr/stdlib/except.tl
+++ b/share/txr/stdlib/except.tl
@@ -27,9 +27,16 @@
 (defun sys:handle-bad-syntax (item)
   (throwf 'eval-error "~s: bad clause syntax: ~s" 'handle item))
 
-(defmacro catch (try-form . handle-clauses)
-  (let ((catch-syms [mapcar car handle-clauses]))
-    ^(sys:catch ,catch-syms ,try-form ,*handle-clauses)))
+(defmacro catch (:form form try-form . catch-clauses)
+  (let ((catch-syms [mapcar car catch-clauses])
+        (sys-catch-clauses (mapcar (do mac-param-bind @1 (type args . body) @1
+                                     ^(,type (,(gensym) ,*args) ,*body))
+                                   catch-clauses)))
+    ^(sys:catch ,catch-syms ,try-form ,*sys-catch-clauses)))
+
+(defmacro catch* (try-form . catch-clauses)
+  (let ((catch-syms [mapcar car catch-clauses]))
+    ^(sys:catch ,catch-syms ,try-form ,*catch-clauses)))
 
 (defmacro handle (:whole form try-form . handle-clauses)
   (let* ((exc-sym (gensym))
diff --git a/tests/012/struct.tl b/tests/012/struct.tl
index a22d32d0..7b0b7fd8 100644
--- a/tests/012/struct.tl
+++ b/tests/012/struct.tl
@@ -64,20 +64,20 @@
 (stest (sys:expand '(defstruct (boa x y) nil
                       (x 0) (y 0)))
        "(sys:make-struct-type 'boa '() '()\n                                            \
-       \                      '(x y) () (lambda (#:g0004)\n                             \
-       \                                  (let ((#:g0005 (struct-type #:g0004)))\n      \
-       \                                    (if (static-slot-p #:g0005 'x)\n            \
-       \                                      () (slotset #:g0004 'x\n                  \
+       \                      '(x y) () (lambda (#:g0008)\n                             \
+       \                                  (let ((#:g0009 (struct-type #:g0008)))\n      \
+       \                                    (if (static-slot-p #:g0009 'x)\n            \
+       \                                      () (slotset #:g0008 'x\n                  \
        \                                                  0))\n                         \
-       \                                    (if (static-slot-p #:g0005 'y)\n            \
-       \                                      () (slotset #:g0004 'y\n                  \
+       \                                    (if (static-slot-p #:g0009 'y)\n            \
+       \                                      () (slotset #:g0008 'y\n                  \
        \                                                  0))))\n                       \
-       \                      (lambda (#:g0004 #:g0006\n                                \
-       \                               #:g0007)\n                                       \
-       \                        (slotset #:g0004 'x\n                                   \
-       \                                 #:g0006)\n                                     \
-       \                        (slotset #:g0004 'y\n                                   \
-       \                                 #:g0007))\n                                    \
+       \                      (lambda (#:g0008 #:g0010\n                                \
+       \                               #:g0011)\n                                       \
+       \                        (slotset #:g0008 'x\n                                   \
+       \                                 #:g0010)\n                                     \
+       \                        (slotset #:g0008 'y\n                                   \
+       \                                 #:g0011))\n                                    \
        \                      ())")
 
 (defstruct (boa x y) nil
diff --git a/txr.1 b/txr.1
index c0ce427b..4abfebb1 100644
--- a/txr.1
+++ b/txr.1
@@ -33055,10 +33055,12 @@ using the
 .code format
 string and additional arguments.
 
-.coNP Macro @ catch
+.coNP Macros @ catch and @ catch*
 .synb
 .mets (catch < try-expression
 .mets \ \  >> {( symbol <> ( arg *) << body-form *)}*)
+.mets (catch* < try-expression
+.mets \ \  >> {( symbol >> ( type-arg << arg *) << body-form *)}*)
 .syne
 .desc
 The
@@ -33113,6 +33115,18 @@ If there is only one element,
 takes on the value
 .codn nil .
 
+The
+.code catch*
+macro is a variant of
+.code catch
+with the following difference: when
+.code catch*
+invokes a clause, it passes the exception symbol as the leftmost argument
+.metn type-arg .
+Then the exception arguments follow. In contrast,
+only the exception arguments are passed to the clauses of
+.codn catch .
+
 Also see: the
 .code unwind-protect
 operator, and the functions