add apply primitive

Author: bksaiki

src/eval.c

@@ -109,6 +109,27 @@ static void check_prim_arity(obj f, obj args) {
     minim_error1("eval_expr", "primitive arity unsupported", Mfixnum(Mprim_arity(f)));
 }
 
+// performs `apply` primitive
+// flattens the last argument (checks that it is a list)
+static obj do_apply(obj args) {
+    obj hd;
+
+    if (Mnullp(Mcdr(args))) {
+        if (!Mlistp(Mcar(args)))
+            minim_error1("apply", "expected list?", Mcar(args));
+        return Mcar(args);
+    } else {
+        hd = args;
+        while (!Mnullp(Mcddr(args))) args = Mcdr(args);
+    
+        if (!Mlistp(Mcadr(args)))
+            minim_error1("apply", "expected list?", Mcadr(args));
+        Mcdr(args) = Mcadr(args);
+    
+        return hd;
+    }
+}
+
 // performs `values` primitive
 // if there is only 1 argument, the argument is returned
 // otherwise, the arguments are written to the values buffer
@@ -212,11 +233,14 @@ static obj do_prim(obj f, obj args) {
 
     switch (Mprim_arity(f))
     {
-    case 0: return fn();
-    case 1: return fn(Mcar(args));
-    case 2: return fn(Mcar(args), Mcadr(args));
-    case 3: return fn(Mcar(args), Mcadr(args), Mcaddr(args));
-    
+    case 0:
+        return fn();
+    case 1:
+        return fn(Mcar(args));
+    case 2:
+        return fn(Mcar(args), Mcadr(args));
+    case 3:
+        return fn(Mcar(args), Mcadr(args), Mcaddr(args));
     default:
         minim_error1("eval_expr", "primitive arity unsupported", Mfixnum(Mprim_arity(f)));
     }
@@ -440,7 +464,13 @@ static obj eval_k(obj e) {
     if (Mprimp(f)) {
         check_prim_arity(f, args);
         if (Mprim_specialp(f)) {
-            x = do_special_prim(f, args);
+            if (f == apply_prim) {
+                f = Mcar(args);
+                args = do_apply(Mcdr(args));
+                goto do_app;
+            } else {
+                x = do_special_prim(f, args);
+            }
         } else {
             x = do_prim(f, args);
         }

src/minim.h

@@ -479,6 +479,7 @@ extern obj fx_le_prim;
 extern obj fx_gt_prim;
 extern obj fx_lt_prim;
 
+extern obj apply_prim;
 extern obj callcc_prim;
 extern obj callwv_prim;
 extern obj exit_prim;

src/prim.c

@@ -24,6 +24,7 @@ obj fx_le_prim;
 obj fx_gt_prim;
 obj fx_lt_prim;
 
+obj apply_prim;
 obj callcc_prim;
 obj callwv_prim;
 obj exit_prim;
@@ -44,6 +45,7 @@ proc1(nullp_proc, x, Mbool(Mnullp(x)))
 proc1(car_proc, x, Mcar(x))
 proc1(cdr_proc, x, Mcdr(x))
 
+uncallable_proc(apply_proc);
 uncallable_proc(callcc_proc);
 uncallable_proc(callwv_proc);
 uncallable_proc(dynwind_proc);
@@ -78,6 +80,8 @@ void init_prims(void) {
 
     void_prim = Mprim(void_proc, -1, "void");
 
+    apply_prim = Mprim(apply_proc, -3, "apply");
+    Mprim_specialp(apply_prim) = 1;
     callcc_prim = Mprim(callcc_proc, 1, "call-with-current-continuation");
     Mprim_specialp(callcc_prim) = 1;
     callwv_prim = Mprim(callwv_proc, 2, "call-with-values");
@@ -121,6 +125,7 @@ obj prim_env(obj env) {
     env_add_prim(env, fx_gt_prim);
     env_add_prim(env, fx_lt_prim);
 
+    env_add_prim(env, apply_prim);
     env_insert(env, Mintern("call/cc"), callcc_prim);
     env_add_prim(env, callcc_prim);
     env_add_prim(env, callwv_prim);

tests/prims.c

@@ -148,6 +148,26 @@ int test_dynamic_wind(void) {
     return passed;
 }
 
+int test_apply(void) {
+    passed = 1;
+
+    check_equal("(apply list '())", "()");
+    check_equal("(apply list 1 '())", "(1)");
+    check_equal("(apply list 1 '(2 3))", "(1 2 3)");
+    check_equal("(apply list 1 2 3 '())", "(1 2 3)");
+    check_equal("(apply list 1 2 3 '(4 5))", "(1 2 3 4 5)");
+
+    check_equal(
+        "(apply call-with-values "
+          "(cons (lambda () 1) "
+          "(cons (lambda (x) (cons x 2)) "
+          "'())))",
+        "(1 . 2)"
+    );
+
+    return passed;
+}
+
 int test_misc(void) {
     passed = 1;
 
@@ -169,6 +189,7 @@ int main(int argc, char **argv) {
     log_test("call-with-values", test_callwv, return_code);
     log_test("call/cc", test_callcc, return_code);
     log_test("dynamic-wind", test_dynamic_wind, return_code);
+    log_test("apply", test_apply, return_code);
     log_test("misc", test_misc, return_code);
 
     minim_shutdown(return_code);