call-with-values is a procedure

Author: bksaiki

src/alloc.c

@@ -187,15 +187,15 @@ 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;
     Mcontinuation_immutablep(x) = 0;
     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;
 }

src/check.c

@@ -20,20 +20,6 @@ static void check_1ary_syntax(obj e) {
         bad_syntax_exn(e);
 }
 
-// Already assumes `expr` is `(<name> . <???>)`
-// Check: `expr` must be `(<name> <datum>)
-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 `(<name> . <???>)`
 // Check: `expr` must be `(<name> <datum> <datum> <datum>)
 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));

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

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)) {

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");

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;
 

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);