klisp

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

commit 11ae670fa7ce048c49d9dd1ed1a71689b665b2d5
parent 6750277b5ae2368e58286b0374c4cd28b7bfa8a2
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Fri, 11 Mar 2011 07:10:18 -0300

Added multiple environment parents. Bugfix in check_list.

Diffstat:
Msrc/kenvironment.c | 57++++++++++++++++++++++++++++++++++++++++++++++-----------
Msrc/kenvironment.h | 1+
Msrc/kground.c | 56+++++++++++++++++++++++++++++++++++++++++++++-----------
Msrc/kstate.h | 19+++++++++++++++++++
4 files changed, 111 insertions(+), 22 deletions(-)

diff --git a/src/kenvironment.c b/src/kenvironment.c @@ -19,7 +19,6 @@ TValue kmake_environment(klisp_State *K, TValue parent) { Environment *new_env = klispM_new(K, Environment); - /* header + gc_fields */ new_env->next = K->root_gc; K->root_gc = (GCObject *) new_env; @@ -42,9 +41,7 @@ TValue kmake_environment(klisp_State *K, TValue parent) */ TValue kfind_local_binding(klisp_State *K, TValue bindings, TValue sym) { - /* avoid warnings */ (void) K; - while(!ttisnil(bindings)) { TValue first = kcar(bindings); TValue first_sym = kcar(first); @@ -74,16 +71,54 @@ void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val) } } +/* This works no matter if parents is a list or a single environment */ +inline bool try_get_binding(klisp_State *K, TValue env, TValue sym, + TValue *value) +{ + /* assume the stack may be in use, keep track of pushed objs */ + int pushed = 1; + ks_spush(K, env); + + while(pushed) { + TValue obj = ks_spop(K); + --pushed; + if (ttisnil(obj)) { + continue; + } else if (ttisenvironment(obj)) { + TValue oldb = kfind_local_binding(K, kenv_bindings(K, obj), sym); + if (!ttisnil(oldb)) { + /* remember to leave the stack as it was */ + ks_sdiscardn(K, pushed); + *value = kcdr(oldb); + return true; + } + TValue parents = kenv_parents(K, obj); + ks_spush(K, parents); + ++pushed; + } else { /* parent list */ + ks_spush(K, kcdr(obj)); + ks_spush(K, kcar(obj)); + pushed += 2; + } + } + *value = KINERT; + return false; +} + TValue kget_binding(klisp_State *K, TValue env, TValue sym) { - while(!ttisnil(env)) { - TValue oldb = kfind_local_binding(K, kenv_bindings(K, env), sym); - if (!ttisnil(oldb)) - return kcdr(oldb); - env = kenv_parents(K, env); + TValue value; + if (try_get_binding(K, env, sym, &value)) { + return value; + } else { + klispE_throw_extra(K, "Unbound symbol: ", ksymbol_buf(sym)); + /* avoid warning */ + return KINERT; } +} - klispE_throw_extra(K, "Unbound symbol: ", ksymbol_buf(sym)); - /* avoid warning */ - return KINERT; +bool kbinds(klisp_State *K, TValue env, TValue sym) +{ + TValue value; + return try_get_binding(K, env, sym, &value); } diff --git a/src/kenvironment.h b/src/kenvironment.h @@ -15,5 +15,6 @@ TValue kmake_environment(klisp_State *K, TValue parent); #define kmake_empty_environment(kst_) (kmake_environment(kst_, KNIL)) void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val); TValue kget_binding(klisp_State *K, TValue env, TValue sym); +bool kbinds(klisp_State *K, TValue env, TValue sym); #endif diff --git a/src/kground.c b/src/kground.c @@ -182,21 +182,21 @@ inline TValue check_copy_list(klisp_State *K, char *name, TValue obj) return obj; } else { TValue dummy = kcons(K, KINERT, KNIL); - TValue last = dummy; + TValue last_pair = dummy; TValue tail = obj; while(ttispair(tail) && !kis_marked(tail)) { - TValue new_pair = kcons(K, kcar(obj), KNIL); + TValue new_pair = kcons(K, kcar(tail), KNIL); /* record the corresponding pair to simplify cycle handling */ kset_mark(tail, new_pair); - kset_cdr(last, new_pair); - last = new_pair; - obj = kcdr(obj); + kset_cdr(last_pair, new_pair); + last_pair = new_pair; + tail = kcdr(tail); } if (ttispair(tail)) { /* complete the cycle */ - kset_cdr(last, kget_mark(tail)); + kset_cdr(last_pair, kget_mark(tail)); } unmark_list(K, obj); @@ -209,6 +209,37 @@ inline TValue check_copy_list(klisp_State *K, char *name, TValue obj) } } +/* check that obj is a list of environments and make a copy but don't keep + the cycles */ +inline TValue check_copy_env_list(klisp_State *K, char *name, TValue obj) +{ + TValue dummy = kcons(K, KINERT, KNIL); + TValue last_pair = dummy; + TValue tail = obj; + + while(ttispair(tail) && !kis_marked(tail)) { + TValue first = kcar(tail); + if (!ttisenvironment(first)) { + klispE_throw_extra(K, name, ": not an environment in parent list"); + return KINERT; + } + TValue new_pair = kcons(K, first, KNIL); + kmark(tail); + kset_cdr(last_pair, new_pair); + last_pair = new_pair; + tail = kcdr(tail); + } + + /* even if there was a cycle, the copy ends with nil */ + unmark_list(K, obj); + + if (!ttispair(tail) && !ttisnil(tail)) { + klispE_throw_extra(K, name , ": expected list"); + return KINERT; + } + return kcdr(dummy); +} + /* ** This is a generic function for type predicates ** It can only be used by types that have a unique tag @@ -697,19 +728,22 @@ void make_environment(klisp_State *K, TValue *xparams, TValue ptree, new_env = kmake_empty_environment(K); kapply_cc(K, new_env); } else if (ttispair(ptree) && ttisnil(kcdr(ptree))) { + /* special common case of one parent, don't keep a list */ TValue parent = kcar(ptree); if (ttisenvironment(parent)) { new_env = kmake_environment(K, parent); kapply_cc(K, new_env); } else { - klispE_throw(K, "make-environment: Bad type on first " - "argument (expected environment)"); + klispE_throw(K, "make-environment: not an environment in " + "parent list"); return; } } else { - klispE_throw(K, "make-environment: Bad ptree (expected " - "zero or one argument"); - return; + /* 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); + new_env = kmake_environment(K, parents); + kapply_cc(K, new_env); } } diff --git a/src/kstate.h b/src/kstate.h @@ -119,6 +119,7 @@ inline void ks_spush(klisp_State *K, TValue obj); inline TValue ks_spop(klisp_State *K); /* this is for DISCARDING stack pop (value isn't used, avoid warning) */ #define ks_sdpop(st_) (UNUSED(ks_spop(st_))) +inline void ks_sdiscardn(klisp_State *K, int32_t n); inline TValue ks_sget(klisp_State *K); inline void ks_sclear(klisp_State *K); inline bool ks_sisempty(klisp_State *K); @@ -163,6 +164,24 @@ inline TValue ks_sget(klisp_State *K) return ks_selem(K, ks_stop(K) - 1); } +inline void ks_sdiscardn(klisp_State *K, int32_t n) +{ + int32_t new_top = ks_stop(K) - n; + ks_stop(K) = new_top; + if (ks_ssize(K) != KS_ISSIZE && new_top < (ks_ssize(K) / 4)) { + /* NOTE: may shrink more than once, take it to a multiple of + KS_ISSIZE that is no smaller than (new_top * 2) */ + size_t old_size = ks_ssize(K); + size_t new_size = new_top * 2; + new_size = new_top + KS_ISSIZE - (new_top % KS_ISSIZE); + /* NOTE: shrink can't fail */ + ks_sbuf(K) = klispM_realloc_(K, ks_sbuf(K), old_size*sizeof(TValue), + new_size*sizeof(TValue)); + ks_ssize(K) = new_size; + } + return; +} + inline void ks_sclear(klisp_State *K) { if (ks_ssize(K) != KS_ISSIZE) {