diff --git a/src/alloc.c b/src/alloc.c index 377d5a0..c305a53 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -187,7 +187,7 @@ obj Mcallcc_continuation(obj prev, obj env, obj winders) { return x; } -obj Mcallwv_continuation(obj prev, obj env, obj consumer) { +obj Mcallwv_continuation(obj prev, obj env, obj producer, obj consumer) { obj x = GC_malloc(Mcontinuation_callwv_size); obj_type(x) = CONTINUATON_OBJ_TYPE; Mcontinuation_type(x) = CALLWV_CONT_TYPE; @@ -195,7 +195,7 @@ obj Mcallwv_continuation(obj prev, obj env, obj consumer) { Mcontinuation_capturedp(x) = 0; Mcontinuation_prev(x) = prev; Mcontinuation_env(x) = env; - Mcontinuation_callwv_producer(x) = Mfalse; + Mcontinuation_callwv_producer(x) = producer; Mcontinuation_callwv_consumer(x) = consumer; return x; } diff --git a/src/check.c b/src/check.c index a0530a7..975ee4a 100644 --- a/src/check.c +++ b/src/check.c @@ -20,20 +20,6 @@ static void check_1ary_syntax(obj e) { bad_syntax_exn(e); } -// Already assumes `expr` is `( . )` -// Check: `expr` must be `( ) -static void check_2ary_syntax(obj e) { - obj rib; - - rib = Mcdr(e); - if (!Mconsp(rib)) - bad_syntax_exn(e); - - rib = Mcdr(rib); - if (!Mconsp(rib) || !Mnullp(Mcdr(rib))) - bad_syntax_exn(e); -} - // Already assumes `expr` is `( . )` // Check: `expr` must be `( ) static void check_3ary_syntax(obj e) { @@ -243,10 +229,6 @@ void check_expr(obj e) { check_setb(e); } else if (hd == Mquote_symbol) { check_1ary_syntax(e); - } else if (hd == Mcallwv_symbol) { - check_2ary_syntax(e); - check_expr(Mcadr(e)); - check_expr(Mcaddr(e)); } else if (Mlistp(e)) { for (it = e; !Mnullp(it); it = Mcdr(it)) check_expr(Mcar(it)); diff --git a/src/eval.c b/src/eval.c index d45327e..68caecf 100644 --- a/src/eval.c +++ b/src/eval.c @@ -336,11 +336,11 @@ static obj eval_k(obj e) { // quote x = Mcadr(e); goto do_k; - } else if (hd == Mcallwv_symbol) { - // call-with-values - Mtc_cc(tc) = Mcallwv_continuation(Mtc_cc(tc), Mtc_env(tc), Mcaddr(e)); - e = Mcadr(e); - goto loop; + // } else if (hd == Mcallwv_symbol) { + // // call-with-values + // Mtc_cc(tc) = Mcallwv_continuation(Mtc_cc(tc), Mtc_env(tc), Mcaddr(e)); + // e = Mcadr(e); + // goto loop; } else { // application Mtc_cc(tc) = Mapp_continuation(Mtc_cc(tc), Mtc_env(tc), e); @@ -381,9 +381,14 @@ static obj eval_k(obj e) { Mtc_cc(tc) = Mdynwind_continuation(Mtc_cc(tc), Mtc_env(tc), Mcar(args), Mcadr(args), Mcaddr(args)); x = Mvoid; } else if (f == callcc_prim) { + check_callcc(Mcar(args)); continuation_set_immutable(Mtc_cc(tc)); // freeze the continuation chain Mtc_cc(tc) = Mcallcc_continuation(Mtc_cc(tc), Mtc_env(tc), Mtc_wnd(tc)); x = Mcar(args); + } else if (f == callwv_prim) { + assert_thunk("call-with-values", Mcar(args)); + Mtc_cc(tc) = Mcallwv_continuation(Mtc_cc(tc), Mtc_env(tc), Mcar(args), Mcadr(args)); + x = Mvoid; } else { x = do_prim(f, args); } @@ -462,9 +467,6 @@ static obj eval_k(obj e) { goto do_k; } else { // capturing current continuation - assert_single_value(Mtc_cc(tc), x); - check_callcc(x); - Mtc_cc(tc) = continuation_mutable(Mtc_cc(tc)); Mcontinuation_capturedp(Mtc_cc(tc)) = 1; @@ -478,27 +480,13 @@ static obj eval_k(obj e) { // call-with-values expressions case CALLWV_CONT_TYPE: Mtc_cc(tc) = continuation_mutable(Mtc_cc(tc)); - if (Mfalsep(Mcontinuation_callwv_producer(Mtc_cc(tc)))) { - // evaluated producer syntax - assert_single_value(Mtc_cc(tc), x); - assert_thunk("call-with-values", x); - - Mcontinuation_callwv_producer(Mtc_cc(tc)) = x; - e = Mcontinuation_callwv_consumer(Mtc_cc(tc)); - Mtc_env(tc) = Mcontinuation_env(Mtc_cc(tc)); - goto loop; - } else if (!Mprocp(Mcontinuation_callwv_consumer(Mtc_cc(tc)))) { - // evaluated consumer syntax - assert_single_value(Mtc_cc(tc), x); - if (!Mprocp(x)) { - minim_error1("call-with-values", "expected a procedure", x); - } - - Mcontinuation_callwv_consumer(Mtc_cc(tc)) = x; + if (Mprocp(Mcontinuation_callwv_producer(Mtc_cc(tc)))) { + // first time => evaluate producer f = Mcontinuation_callwv_producer(Mtc_cc(tc)); args = Mnull; Mtc_env(tc) = Mcontinuation_env(Mtc_cc(tc)); + Mcontinuation_callwv_producer(Mtc_cc(tc)) = Mfalse; goto do_app; } else { // evaluated producer procedure diff --git a/src/expand.c b/src/expand.c index 49158a9..620f4ba 100644 --- a/src/expand.c +++ b/src/expand.c @@ -288,8 +288,6 @@ obj expand_expr(obj e) { return Mlist3(Msetb_symbol, Mcadr(e), expand_expr(Mcaddr(e))); } else if (hd == Mquote_symbol) { return e; - } else if (hd == Mcallwv_symbol) { - return Mlist3(Mcallwv_symbol, expand_expr(Mcadr(e)), expand_expr(Mcaddr(e))); } else { hd = tl = Mcons(expand_expr(Mcar(e)), Mnull); for (it = Mcdr(e); !Mnullp(it); it = Mcdr(it)) { diff --git a/src/global.c b/src/global.c index 3e83c72..a1b061f 100644 --- a/src/global.c +++ b/src/global.c @@ -11,7 +11,6 @@ obj Mvalues; obj Munbound; obj Mbegin_symbol; -obj Mcallwv_symbol; obj Mif_symbol; obj Mlambda_symbol; obj Mlet_symbol; @@ -47,7 +46,6 @@ void minim_init(void) { // intern symbols Mbegin_symbol = Mintern("begin"); - Mcallwv_symbol = Mintern("call-with-values"); Mif_symbol = Mintern("if"); Mlambda_symbol = Mintern("lambda"); Mlet_symbol = Mintern("let"); diff --git a/src/minim.h b/src/minim.h index 458ccde..dfa18c8 100644 --- a/src/minim.h +++ b/src/minim.h @@ -54,7 +54,6 @@ typedef void *obj; // Syntax extern obj Mbegin_symbol; -extern obj Mcallwv_symbol; extern obj Mif_symbol; extern obj Mlambda_symbol; extern obj Mlet_symbol; @@ -309,7 +308,7 @@ obj Mseq_continuation(obj prev, obj env, obj seq); obj Mlet_continuation(obj prev, obj env, obj bindings, obj body); obj Msetb_continuation(obj prev, obj env, obj name); obj Mcallcc_continuation(obj prev, obj env, obj winders); -obj Mcallwv_continuation(obj prev, obj env, obj producer); +obj Mcallwv_continuation(obj prev, obj env, obj producer, obj consumer); obj Mdynwind_continuation(obj prev, obj env, obj pre, obj val, obj post); obj Mwinders_continuation(obj prev, obj env, obj winders); @@ -478,6 +477,7 @@ extern obj fx_gt_prim; extern obj fx_lt_prim; extern obj callcc_prim; +extern obj callwv_prim; extern obj dynwind_prim; extern obj values_prim; diff --git a/src/prim.c b/src/prim.c index 8b46cd9..5ad696e 100644 --- a/src/prim.c +++ b/src/prim.c @@ -24,6 +24,7 @@ obj fx_gt_prim; obj fx_lt_prim; obj callcc_prim; +obj callwv_prim; obj dynwind_prim; obj values_prim; @@ -40,6 +41,10 @@ static obj callcc_proc() { minim_error("callcc_proc()", "should never call"); } +static obj callwv_proc() { + minim_error("callwv_proc()", "should never call"); +} + static obj dynwind_proc() { minim_error("dynwind_proc()", "should never call"); } @@ -73,6 +78,7 @@ void init_prims(void) { fx_lt_prim = Mprim(Mfx_lt, 2, "fx2<"); callcc_prim = Mprim(callcc_proc, 1, "call-with-current-continuation"); + callwv_prim = Mprim(callwv_proc, 2, "call-with-values"); dynwind_prim = Mprim(dynwind_proc, 3, "dynamic-wind"); values_prim = Mprim(values_proc, -1, "values"); } @@ -106,6 +112,7 @@ obj prim_env(obj env) { env_insert(env, Mintern("call/cc"), callcc_prim); env_add_prim(env, callcc_prim); + env_add_prim(env, callwv_prim); env_add_prim(env, dynwind_prim); env_add_prim(env, values_prim);