klisp

commit f8d9ff5256bfc0dceb56531b1b08480a407243cd
parent 412fe034f97fca1160afdd17bb5be87f1bf48890
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 17 Mar 2011 20:42:18 -0300

Added get-module to the ground environment.

Diffstat:
M
src/kgports.c
 | 
43
++++++++++++++++++++++++++++++++++++++++++-
M
src/kgports.h
 | 
2
+-
M
src/kground.c
 | 
2
+-
M
src/kstate.c
 | 
3
+++
M
src/kstate.h
 | 
6
+++++-

5 files changed, 52 insertions(+), 4 deletions(-)
diff --git a/src/kgports.c b/src/kgports.c
@@ -288,4 +288,45 @@ void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
 }
 
 /* 15.2.3 get-module */
-/* TODO */
+void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+    UNUSED(xparams);
+    UNUSED(denv);
+    bind_al1tp(K, "get-module", ptree, "string", ttisstring, filename, 
+	maybe_env);
+
+    TValue env = kmake_environment(K, K->ground_env);
+
+    if (get_opt_tpar(K, "", K_TENVIRONMENT, &maybe_env)) {
+	kadd_binding(K, env, K->module_params_sym, maybe_env);
+    }
+
+    /* the reads must be guarded to close the file if there is some error 
+     this continuation also will return inert after the evaluation of the
+     last expression is done */
+    TValue port = kmake_port(K, filename, false, KNIL, KNIL);
+    TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
+    /* this will be used later, but contruct it now to use the 
+       current continuation as parent 
+    GC: root this obj */
+    TValue ret_env_cont = make_return_value_cont(K, kget_cc(K), env);
+
+    kset_cc(K, guarded_cont);
+    TValue ls = read_all_expr(K, port); /* any error will close the port */
+
+    /* now the sequence of expresions should be evaluated in the created env
+       and the environment returned after all are done */
+    kset_cc(K, ret_env_cont);
+
+    if (ttisnil(ls)) {
+	kapply_cc(K, KINERT);
+    } else {
+	TValue tail = kcdr(ls);
+	if (ttispair(tail)) {
+	    TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+					     do_seq, 2, tail, env);
+	    kset_cc(K, new_cont);
+	} 
+	ktail_eval(K, kcar(ls), env);
+    }
+}
diff --git a/src/kgports.h b/src/kgports.h
@@ -55,6 +55,6 @@ void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 /* 15.2.3 get-module */
-/* TODO */
+void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
 
 #endif
diff --git a/src/kground.c b/src/kground.c
@@ -540,7 +540,7 @@ void kinit_ground_env(klisp_State *K)
     add_applicative(K, ground_env, "load", load, 0);
 
     /* 15.2.3 get-module */
-    /* TODO */
+    add_applicative(K, ground_env, "get-module", get_module, 0);
 
     /* TODO: That's all there is in the report, but we will probably need:
        (from r5rs) char-ready?, read-char, peek-char, eof-object?, newline,
diff --git a/src/kstate.c b/src/kstate.c
@@ -29,6 +29,7 @@
 #include "kenvironment.h"
 #include "kground.h"
 #include "krepl.h"
+#include "ksymbol.h"
 
 /*
 ** State creation and destruction
@@ -63,6 +64,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
     /* these will be properly initialized later */
     K->eval_op = KINERT;
     K->ground_env = KINERT;
+    K->module_params_sym = KINERT;
     K->root_cont = KINERT;
     K->error_cont = KINERT;
 
@@ -121,6 +123,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
     /* create the ground environment and the eval operative */
     K->eval_op = kmake_operative(K, KNIL, KNIL, keval_ofn, 0);
     K->ground_env = kmake_empty_environment(K);
+    K->module_params_sym = ksymbol_new(K, "module-parameters");
     
     kinit_ground_env(K);
 
diff --git a/src/kstate.h b/src/kstate.h
@@ -52,7 +52,11 @@ struct klisp_State {
     TValue *next_xparams; 
 
     TValue eval_op; /* the operative for evaluation */
-    TValue ground_env; 
+    TValue ground_env;  /* the environment with all the ground definitions */
+    /* standard environments are environments with no bindings and ground_env
+       as parent */
+    TValue module_params_sym; /* this is the symbol "module-parameters" */
+    /* it is used in get-module */
     TValue root_cont; 
     TValue error_cont;