diff options
| -rw-r--r-- | eval.c | 18 | ||||
| -rw-r--r-- | share/txr/stdlib/yield.tl | 5 | ||||
| -rw-r--r-- | txr.1 | 55 | ||||
| -rw-r--r-- | unwind.c | 47 | ||||
| -rw-r--r-- | unwind.h | 1 |
5 files changed, 121 insertions, 5 deletions
@@ -84,7 +84,7 @@ val setq_s, inc_s, zap_s; val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s; val append_each_s, append_each_star_s, while_s, while_star_s, until_star_s; val dohash_s; -val uw_protect_s, return_s, return_from_s; +val uw_protect_s, return_s, return_from_s, sys_abscond_from_s; val list_s, append_s, apply_s, iapply_s; val gen_s, gun_s, generate_s, rest_s, plus_s; val promise_s, promise_forced_s, promise_inprogress_s, force_s; @@ -1858,6 +1858,16 @@ static val op_return_from(val form, val env) abort(); } +static val op_abscond_from(val form, val env) +{ + val name = second(form); + val retval = eval(third(form), env, form); + uw_block_abscond(name, retval); + eval_error(form, lit("sys:abscond-from: no block named ~s is visible"), + name, nao); + abort(); +} + static val op_dwim(val form, val env) { val argexps = rest(form); @@ -3030,7 +3040,9 @@ tail: } else { return rlcp(cons(sym, cons(funcs_ex, body_ex)), form); } - } else if (sym == block_s || sym == return_from_s) { + } else if (sym == block_s || sym == return_from_s || + sym == sys_abscond_from_s) + { val name = second(form); val body = rest(rest(form)); val body_ex = expand_progn(body, menv); @@ -4157,6 +4169,7 @@ void eval_init(void) uw_protect_s = intern(lit("unwind-protect"), user_package); return_s = intern(lit("return"), user_package); return_from_s = intern(lit("return-from"), user_package); + sys_abscond_from_s = intern(lit("abscond-from"), system_package); gethash_s = intern(lit("gethash"), user_package); car_s = intern(lit("car"), user_package); cdr_s = intern(lit("cdr"), user_package); @@ -4252,6 +4265,7 @@ void eval_init(void) reg_op(block_s, op_block); reg_op(return_s, op_return); reg_op(return_from_s, op_return_from); + reg_op(sys_abscond_from_s, op_abscond_from); reg_op(dwim_s, op_dwim); reg_op(quasi_s, op_quasi_lit); reg_op(catch_s, op_catch); diff --git a/share/txr/stdlib/yield.tl b/share/txr/stdlib/yield.tl index 0a623a2b..ef0518e6 100644 --- a/share/txr/stdlib/yield.tl +++ b/share/txr/stdlib/yield.tl @@ -51,8 +51,9 @@ (let ((cont-sym (gensym))) ^(sys:yield-impl ',name (lambda (,cont-sym) - (return-from ,name (new (sys:yld-item - ,form (cdr ,cont-sym))))) + (sys:abscond-from ,name + (new (sys:yld-item + ,form (cdr ,cont-sym))))) ',ctx-form))) (defmacro yield (form) @@ -27413,6 +27413,25 @@ and which create an abstraction which models the continuation as a suspended procedure supporting two-way communication of data. +Continuations raise the issue of what to do about unwinding. +The language Scheme provides the much criticized +.code dynamic-wind +operator which can execute initialization and clean-up code as +a continuation is entered and abandoned. \*(TX takes a simpler, +albeit risky approach. It provides a non-unwinding escape operator +.code sys:abscond-from +for use with continuations. Code which has captured a continuation +can use this operator to escape from the delimiting block without +triggering any unwinding among the frames between the capture point and the +delimiter. When the continuation is restarted, it will then do so +with all of the resources associated with it frames intact. +When the continuation executes normal returns within its context, +the unwinding takes place then. Thus tidy, "thread-like" use +of continuations is possible with a small measure of coding discipline. +Unfortunately, the absconding operator is dangerous: its use +breaks the language guarantee that clean-up associated with a form is done no +matter how a form terminates. + .TP* Notes: Delimited continuations resemble lexical closures in some ways. Both @@ -27548,6 +27567,37 @@ with named prompts. --> 24 .cble +.coNP Operator @ sys:abscond-from +.synb +.mets (sys:abscond-from < name <> [ value ]) +.syne +.desc +The +.code sys:abscond-from +operator closely resembles +.code return-from +and performs the same thing: it causes an enclosing block +.meta name +to terminate with +.meta value +which defaults to +.codn nil . + +However, unlike +.codn return-from , +.code sys:abscond-from +does not perform any unwinding. + +This operator should never be used for any purpose other than +implementing primitives for the use of delimited continuations. +It is used by the +.code yield-from +and +.code yield +operators to escape out of a block in which a continuation has +been captured. Neglecting to unwind is valid due to the expectation +that control will return into a restarted copy of that context. + .coNP Macros @ obtain and @ yield-from .synb .mets (obtain << forms *) @@ -27573,7 +27623,10 @@ are encapsulated in a special Finally, .code yield-from performs a non-local transfer to the same block, so that the yield object -appears as the result value of that block. +appears as the result value of that block. The non-local transfer is +performed abruptly, by the +.code sys:abscond-from +operator. An .code obtain @@ -114,6 +114,34 @@ static void uw_unwind_to_exit_point(void) } } +static void uw_abscond_to_exit_point(void) +{ + assert (uw_exit_point); + + for (; uw_stack && uw_stack != uw_exit_point; uw_stack = uw_stack->uw.up) { + switch (uw_stack->uw.type) { + case UW_ENV: + uw_env_stack = uw_env_stack->ev.up_env; + break; + default: + break; + } + } + + if (!uw_stack) + abort(); + + uw_exit_point = 0; + + switch (uw_stack->uw.type) { + case UW_BLOCK: + extended_longjmp(uw_stack->bl.jb, 1); + abort(); + default: + abort(); + } +} + void uw_push_block(uw_frame_t *fr, val tag) { memset(fr, 0, sizeof *fr); @@ -356,6 +384,25 @@ val uw_block_return_proto(val tag, val result, val protocol) abort(); } +val uw_block_abscond(val tag, val result) +{ + uw_frame_t *ex; + + for (ex = uw_stack; ex != 0; ex = ex->uw.up) { + if (ex->uw.type == UW_BLOCK && ex->bl.tag == tag) + break; + } + + if (ex == 0) + return nil; + + ex->bl.result = result; + ex->bl.protocol = nil; + uw_exit_point = ex; + uw_abscond_to_exit_point(); + abort(); +} + void uw_push_catch(uw_frame_t *fr, val matches) { memset(fr, 0, sizeof *fr); @@ -102,6 +102,7 @@ INLINE val uw_block_return(val tag, val result) { return uw_block_return_proto(tag, result, nil); } +val uw_block_abscond(val tag, val result); 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); |