commit 43f04b6fed44c6bd24db6337830ced33a2165e91
parent 260533a3faf987c5cddaa543ae9e56c6e7770acd
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 15 Mar 2011 00:43:20 -0300
Added guard-continuation to the ground environment. NOTE: the mechanism to handle the guards isn't there yet, but the guard list are checked and properly copied.
Diffstat:
6 files changed, 125 insertions(+), 7 deletions(-)
diff --git a/src/kapplicative.h b/src/kapplicative.h
@@ -13,5 +13,5 @@
TValue kwrap(klisp_State *K, TValue underlying);
TValue kmake_applicative(klisp_State *K, TValue name, TValue si,
TValue underlying);
-#define kunwrap(K_, app_) (tv2app(app_)->underlying)
+#define kunwrap(app_) (tv2app(app_)->underlying)
#endif
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -102,7 +102,7 @@ void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
(void) denv;
(void) xparams;
bind_1tp(K, "unwrap", ptree, "applicative", ttisapplicative, app);
- TValue underlying = kunwrap(K, app);
+ TValue underlying = kunwrap(app);
kapply_cc(K, underlying);
}
@@ -140,7 +140,7 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree,
TValue env = (get_opt_tpar(K, "apply", K_TENVIRONMENT, &maybe_env))?
maybe_env : kmake_empty_environment(K);
- TValue expr = kcons(K, kunwrap(K, app), obj);
+ TValue expr = kcons(K, kunwrap(app), obj);
ktail_eval(K, expr, env);
}
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -46,7 +46,7 @@ void do_extended_cont(klisp_State *K, TValue *xparams, TValue obj)
** xparams[1]: environment
*/
TValue app = xparams[0];
- TValue underlying = kunwrap(K, app);
+ TValue underlying = kunwrap(app);
TValue env = xparams[1];
TValue expr = kcons(K, underlying, obj);
@@ -73,8 +73,111 @@ void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, new_cont);
}
+/* Helpers for guard-continuation (& guard-dynamic-extent) */
+
+/* this is used for inner & outer continuations, it just
+ passes the value. xparams is not actually empty, it contains
+ the entry/exit guards, but they are used only in
+ continuation->applicative (that is during abnormal passes) */
+void pass_value(klisp_State *K, TValue *xparams, TValue obj)
+{
+ UNUSED(xparams);
+ kapply_cc(K, obj);
+}
+
+#define singly_wrapped(obj_) (ttisapplicative(obj_) && \
+ ttisoperative(kunwrap(obj_)))
+
+/* this unmarks root before throwing any error */
+/* TODO: this isn't very clean, refactor */
+inline TValue check_copy_single_entry(klisp_State *K, char *name,
+ TValue obj, TValue root)
+{
+ if (!ttispair(obj) || !ttispair(kcdr(obj)) ||
+ !ttisnil(kcddr(obj))) {
+ unmark_list(K, root);
+ klispE_throw_extra(K, name , ": Bad entry (expected "
+ "list of length 2)");
+ return KINERT;
+ }
+ TValue cont = kcar(obj);
+ TValue app = kcadr(obj);
+
+ if (!ttiscontinuation(cont)) {
+ unmark_list(K, root);
+ klispE_throw_extra(K, name, ": Bad type on first element (expected "
+ "continuation)");
+ return KINERT;
+ } else if (!singly_wrapped(app)) {
+ unmark_list(K, root);
+ klispE_throw_extra(K, name, ": Bad type on second element (expected "
+ "singly wrapped applicative)");
+ return KINERT;
+ }
+
+ /* GC: save intermediate pair */
+ return kcons(K, cont, kcons(K, app, KNIL));
+}
+
+/* the guards are probably generated on the spot so we don't check
+ for immutability and copy it anyways */
+TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
+{
+ if (ttisnil(obj)) {
+ return obj;
+ } else {
+ TValue dummy = kcons(K, KINERT, KNIL);
+ TValue last_pair = dummy;
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ /* this will clear the marks and throw an error if the structure
+ is incorrect */
+ TValue entry = check_copy_single_entry(K, name, kcar(tail), obj);
+ TValue new_pair = kcons(K, entry, KNIL);
+ kmark(tail);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ }
+
+ /* dont close the cycle (if there is one) */
+ unmark_list(K, obj);
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_extra(K, name , ": expected list");
+ return KINERT;
+ }
+ return kcdr(dummy);
+ }
+}
+
/* 7.2.4 guard-continuation */
-/* TODO */
+void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_3tp(K, "guard-continuation", ptree, "any", anytype, entry_guards,
+ "continuation", ttiscontinuation, cont,
+ "any", anytype, exit_guards);
+
+ entry_guards = check_copy_guards(K, "guard-continuation: entry guards",
+ entry_guards);
+ exit_guards = check_copy_guards(K, "guard-continuation: exit guards",
+ exit_guards);
+
+ TValue outer_cont = kmake_continuation(K, cont, KNIL, KNIL, pass_value,
+ 1, entry_guards);
+ /* mark it as an outer continuation */
+ kset_outer_cont(outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
+ pass_value, 1, exit_guards);
+ /* mark it as an outer continuation */
+ kset_inner_cont(inner_cont);
+ kapply_cc(K, inner_cont);
+}
/* helper for continuation->applicative */
diff --git a/src/kgcontinuations.h b/src/kgcontinuations.h
@@ -29,7 +29,8 @@ void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv);
/* 7.2.4 guard-continuation */
-/* TODO */
+void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
/* 7.2.5 continuation->applicative */
void continuation_applicative(klisp_State *K, TValue *xparams, TValue ptree,
diff --git a/src/kground.c b/src/kground.c
@@ -359,7 +359,8 @@ void kinit_ground_env(klisp_State *K)
add_applicative(K, ground_env, "extend-continuation", extend_continuation, 0);
/* 7.2.4 guard-continuation */
- /* TODO */
+ add_applicative(K, ground_env, "guard-continuation", guard_continuation,
+ 0);
/* 7.2.5 continuation->applicative */
add_applicative(K, ground_env, "continuation->applicative",
diff --git a/src/kobject.h b/src/kobject.h
@@ -419,6 +419,19 @@ extern char *ktv_names[];
#define gch_get_flags(o_) (obj2gch(o_)->flags)
#define tv_get_flags(o_) (gch_get_flags(tv2gch(o_)))
+/* Flags for marking continuations */
+#define K_FLAG_OUTER 0x01
+#define K_FLAG_INNER 0x02
+#define K_FLAG_DYNAMIC 0x04
+
+#define kset_inner_cont(c_) (tv_get_flags(c_) |= K_FLAG_INNER)
+#define kset_outer_cont(c_) (tv_get_flags(c_) |= K_FLAG_OUTER)
+#define kset_dyn_cont(c_) (tv_get_flags(c_) |= K_FLAG_DYNAMIC)
+
+#define kis_inner_cont(c_) ((tv_get_flags(c_) & K_FLAG_INNER) != 0)
+#define kis_outer_cont(c_) ((tv_get_flags(c_) & K_FLAG_OUTER) != 0)
+#define kis_dyn_cont(c_) ((tv_get_flags(c_) & K_FLAG_DYNAMIC) != 0)
+
#define K_FLAG_IMMUTABLE 0x01
#define kis_mutable(o_) ((tv_get_flags(o_) & K_FLAG_IMMUTABLE) == 0)
#define kis_immutable(o_) (!kis_mutable(o_))
