klisp

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

commit aadfff628e6096cc7954dbd621d1aa582da7dbb4
parent 95e1af6d08687295f30f0d4c8c04dfeb1e399031
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Sat, 16 Apr 2011 09:42:03 -0300

Environment constructors no longer protect parent list, or key/value pairs. check_list & check_typed_list now accept a NULL pointer to indicate that cpairs is not needed. BUGFIX: rooted objs in kground macros, added add_value macro to add continuations.

Diffstat:
Msrc/kenvironment.c | 30+++++++-----------------------
Msrc/kenvironment.h | 1-
Msrc/kgbooleans.c | 9+++++----
Msrc/kgcombiners.c | 15+++++++++++++--
Msrc/kgcontinuations.c | 6++++++
Msrc/kgenv_mut.h | 1+
Msrc/kgenvironments.c | 2++
Msrc/kghelpers.c | 10++++++++--
Msrc/kgks_vars.c | 2+-
Msrc/kground.c | 35+++++++++++++++++++++++------------
Msrc/krepl.c | 20+++++++++++++++++++-
11 files changed, 85 insertions(+), 46 deletions(-)

diff --git a/src/kenvironment.c b/src/kenvironment.c @@ -23,12 +23,11 @@ #define env_is_keyed(env_) (!ttisnil(env_keyed_node(env_))) /* env_ should be keyed! */ #define env_has_key(env_, k_) (tv_equal(env_keyed_key(env_), (k_))) -/* TEMP: for now allow only a single parent */ + +/* GC: Assumes that parents is rooted */ TValue kmake_environment(klisp_State *K, TValue parents) { - krooted_tvs_push(K, parents); Environment *new_env = klispM_new(K, Environment); - krooted_tvs_pop(K); /* header + gc_fields */ klispC_link(K, (GCObject *) new_env, K_TENVIRONMENT, 0); @@ -106,26 +105,25 @@ TValue kfind_local_binding(klisp_State *K, TValue bindings, TValue sym) #define kenv_parents(kst_, env_) (tv2env(env_)->parents) #define kenv_bindings(kst_, env_) (tv2env(env_)->bindings) +/* Assumes that env, sym & val are rooted. sym & val need not be + right now, but that could change */ void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val) { TValue oldb = kfind_local_binding(K, kenv_bindings(K, env), sym); if (ttisnil(oldb)) { - krooted_tvs_push(K, env); /* keep the env rooted */ TValue new_pair = kcons(K, sym, val); kenv_bindings(K, env) = kcons(K, new_pair, kenv_bindings(K, env)); - krooted_tvs_pop(K); } else { kset_cdr(oldb, val); } } /* This works no matter if parents is a list or a single environment */ +/* GC: assumes env & sym are rooted */ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym, TValue *value) { - krooted_tvs_push(K, env); /* keep the env rooted */ - krooted_tvs_push(K, sym); /* keep the sym rooted */ /* assume the stack may be in use, keep track of pushed objs */ int pushed = 1; ks_spush(K, env); @@ -141,8 +139,6 @@ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym, /* remember to leave the stack as it was */ ks_sdiscardn(K, pushed); *value = kcdr(oldb); - krooted_tvs_pop(K); - krooted_tvs_pop(K); return true; } TValue parents = kenv_parents(K, obj); @@ -155,9 +151,6 @@ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym, } } - krooted_tvs_pop(K); - krooted_tvs_pop(K); - *value = KINERT; return false; } @@ -183,26 +176,21 @@ bool kbinds(klisp_State *K, TValue env, TValue sym) /* keyed dynamic vars */ /* MAYBE: This could be combined with the default constructor */ +/* GC: assumes parent, key & val are rooted */ TValue kmake_keyed_static_env(klisp_State *K, TValue parent, TValue key, TValue val) { - krooted_tvs_push(K, key); /* keep the key/val rooted */ - krooted_tvs_push(K, val); TValue new_env = kmake_environment(K, parent); - krooted_tvs_pop(K); - krooted_tvs_pop(K); krooted_tvs_push(K, new_env); /* keep the env rooted */ env_keyed_node(new_env) = kcons(K, key, val); krooted_tvs_pop(K); return new_env; } +/* GC: assumes parent, key & env are rooted */ inline bool try_get_keyed(klisp_State *K, TValue env, TValue key, TValue *value) { - krooted_tvs_push(K, env); /* keep the env/key rooted */ - krooted_tvs_push(K, key); - /* MAYBE: this could be optimized to mark environments to avoid repetition */ /* assume the stack may be in use, keep track of pushed objs */ @@ -222,8 +210,6 @@ inline bool try_get_keyed(klisp_State *K, TValue env, TValue key, /* remember to leave the stack as it was */ ks_sdiscardn(K, pushed); *value = env_keyed_val(obj); - krooted_tvs_pop(K); - krooted_tvs_pop(K); return true; } else { TValue parents = env_keyed_parents(obj); @@ -236,8 +222,6 @@ inline bool try_get_keyed(klisp_State *K, TValue env, TValue key, pushed += 2; } } - krooted_tvs_pop(K); - krooted_tvs_pop(K); *value = KINERT; return false; } diff --git a/src/kenvironment.h b/src/kenvironment.h @@ -10,7 +10,6 @@ #include "kobject.h" #include "kstate.h" -/* TEMP: for now allow only a single parent */ TValue kmake_environment(klisp_State *K, TValue parents); #define kmake_empty_environment(kst_) (kmake_environment(kst_, KNIL)) void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val); diff --git a/src/kgbooleans.c b/src/kgbooleans.c @@ -42,9 +42,9 @@ void andp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) { UNUSED(xparams); UNUSED(denv); - int32_t dummy; /* don't care about cycle pairs */ + /* don't care about cycle pairs */ int32_t pairs = check_typed_list(K, "and?", "boolean", kbooleanp, - true, ptree, &dummy); + true, ptree, NULL); TValue res = KTRUE; TValue tail = ptree; while(pairs--) { @@ -63,9 +63,9 @@ void orp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) { UNUSED(xparams); UNUSED(denv); - int32_t dummy; /* don't care about cycle pairs */ + /* don't care about cycle pairs */ int32_t pairs = check_typed_list(K, "or?", "boolean", kbooleanp, - true, ptree, &dummy); + true, ptree, NULL); TValue res = KFALSE; TValue tail = ptree; while(pairs--) { @@ -147,6 +147,7 @@ void Sandp_Sorp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) TValue ls = check_copy_list(K, ksymbol_buf(sname), ptree, false); /* This will work even if ls is empty */ + /* GC: ls is protected by make cont */ TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_Sandp_Sorp, 4, sname, term_bool, ls, denv); diff --git a/src/kgcombiners.c b/src/kgcombiners.c @@ -44,10 +44,15 @@ void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) /* The ptree & body are copied to avoid mutation */ vptree = check_copy_ptree(K, "$vau", vptree, vpenv); + + /* GC: root ptree while body is being copied */ + krooted_tvs_push(K, vptree); /* make op will protect it now */ + /* the body should be a list */ - int32_t dummy; - (void)check_list(K, "$vau", true, vbody, &dummy); + UNUSED(check_list(K, "$vau", true, vbody, NULL)); vbody = copy_es_immutable_h(K, "$vau", vbody, false); + + krooted_tvs_pop(K); /* make op will protect it now */ TValue new_op = make_operative(K, do_vau, 4, vptree, vpenv, vbody, denv); kapply_cc(K, new_op); @@ -68,10 +73,16 @@ void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv) /* bindings in an operative are in a child of the static env */ TValue env = kmake_environment(K, senv); + + /* match & add binding may allocate, protect env */ + krooted_tvs_push(K, env); + /* TODO use name from operative */ match(K, "[user-operative]", env, ptree, obj); kadd_binding(K, env, penv, denv); + krooted_tvs_pop(K); /* make cont will protect it now */ + if (ttisnil(body)) { kapply_cc(K, KINERT); } else { diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c @@ -233,11 +233,17 @@ void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree, kapply_cc(K, KINERT); } else { TValue new_env = kmake_environment(K, denv); + + /* add binding may allocate, protect env */ + krooted_tvs_push(K, new_env); kadd_binding(K, new_env, sym, kget_cc(K)); /* the list of instructions is copied to avoid mutation */ /* MAYBE: copy the evaluation structure, ASK John */ TValue ls = check_copy_list(K, "$let/cc", objs, false); + + krooted_tvs_pop(K); /* make cont will protect it now */ + /* this is needed because seq continuation doesn't check for nil sequence */ TValue tail = kcdr(ls); diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h @@ -50,6 +50,7 @@ inline void ptree_clear_all(klisp_State *K, TValue sym_ls) ks_tbclear(K); } +/* GC: assumes env, ptree & obj are rooted */ inline void match(klisp_State *K, char *name, TValue env, TValue ptree, TValue obj) { diff --git a/src/kgenvironments.c b/src/kgenvironments.c @@ -67,7 +67,9 @@ void make_environment(klisp_State *K, TValue *xparams, TValue ptree, /* this is the general case, copy the list but without the cycle if there is any */ TValue parents = check_copy_env_list(K, "make-environment", ptree); + krooted_tvs_push(K, parents); new_env = kmake_environment(K, parents); + krooted_tvs_pop(K); kapply_cc(K, new_env); } } diff --git a/src/kghelpers.c b/src/kghelpers.c @@ -193,7 +193,10 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename, tail = kcdr(tail); ++pairs; } - *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0; + + if (cpairs != NULL) + *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0; + unmark_list(K, obj); if (!ttispair(tail) && !ttisnil(tail)) { @@ -221,7 +224,10 @@ int32_t check_list(klisp_State *K, char *name, bool allow_infp, tail = kcdr(tail); ++pairs; } - *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0; + + if (cpairs != NULL) + *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0; + unmark_list(K, obj); if (!ttispair(tail) && !ttisnil(tail)) { diff --git a/src/kgks_vars.c b/src/kgks_vars.c @@ -50,7 +50,7 @@ void do_sv_bind(klisp_State *K, TValue *xparams, TValue ptree, "environment", ttisenvironment, env); UNUSED(denv); TValue key = xparams[0]; - /* GC: root intermediate objs */ + /* GC: all objs are rooted in ptree, or xparams */ TValue new_env = kmake_keyed_static_env(K, env, key, obj); kapply_cc(K, new_env); } diff --git a/src/kground.c b/src/kground.c @@ -51,17 +51,30 @@ operand/applicative construction */ #define add_operative(K_, env_, n_, fn_, ...) \ { symbol = ksymbol_new(K_, n_); \ - krooted_tvs_push(K, symbol); \ + krooted_tvs_push(K_, symbol); \ value = make_operative(K_, fn_, __VA_ARGS__); \ - krooted_tvs_pop(K); \ - kadd_binding(K_, env_, symbol, value); } + krooted_tvs_push(K_, value); \ + kadd_binding(K_, env_, symbol, value); \ + krooted_tvs_pop(K_); \ + krooted_tvs_pop(K_); } #define add_applicative(K_, env_, n_, fn_, ...) \ { symbol = ksymbol_new(K_, n_); \ - krooted_tvs_push(K, symbol); \ + krooted_tvs_push(K_, symbol); \ value = make_applicative(K_, fn_, __VA_ARGS__); \ - krooted_tvs_pop(K); \ - kadd_binding(K_, env_, symbol, value); } + krooted_tvs_push(K_, value); \ + kadd_binding(K_, env_, symbol, value); \ + krooted_tvs_pop(K_); \ + krooted_tvs_pop(K_); } + +#define add_value(K_, env_, n_, v_) \ + { value = v_; \ + krooted_tvs_push(K_, value); \ + symbol = ksymbol_new(K_, n_); \ + krooted_tvs_push(K_, symbol); \ + kadd_binding(K_, env_, symbol, v_); \ + krooted_tvs_pop(K_); \ + krooted_tvs_pop(K_); } /* ** This is called once to bind all symbols in the ground environment @@ -530,14 +543,12 @@ void kinit_ground_env(klisp_State *K) continuation_applicative, 0); /* 7.2.6 root-continuation */ - symbol = ksymbol_new(K, "root-continuation"); - value = K->root_cont; - kadd_binding(K, ground_env, symbol, value); + add_value(K, ground_env, "root-continuation", + K->root_cont); /* 7.2.7 error-continuation */ - symbol = ksymbol_new(K, "error-continuation"); - value = K->error_cont; - kadd_binding(K, ground_env, symbol, value); + add_value(K, ground_env, "error-continuation", + K->root_cont); /* ** 7.3 Library features diff --git a/src/krepl.c b/src/krepl.c @@ -69,8 +69,11 @@ void eval_cfn(klisp_State *K, TValue *xparams, TValue obj) void loop_fn(klisp_State *K, TValue *xparams, TValue obj); /* this is called from both loop_fn and error_fn */ +/* GC: assumes denv is rooted */ inline void create_loop(klisp_State *K, TValue denv) { + /* GC: the intermediate conts are protected by the + others */ TValue loop_cont = kmake_continuation( K, K->root_cont, KNIL, KNIL, &loop_fn, 1, denv); TValue eval_cont = kmake_continuation( @@ -119,22 +122,37 @@ void kinit_repl(klisp_State *K) { TValue std_env = kmake_environment(K, K->ground_env); + krooted_tvs_push(K, std_env); + /* set up the continuations */ TValue root_cont = kmake_continuation(K, KNIL, KNIL, KNIL, exit_fn, 0); + + krooted_tvs_push(K, root_cont); + TValue error_cont = kmake_continuation(K, root_cont, KNIL, KNIL, error_fn, 1, std_env); + + krooted_tvs_push(K, error_cont); + /* update the ground environment with these two conts */ TValue symbol; symbol = ksymbol_new(K, "root-continuation"); + /* GC: symbol should already be in root */ kadd_binding(K, K->ground_env, symbol, root_cont); - symbol = ksymbol_new(K, "error-continuation"); + symbol = ksymbol_new(K, "error-continuation"); + /* GC: symbol should already be in root */ kadd_binding(K, K->ground_env, symbol, error_cont); /* and save them in the structure */ K->root_cont = root_cont; K->error_cont = error_cont; + krooted_tvs_pop(K); + krooted_tvs_pop(K); + + /* don't yet pop std_env */ create_loop(K, std_env); + krooted_tvs_pop(K); }