klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
Msrc/klisp.c | 101+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------------
Msrc/kstate.c | 2++
Msrc/kstate.h | 2++
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' */