klisp

commit 991c894888284602f94bdad21f4e1806366cd486
parent 3ebb7ff8ed61e32b696f73b56164c5f48724526c
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Wed, 16 Mar 2011 17:48:18 -0300

Added make-keyed-static-variable to the ground environment.

Diffstat:
M
src/Makefile
 | 
8
++++++--
M
src/kenvironment.c
 | 
4
+++-
A
src/kgks_vars.c
 | 
72
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A
src/kgks_vars.h
 | 
25
+++++++++++++++++++++++++
M
src/kground.c
 | 
16
++++++++++++++++

5 files changed, 122 insertions(+), 3 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -14,7 +14,7 @@ CORE_O=	kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
 	kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
 	kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
 	kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
-	kgpromises.o kgkd_vars.o
+	kgpromises.o kgkd_vars.o kgks_vars.o
 
 KRN_T=	klisp
 KRN_O=	klisp.o
@@ -77,7 +77,8 @@ kground.o: kground.c kground.h kstate.h kobject.h klisp.h kenvironment.h \
 	kapplicative.h koperative.h ksymbol.h kerror.h kghelpers.h \
 	kgbooleans.h kgeqp.h kgequalp.h kgsymbols.h kgpairs_lists.h \
 	kgpair_mut.h kgenvironments.h kgenv_mut.h kgcombiners.h \
-	kgcontinuations.h kgencapsulations.h kgpromises.h kgkd_vars.h
+	kgcontinuations.h kgencapsulations.h kgpromises.h kgkd_vars.h \
+	kgks_vars.h
 kghelpers.o: kghelpers.c kghelpers.h kstate.h kstate.h klisp.h kpair.h \
 	kapplicative.h koperative.h kerror.h kobject.h ksymbol.h
 kgbooleans.o: kgbooleans.c kgbooleans.c kghelpers.h kstate.h klisp.h \
@@ -115,3 +116,6 @@ kgpromises.o: kgpromises.c kgpromises.h kghelpers.h kstate.h klisp.h \
 kgkd_vars.o: kgkd_vars.c kgkd_vars.h kghelpers.h kstate.h klisp.h \
 	kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h \
 	kpair.h kenvironment.h kgcontinuations.h
+kgks_vars.o: kgks_vars.c kgks_vars.h kghelpers.h kstate.h klisp.h \
+	kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h \
+	kpair.h kenvironment.h
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -187,6 +187,8 @@ inline bool try_get_keyed(klisp_State *K, TValue env, TValue key,
      repetition */
     /* assume the stack may be in use, keep track of pushed objs */
     int pushed = 1;
+    if (!env_is_keyed(env))
+	env = env_keyed_parents(env);
     ks_spush(K, env);
 
     while(pushed) {
@@ -202,7 +204,7 @@ inline bool try_get_keyed(klisp_State *K, TValue env, TValue key,
 		*value = env_keyed_val(obj);
 		return true;
 	    } else {
-		TValue parents = kenv_parents(K, obj);
+		TValue parents = env_keyed_parents(obj);
 		ks_spush(K, parents);
 		++pushed;
 	    }
diff --git a/src/kgks_vars.c b/src/kgks_vars.c
@@ -0,0 +1,72 @@
+/*
+** kgks_vars.c
+** Keyed Static Variables features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kpair.h"
+#include "kcontinuation.h"
+#include "koperative.h"
+#include "kapplicative.h"
+#include "kenvironment.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgks_vars.h"
+
+/* Helpers for make-static-dynamic-variable */
+
+/* accesor returned */
+void do_sv_access(klisp_State *K, TValue *xparams, TValue ptree, 
+	       TValue denv)
+{
+    /*
+    ** xparams[0]: static key 
+    */
+    check_0p(K, "keyed-static-get", ptree);
+
+    TValue key = xparams[0];
+    /* this may throw an exception if not bound */
+    TValue val = kget_keyed_static_var(K, denv, key);
+    kapply_cc(K, val);
+}
+
+/* binder returned */
+void do_sv_bind(klisp_State *K, TValue *xparams, TValue ptree, 
+		TValue denv)
+{
+    /*
+    ** xparams[0]: static key 
+    */
+    bind_2tp(K, "keyed-static-bind", ptree, "any", anytype, obj,
+	      "environment", ttisenvironment, env);
+    UNUSED(denv); 
+    TValue key = xparams[0];
+    /* GC: root intermediate objs */
+    TValue new_env = kmake_keyed_static_env(K, env, key, obj);
+    kapply_cc(K, new_env);
+}
+
+/* 11.1.1 make-static-dynamic-variable */
+void make_keyed_static_variable(klisp_State *K, TValue *xparams, 
+				 TValue ptree, TValue denv)
+{
+    UNUSED(denv); 
+    UNUSED(xparams);
+
+    check_0p(K, "make-keyed-static-variable", ptree);
+    /* the key is just a dummy pair */
+    TValue key = kcons(K, KINERT, KINERT);
+    TValue a = kwrap(K, kmake_operative(K, KNIL, KNIL, do_sv_access, 1, key));
+    TValue b = kwrap(K, kmake_operative(K, KNIL, KNIL, do_sv_bind, 1, key));
+    TValue ls = kcons(K, b, kcons(K, a, KNIL));
+    kapply_cc(K, ls);
+}
diff --git a/src/kgks_vars.h b/src/kgks_vars.h
@@ -0,0 +1,25 @@
+/*
+** kgks_vars.h
+** Keyed Static Variables features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgks_vars_h
+#define kgks_vars_h
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kobject.h"
+#include "klisp.h"
+#include "kstate.h"
+#include "kghelpers.h"
+
+/* 11.1.1 make-static-dynamic-variable */
+void make_keyed_static_variable(klisp_State *K, TValue *xparams, 
+				 TValue ptree, TValue denv);
+
+#endif
diff --git a/src/kground.c b/src/kground.c
@@ -34,6 +34,7 @@
 #include "kgencapsulations.h"
 #include "kgpromises.h"
 #include "kgkd_vars.h"
+#include "kgks_vars.h"
 
 /*
 ** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
@@ -451,6 +452,21 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, "make-keyed-dynamic-variable", 
 		    make_keyed_dynamic_variable, 0); 
 
+
+    /*
+    **
+    ** 11 Keyed Static Variables
+    **
+    */
+
+    /* 
+    ** 11.1 Primitive features
+    */
+
+    /* 11.1.1 make-keyed-static-variable */
+    add_applicative(K, ground_env, "make-keyed-static-variable", 
+		    make_keyed_static_variable, 0); 
+
     return;
 
 }