klisp

commit c8dd66263abdb1fdbc3d477ddad15eb212abbc21
parent 1407b2adf81afc9a066f41da46a8ec330d6ce42f
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Wed, 16 Mar 2011 03:34:05 -0300

Added force and $lazy to the ground environment. Promises & Encapsulations completed.

Diffstat:
M
src/kgpromises.c
 | 
69
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
M
src/kgpromises.h
 | 
4
++--
M
src/kground.c
 | 
4
++--
M
src/kpromise.h
 | 
8
++------

4 files changed, 73 insertions(+), 12 deletions(-)
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -21,14 +21,79 @@
 #include "kghelpers.h"
 #include "kgpromises.h"
 
+/* SOURCE_NOTE: this is mostly an adaptation of the library derivation
+   in the report */
+
 /* 9.1.1 promise? */
 /* uses typep */
 
+/* Helper for force */
+void handle_result(klisp_State *K, TValue *xparams, TValue obj)
+{
+    /*
+    ** xparams[0]: promise
+    */
+    TValue prom = xparams[0];
+
+    /* check to see if promise was determined before the eval completed */
+    if (ttisnil(kpromise_maybe_env(prom))) {
+	/* discard obj, return previous result */
+	kapply_cc(K, kpromise_exp(prom));
+    } else if (ttispromise(obj)) {
+	/* force iteratively, by sharing pairs so that when obj
+	 determines a value, prom also does */
+	TValue node = kpromise_node(obj);
+	kpromise_node(prom) = node;
+	TValue expr = kpromise_exp(prom);
+	TValue maybe_env = kpromise_maybe_env(prom);
+	if (ttisnil(maybe_env)) {
+	    /* promise was already determined */
+	    kapply_cc(K, expr);
+	} else {
+	    TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+						 handle_result, 1, prom);
+	    kset_cc(K, new_cont);
+	    ktail_eval(K, expr, maybe_env);
+	}
+    } else {
+	/* memoize result */
+	TValue node = kpromise_node(prom);
+	kset_car(node, obj);
+	kset_cdr(node, KNIL);
+    }
+}
+
 /* 9.1.2 force */
-/* TODO */
+void force(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    UNUSED(xparams);
+    UNUSED(denv);
+    bind_1p(K, "force", ptree, obj);
+    if (!ttispromise(obj)) {
+	/* non promises force to themselves */
+	kapply_cc(K, obj);
+    } else if (ttisnil(kpromise_maybe_env(obj))) {
+	/* promise was already determined */
+	kapply_cc(K, kpromise_exp(obj));
+    } else {
+	TValue expr = kpromise_exp(obj);
+	TValue env = kpromise_maybe_env(obj);
+	TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+					     handle_result, 1, obj);
+	kset_cc(K, new_cont);
+	ktail_eval(K, expr, env);
+    }
+}
 
 /* 9.1.3 $lazy */
-/* TODO */
+void Slazy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    UNUSED(xparams);
+
+    bind_1p(K, "$lazy", ptree, exp);
+    TValue new_prom = kmake_promise(K, KNIL, KNIL, exp, denv);
+    kapply_cc(K, new_prom);
+}
 
 /* 9.1.4 memoize */
 void memoize(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
diff --git a/src/kgpromises.h b/src/kgpromises.h
@@ -22,10 +22,10 @@
 /* uses typep */
 
 /* 9.1.2 force */
-/* TODO */
+void force(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* 9.1.3 $lazy */
-/* TODO */
+void Slazy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* 9.1.4 memoize */
 void memoize(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
diff --git a/src/kground.c b/src/kground.c
@@ -431,10 +431,10 @@ void kinit_ground_env(klisp_State *K)
 		    i2tv(K_TPROMISE));
 
     /* 9.1.2 force */
-    /* TODO */
+    add_applicative(K, ground_env, "force", force, 0); 
 
     /* 9.1.3 $lazy */
-    /* TODO */
+    add_operative(K, ground_env, "$lazy", Slazy, 0); 
 
     /* 9.1.4 memoize */
     add_applicative(K, ground_env, "memoize", memoize, 0); 
diff --git a/src/kpromise.h b/src/kpromise.h
@@ -15,11 +15,7 @@ TValue kmake_promise(klisp_State *K, TValue name, TValue si,
 		     TValue exp, TValue maybe_env);
 
 #define kpromise_node(p_) (tv2prom(p_)->node)
-inline void kdetermine_promise(TValue p, TValue obj)
-{
-    TValue node = kpromise_node(p);
-    kset_car(node, obj);
-    kset_cdr(node, KNIL);
-}
+#define kpromise_exp(p_) (kcar(kpromise_node(p_)))
+#define kpromise_maybe_env(p_) (kcdr(kpromise_node(p_)))
 
 #endif