klisp

commit c3edd369019e98751bcca757950a239df5d4c952
parent 6d3dcc9934cd9833218028900b0fae5b2d4b4362
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Sat,  5 Mar 2011 15:49:01 -0300

Made the read-print loop to continuation based. Some bugfixes in helpers for operative and continuation calling.

Diffstat:
M
src/Makefile
 | 
2
+-
M
src/klisp.c
 | 
73
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
M
src/kstate.h
 | 
7
+++----

3 files changed, 76 insertions(+), 6 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -34,7 +34,7 @@ clean:
 .PHONY: all default o clean
 
 klisp.o: klisp.c klisp.h kobject.h kread.h kwrite.h klimits.h kstate.h kmem.h \
-	kerror.h kauxlib.h
+	kerror.h kauxlib.h koperative.h kenvironment.h kcontinuation.h
 kobject.o: kobject.c kobject.h
 ktoken.o: ktoken.c ktoken.h kobject.h kstate.h kpair.h kstring.h ksymbol.h \
 	kerror.h
diff --git a/src/klisp.c b/src/klisp.c
@@ -21,6 +21,10 @@
 #include "kread.h"
 #include "kwrite.h"
 
+#include "kcontinuation.h"
+#include "kenvironment.h"
+#include "koperative.h"
+
 /*
 ** Simple read/write loop
 */
@@ -35,11 +39,65 @@ void main_body(klisp_State *K)
     }
 }
 
+/* the exit continuation, it exits the loop */
+void exit_fn(klisp_State *K, TValue *xparams, TValue obj)
+{
+    /* avoid warnings */
+    (void) xparams;
+    (void) obj;
+
+    /* force the loop to terminate */
+    K->next_func = NULL;
+    return;
+}
+
+/* the underlying function of the read operative */
+void read_fn(klisp_State *K, TValue *xparams, TValue ptree, TValue env)
+{
+    (void) ptree;
+    (void) env;
+    (void) xparams;
+    TValue obj = kread(K);
+    kapply_cc(K, obj);
+}
+
+/* the underlying function of the loop */
+void loop_fn(klisp_State *K, TValue *xparams, TValue obj)
+{
+    /* tparams[0] is the read operative,
+     in tparams[1] a dummy environment */
+    if (ttiseof(obj)) {
+	/* this will in turn call main_cont */
+	kapply_cc(K, obj);
+    } else {
+	kwrite(K, obj);
+	knewline(K);
+	TValue read_op = *xparams;
+	TValue dummy_env = *xparams;
+	TValue new_cont = kmake_continuation(
+	    K, kget_cc(K), KNIL, KNIL, &loop_fn, 2, read_op, dummy_env);
+	kset_cc(K, new_cont);
+	ktail_call(K, read_op, KNIL, dummy_env);
+    }
+} 
+
 int main(int argc, char *argv[]) 
 {
     printf("Read/Write Test\n");
 
     klisp_State *K = klispL_newstate();
+
+    /* set up the continuations */
+    TValue read_op = kmake_operative(K, KNIL, KNIL, read_fn, 0);
+    TValue dummy_env = kmake_empty_environment(K);
+    TValue root_cont = kmake_continuation(K, KNIL, KNIL, KNIL,
+					  exit_fn, 0);
+    TValue loop_cont = kmake_continuation(K, root_cont, KNIL, KNIL,
+					  loop_fn, 2, read_op, dummy_env);
+    kset_cc(K, loop_cont);
+    /* NOTE: this will take effect only in the while (K->next_func) loop */
+    klispS_tail_call(K, read_op, KNIL, dummy_env);
+
     int ret_value = 0;
     bool done = false;
 
@@ -53,11 +111,24 @@ int main(int argc, char *argv[])
 		ks_tbclear(K);
 		K->shared_dict = KNIL;
 	    } else {
+		printf("Aborting...\n");
 		ret_value = 1;
 		done = true;
 	    }
 	} else {
-	    main_body(K);
+	    /* all ok, continue with next func */
+	    while (K->next_func) {
+		if (ttisnil(K->next_env)) {
+		    /* continuation application */
+		    klisp_Cfunc fn = (klisp_Cfunc) K->next_func;
+		    (*fn)(K, K->next_xparams, K->next_value);
+		} else {
+		    /* operative calling */
+		    klisp_Ofunc fn = (klisp_Ofunc) K->next_func;
+		    (*fn)(K, K->next_xparams, K->next_value, K->next_env);
+		}
+	    }
+	    printf("Done!\n");
 	    ret_value = 0;
 	    done = true;
 	}
diff --git a/src/kstate.h b/src/kstate.h
@@ -236,7 +236,7 @@ inline void klispS_apply_cc(klisp_State *K, TValue val)
     K->curr_cont = cont->parent;
 }
 
-#define kapply_cc(K_, val_) (klispS_appply_cc((K_), (val_)); return;)
+#define kapply_cc(K_, val_) klispS_apply_cc((K_), (val_)); return
 
 inline TValue klispS_get_cc(klisp_State *K)
 {
@@ -263,9 +263,8 @@ inline void klispS_tail_call(klisp_State *K, TValue top, TValue ptree,
     K->next_xparams = op->extra;
 }
 
-#define ktail_call(K_, op_, p_, e_) (klispS_tail_call( \
-					       (K_), (op_), (p_), (v_)); \
-					   return;)
+#define ktail_call(K_, op_, p_, e_) \
+    klispS_tail_call((K_), (op_), (p_), (e_)); return
 
 #endif