From 41ea4bd2c8791696525aadb0a457ba36fa1d204e Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 25 Jan 2017 10:29:27 -0800 Subject: 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. --- eval.c | 5 ++++- share/txr/stdlib/except.tl | 13 ++++++++++--- tests/012/struct.tl | 24 ++++++++++++------------ txr.1 | 16 +++++++++++++++- 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 -- cgit v1.2.3