commit c9bda1d52762c113481d855f395f3c41170367c3
parent 65ea7a0c671cce8c5b64e1ede5cbd941858f5685
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sat, 5 Mar 2011 19:44:34 -0300
Added eval and simple define. TODO complex define and applicative support.
Diffstat:
3 files changed, 88 insertions(+), 17 deletions(-)
diff --git a/src/klisp.c b/src/klisp.c
@@ -24,6 +24,9 @@
#include "kcontinuation.h"
#include "kenvironment.h"
#include "koperative.h"
+#include "kpair.h"
+#include "ksymbol.h"
+#include "kerror.h"
/* the exit continuation, it exits the loop */
void exit_fn(klisp_State *K, TValue *xparams, TValue obj)
@@ -37,16 +40,43 @@ void exit_fn(klisp_State *K, TValue *xparams, TValue obj)
return;
}
+/* eval helper */
+void combine_cfn(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** tparams[0]: operand list
+ ** tparams[1]: dynamic environment
+ */
+ TValue operands = xparams[0];
+ TValue env = xparams[1];
+
+ switch(ttype(obj)) {
+ case K_TAPPLICATIVE:
+ /* TODO */
+ kapply_cc(K, KINERT);
+ break;
+ case K_TOPERATIVE:
+ ktail_call(K, obj, operands, env);
+ break;
+ default:
+ klispE_throw(K, "Not a combiner in combiner position", true);
+ return;
+ }
+}
+
/* the underlying function of the eval cont */
void eval_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
{
(void) xparams;
switch(ttype(obj)) {
- case K_TPAIR:
- /* TODO */
- kapply_cc(K, obj);
+ case K_TPAIR: {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ &combine_cfn, 2, kcdr(obj), env);
+ kset_cc(K, new_cont);
+ ktail_call(K, K->eval_op, kcar(obj), env);
break;
+ }
case K_TSYMBOL:
/* error handling happens in kget_binding */
kapply_cc(K, kget_binding(K, env, obj));
@@ -60,21 +90,18 @@ void eval_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
void eval_cfn(klisp_State *K, TValue *xparams, TValue obj)
{
/*
- ** tparams[0]: eval operative
- ** tparams[1]: dynamic environment
+ ** xparams[0]: dynamic environment
*/
- TValue eval_op = xparams[0];
- TValue denv = xparams[1];
+ TValue denv = xparams[0];
- ktail_call(K, eval_op, obj, denv);
+ ktail_call(K, K->eval_op, obj, denv);
}
/* the underlying function of the write & loop cont */
void loop_fn(klisp_State *K, TValue *xparams, TValue obj)
{
/*
- ** tparams[0]: eval operative
- ** tparams[1]: dynamic environment
+ ** xparams[0]: dynamic environment
*/
if (ttiseof(obj)) {
/* this will in turn call main_cont */
@@ -82,19 +109,56 @@ void loop_fn(klisp_State *K, TValue *xparams, TValue obj)
} else {
kwrite(K, obj);
knewline(K);
- TValue eval_op = xparams[0];
- TValue denv = xparams[1];
+ TValue denv = xparams[0];
TValue loop_cont = kmake_continuation(
- K, kget_cc(K), KNIL, KNIL, &loop_fn, 2, eval_op, denv);
+ K, kget_cc(K), KNIL, KNIL, &loop_fn, 1, denv);
TValue eval_cont = kmake_continuation(
- K, loop_cont, KNIL, KNIL, &eval_cfn, 2, eval_op, denv);
+ K, loop_cont, KNIL, KNIL, &eval_cfn, 1, denv);
kset_cc(K, eval_cont);
TValue robj = kread(K);
kapply_cc(K, robj);
}
}
+/* define helper */
+void match_cfn(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** tparams[0]: ptree
+ ** tparams[1]: dynamic environment
+ */
+ TValue ptree = xparams[0];
+ TValue env = xparams[1];
+
+ /* TODO: allow general parameter trees */
+ if (!ttisignore(ptree)) {
+ kadd_binding(K, env, ptree, obj);
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* the underlying function of a simple define */
+void def_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
+{
+ if (!ttispair(obj) || !ttispair(kcdr(obj)) || !ttisnil(kcdr(kcdr(obj)))) {
+ klispE_throw(K, "Bad syntax ($define!)", true);
+ return;
+ }
+ TValue ptree = kcar(obj);
+ TValue exp = kcar(kcdr(obj));
+ /* TODO: allow general ptrees */
+ if (!ttissymbol(ptree) && !ttisignore(ptree)) {
+ klispE_throw(K, "Not a symbol or ignore ($define!)", true);
+ return;
+ } else {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ &match_cfn, 2, ptree, env);
+ kset_cc(K, new_cont);
+ ktail_call(K, K->eval_op, exp, env);
+ }
+}
+
int main(int argc, char *argv[])
{
printf("Read/Write Test\n");
@@ -102,15 +166,18 @@ int main(int argc, char *argv[])
klisp_State *K = klispL_newstate();
/* set up the continuations */
- TValue eval_op = kmake_operative(K, KNIL, KNIL, eval_ofn, 0);
+ K->eval_op = kmake_operative(K, KNIL, KNIL, eval_ofn, 0);
TValue ground_env = kmake_empty_environment(K);
+ TValue g_define = kmake_operative(K, KNIL, KNIL, def_ofn, 0);
+ TValue s_define = ksymbol_new(K, "$define!");
+ kadd_binding(K, ground_env, s_define, g_define);
TValue std_env = kmake_environment(K, ground_env);
TValue root_cont = kmake_continuation(K, KNIL, KNIL, KNIL,
exit_fn, 0);
TValue loop_cont = kmake_continuation(
- K, root_cont, KNIL, KNIL, &loop_fn, 2, eval_op, std_env);
+ K, root_cont, KNIL, KNIL, &loop_fn, 1, std_env);
TValue eval_cont = kmake_continuation(
- K, loop_cont, KNIL, KNIL, &eval_cfn, 2, eval_op, std_env);
+ K, loop_cont, KNIL, KNIL, &eval_cfn, 1, std_env);
kset_cc(K, eval_cont);
/* NOTE: this will take effect only in the while (K->next_func) loop */
diff --git a/src/kstate.c b/src/kstate.c
@@ -46,6 +46,8 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->next_env = KNIL;
K->next_xparams = NULL;
+ K->eval_op = KINERT;
+
K->frealloc = f;
K->ud = ud;
diff --git a/src/kstate.h b/src/kstate.h
@@ -50,6 +50,8 @@ struct klisp_State {
TValue next_env; /* either NIL or an environment for next operative */
TValue *next_xparams;
+ TValue eval_op; /* the operative for evaluation */
+
klisp_Alloc frealloc; /* function to reallocate memory */
void *ud; /* auxiliary data to `frealloc' */
