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:
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) {
