commit 5fe809189aa10c4d6465e5d00242576373bb0932
parent 9fe5556052bd332596b3a3d5bcb9c05ef5050620
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 1 Mar 2011 23:04:54 -0300
Added some basic support for first class environments.
Diffstat:
4 files changed, 109 insertions(+), 5 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -8,7 +8,7 @@ MYLDFLAGS=
MYLIBS=
CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
- kwrite.o kstate.o kmem.o kerror.o kauxlib.o
+ kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o
KRN_T= klisp
KRN_O= klisp.o
@@ -46,4 +46,6 @@ kwrite.o: kwrite.c kwrite.h kobject.h kpair.h kstring.h kstate.h kerror.h
kstate.o: kstate.c kstate.h klisp.h kobject.h kmem.h kstring.h
kmem.o: kmem.c kmem.h klisp.h kerror.h
kerror.o: kerror.c kerror.h klisp.h kstate.h
-kauxlib.o: kauxlib.c kauxlib.h klisp.h kstate.h
-\ No newline at end of file
+kauxlib.o: kauxlib.c kauxlib.h klisp.h kstate.h
+kenvironment.o: kenvironment.c kenvironment.h kpair.h kobject.h kerror.h \
+ kmem.h kstate.h
+\ No newline at end of file
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -0,0 +1,82 @@
+/*
+** kenvironmment.c
+** Kernel Environments
+** See Copyright Notice in klisp.h
+*/
+
+#include <string.h>
+
+#include "kenvironment.h"
+#include "kpair.h"
+#include "ksymbol.h"
+#include "kobject.h"
+#include "kerror.h"
+#include "kstate.h"
+#include "kmem.h"
+
+/* TEMP: for now allow only a single parent */
+TValue kmake_environment(klisp_State *K, TValue parent)
+{
+ Environment *new_env = klispM_new(K, Environment);
+
+ new_env->next = NULL;
+ new_env->gct = 0;
+ new_env->tt = K_TENVIRONMENT;
+ new_env->mark = KFALSE;
+ new_env->parents = parent;
+ /* TEMP: for now the bindings are an alist */
+ new_env->bindings = KNIL;
+
+ return gc2env(new_env);
+}
+
+/*
+** Helper function for kadd_binding and kget_binding,
+** returns KNIL or a pair with sym as car.
+*/
+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);
+ if (tv_equal(sym, first_sym))
+ return first;
+ bindings = kcdr(bindings);
+ }
+ return KNIL;
+}
+
+/*
+** Some helper macros
+*/
+#define kenv_parents(kst_, env_) (tv2env(env_)->parents)
+#define kenv_bindings(kst_, env_) (tv2env(env_)->bindings)
+
+void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
+{
+ TValue oldb = kfind_local_binding(K, kenv_parents(K, env), sym);
+
+ if (ttisnil(oldb)) {
+ /* XXX: unrooted pair */
+ TValue new_pair = kcons(K, sym, val);
+ kenv_bindings(K, env) = kcons(K, new_pair, kenv_bindings(K, env));
+ } else {
+ kset_cdr(oldb, val);
+ }
+}
+
+TValue kget_binding(klisp_State *K, TValue env, TValue sym)
+{
+ while(!ttisnil(env)) {
+ TValue oldb = kfind_local_binding(K, kenv_parents(K, env), sym);
+ if (!ttisnil(oldb))
+ return kcdr(oldb);
+ env = kenv_parents(K, env);
+ }
+ klispE_throw(K, strcat("Unbound symbol: ", ksymbol_buf(sym)), true);
+ /* avoid warning */
+ return KINERT;
+}
diff --git a/src/kenvironment.h b/src/kenvironment.h
@@ -0,0 +1,18 @@
+/*
+** kenvironment.h
+** Kernel Environments
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kenvironment_h
+#define kenvironment_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+/* TEMP: for now allow only a single parent */
+TValue kmake_environment(klisp_State *K, TValue parent);
+void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val);
+TValue kget_binding(klisp_State *K, TValue env, TValue sym);
+
+#endif
diff --git a/src/kobject.h b/src/kobject.h
@@ -232,8 +232,8 @@ typedef struct __attribute__ ((__packed__)) {
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
TValue mark; /* for cycle/sharing aware algorithms */
- TValue ancestors; /* may be (), a list, or a single env */
- TValue alist; /* TEMP: for now alist of (binding . value) */
+ TValue parents; /* may be (), a list, or a single env */
+ TValue bindings; /* TEMP: for now alist of (binding . value) */
} Environment;
/*
@@ -360,11 +360,13 @@ const TValue keminf;
#define gc2pair(o_) (gc2tv(K_TAG_PAIR, o_))
#define gc2str(o_) (gc2tv(K_TAG_STRING, o_))
#define gc2sym(o_) (gc2tv(K_TAG_SYMBOL, o_))
+#define gc2env(o_) (gc2tv(K_TAG_ENVIRONMENT, o_))
/* Macro to convert a TValue into a specific heap allocated object */
#define tv2pair(v_) ((Pair *) gcvalue(v_))
#define tv2str(v_) ((String *) gcvalue(v_))
#define tv2sym(v_) ((Symbol *) gcvalue(v_))
+#define tv2env(v_) ((Environment *) gcvalue(v_))
#define tv2mgch(v_) ((MGCheader *) gcvalue(v_))
