diff --git a/src/eval.c b/src/eval.c index 6f2164f..8f94115 100644 --- a/src/eval.c +++ b/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); } diff --git a/src/minim.h b/src/minim.h index 63985db..b8511d1 100644 --- a/src/minim.h +++ b/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; diff --git a/src/prim.c b/src/prim.c index 160b610..03d041a 100644 --- a/src/prim.c +++ b/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); diff --git a/tests/prims.c b/tests/prims.c index 1a35e2a..c30030f 100644 --- a/tests/prims.c +++ b/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);