commit 317177e992151c6ba0e5ce27ad86cf019ed1ea2f
parent 3486269dd38eb67af5f92cce4e5c64b2bf3d5d91
Author: Andres Navarro <canavarro82@gmail.com>
Date: Thu, 17 Mar 2011 16:30:59 -0300
Changed name and forgot to update in mercurial
Diffstat:
| A | src/kgkd_vars.c | | | 171 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
1 file changed, 171 insertions(+), 0 deletions(-)
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -0,0 +1,171 @@
+/*
+** kgkd_vars.c
+** Keyed Dynamic 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 "kgcontinuations.h" /* for pass_value / guards */
+#include "kgkd_vars.h"
+
+/*
+** A dynamic key is a pair with a boolean in the car indicating if the
+** variable is bound and an arbitrary object in the cdr representing the
+** currently bound value.
+*/
+
+/* Helpers for make-keyed-dynamic-variable */
+
+/* accesor returned */
+void do_access(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ /*
+ ** xparams[0]: dynamic key
+ */
+ check_0p(K, "keyed-dynamic-get", ptree);
+ UNUSED(denv);
+ TValue key = xparams[0];
+
+ if (kis_true(kcar(key))) {
+ kapply_cc(K, kcdr(key));
+ } else {
+ klispE_throw(K, "keyed-dynamic-get: variable is unbound");
+ return;
+ }
+}
+
+/* continuation to set the key to the old value on normal return */
+void do_unbind(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** xparams[0]: dynamic key
+ ** xparams[1]: old flag
+ ** xparams[2]: old value
+ */
+
+ TValue key = xparams[0];
+ TValue old_flag = xparams[1];
+ TValue old_value = xparams[2];
+
+ kset_car(key, old_flag);
+ kset_cdr(key, old_value);
+ /* pass along the value returned to this continuation */
+ kapply_cc(K, obj);
+}
+
+/* operative for setting the key to the new/old flag/value */
+void do_set_pass(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ /*
+ ** xparams[0]: dynamic key
+ ** xparams[1]: flag
+ ** xparams[2]: value
+ */
+ TValue key = xparams[0];
+ TValue flag = xparams[1];
+ TValue value = xparams[2];
+ UNUSED(denv);
+
+ kset_car(key, flag);
+ kset_cdr(key, value);
+
+ /* pass to next interceptor/ final destination */
+ /* ptree is as for interceptors: (obj divert) */
+ TValue obj = kcar(ptree);
+ kapply_cc(K, obj);
+}
+
+/* create continuation to set the key on both normal return and
+ abnormal passes */
+/* TODO: reuse the code for guards in kgcontinuations.c */
+inline TValue make_bind_continuation(klisp_State *K, TValue key,
+ TValue old_flag, TValue old_value,
+ TValue new_flag, TValue new_value)
+{
+ TValue unbind_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ do_unbind, 3, key, old_flag,
+ old_value);
+ /* create the guards to guarantee that the values remain consistent on
+ abnormal passes (in both directions) */
+ TValue exit_int = kmake_operative(K, KNIL, KNIL, do_set_pass,
+ 3, key, old_flag, old_value);
+ TValue entry_int = kmake_operative(K, KNIL, KNIL, do_set_pass,
+ 3, key, new_flag, new_value);
+ TValue exit_guard = kcons(K, K->root_cont, exit_int);
+ TValue exit_guards = kcons(K, exit_guard, KNIL);
+ TValue entry_guard = kcons(K, K->root_cont, entry_int);
+ TValue entry_guards = kcons(K, entry_guard, KNIL);
+ /* this is needed for interception code */
+ TValue env = kmake_empty_environment(K);
+ TValue outer_cont = kmake_continuation(K, unbind_cont, KNIL, KNIL,
+ pass_value, 2, entry_guards, env);
+ /* mark it as an outer continuation */
+ kset_outer_cont(outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
+ pass_value, 2, exit_guards, env);
+ /* mark it as an outer continuation */
+ kset_inner_cont(inner_cont);
+ return inner_cont;
+}
+
+/* binder returned */
+void do_bind(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ /*
+ ** xparams[0]: dynamic key
+ */
+ bind_2tp(K, "keyed-dynamic-bind", ptree, "any", anytype, obj,
+ "combiner", ttiscombiner, comb);
+ UNUSED(denv); /* the combiner is called in an empty environment */
+ TValue key = xparams[0];
+ /* GC: root intermediate objs */
+ TValue new_flag = KTRUE;
+ TValue new_value = obj;
+ TValue old_flag = kcar(key);
+ TValue old_value = kcdr(key);
+ /* set the var to the new object */
+ kset_car(key, new_flag);
+ kset_cdr(key, new_value);
+ /* create a continuation to set the var to the correct value/flag on both
+ normal return and abnormal passes */
+ TValue new_cont = make_bind_continuation(K, key, old_flag, old_value,
+ new_flag, new_value);
+ kset_cc(K, new_cont);
+ TValue env = kmake_empty_environment(K);
+ TValue expr = kcons(K, comb, KNIL);
+ ktail_eval(K, expr, env)
+}
+
+/* 10.1.1 make-keyed-dynamic-variable */
+void make_keyed_dynamic_variable(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ check_0p(K, "make-keyed-dynamic-variable", ptree);
+ TValue key = kcons(K, KFALSE, KINERT);
+ TValue a = kwrap(K, kmake_operative(K, KNIL, KNIL, do_access, 1, key));
+ TValue b = kwrap(K, kmake_operative(K, KNIL, KNIL, do_bind, 1, key));
+ TValue ls = kcons(K, b, kcons(K, a, KNIL));
+ kapply_cc(K, ls);
+}
+
