commit 05746b66644664cd7773c3735634d401b7632aff
parent 93ac1aacdd26b3ff6f4ea1222c0afab426fed283
Author: Andres Navarro <canavarro82@gmail.com>
Date: Thu, 17 Mar 2011 20:08:40 -0300
Added load to the ground environment.
Diffstat:
10 files changed, 158 insertions(+), 22 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -123,4 +123,5 @@ kgks_vars.o: kgks_vars.c kgks_vars.h kghelpers.h kstate.h klisp.h \
kpair.h kenvironment.h
kgports.o: kgports.c kgports.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h \
- kport.h ksymbol.h kread.h kwrite.h
+ kport.h ksymbol.h kread.h kwrite.h ktoken.h kgcontinuations.h \
+ kpair.h kenvironment.h
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -24,6 +24,7 @@
#include "kgcontinuations.h"
#include "kgcontrol.h" /* for seq helpers in $let/cc */
+
/* 7.1.1 continuation? */
/* uses typep */
@@ -79,7 +80,7 @@ void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
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)
+void do_pass_value(klisp_State *K, TValue *xparams, TValue obj)
{
UNUSED(xparams);
kapply_cc(K, obj);
@@ -169,12 +170,12 @@ void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
exit_guards = check_copy_guards(K, "guard-continuation: exit guards",
exit_guards);
- TValue outer_cont = kmake_continuation(K, cont, KNIL, KNIL, pass_value,
+ TValue outer_cont = kmake_continuation(K, cont, KNIL, KNIL, do_pass_value,
2, entry_guards, denv);
/* 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, denv);
+ do_pass_value, 2, exit_guards, denv);
/* mark it as an outer continuation */
kset_inner_cont(inner_cont);
kapply_cc(K, inner_cont);
@@ -265,13 +266,11 @@ void guard_dynamic_extent(klisp_State *K, TValue *xparams, TValue ptree,
exit_guards);
/* GC: root continuations */
/* The current continuation is guarded */
- TValue outer_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, pass_value,
+ TValue outer_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_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 */
+ do_pass_value, 1, exit_guards);
kset_inner_cont(inner_cont);
/* call combiner with no operands in the dynamic extent of inner,
diff --git a/src/kgcontinuations.h b/src/kgcontinuations.h
@@ -18,9 +18,8 @@
#include "kstate.h"
#include "kghelpers.h"
-/* Helpers (also used in keyed dynamic code */
-void pass_value(klisp_State *K, TValue *xparams, TValue obj);
-
+/* Helpers (also used in keyed dynamic code) */
+void do_pass_value(klisp_State *K, TValue *xparams, TValue obj);
/* 7.1.1 continuation? */
/* uses typep */
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -73,6 +73,8 @@ void Ssequence(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue ls = check_copy_list(K, "$sequence", ptree);
/* this is needed because seq continuation doesn't check for
nil sequence */
+ /* TODO this could be at least in an inlineable function to
+ allow used from $lambda, $vau, $let family, load, etc */
TValue tail = kcdr(ls);
if (ttispair(tail)) {
TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -20,7 +20,7 @@
#include "kerror.h"
#include "kghelpers.h"
-#include "kgcontinuations.h" /* for pass_value / guards */
+#include "kgcontinuations.h" /* for do_pass_value / guards */
#include "kgkd_vars.h"
/*
@@ -115,12 +115,10 @@ inline TValue make_bind_continuation(klisp_State *K, TValue key,
/* 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 */
+ do_pass_value, 2, entry_guards, env);
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 */
+ do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
return inner_cont;
}
diff --git a/src/kgports.c b/src/kgports.c
@@ -13,16 +13,22 @@
#include "kstate.h"
#include "kobject.h"
#include "kport.h"
+#include "kenvironment.h"
#include "kapplicative.h"
#include "koperative.h"
#include "kcontinuation.h"
+#include "kpair.h"
#include "kerror.h"
#include "ksymbol.h"
+#include "ktoken.h"
#include "kread.h"
#include "kwrite.h"
+#include "kpair.h"
#include "kghelpers.h"
#include "kgports.h"
+#include "kgcontinuations.h" /* for guards */
+#include "kgcontrol.h" /* for evaling in sequence */
/* 15.1.1 port? */
/* uses typep */
@@ -87,7 +93,7 @@ void read(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* TEMP: for now set this by hand */
- K->curr_in = tv2port(port)->file;
+ K->curr_in = kport_file(port);
ktok_reset_source_info(K); /* this should be saved in the port
and restored before the call to
read and saved after it */
@@ -114,7 +120,7 @@ void write(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* TEMP: for now set this by hand */
- K->curr_out = tv2port(port)->file;
+ K->curr_out = kport_file(port);
kwrite(K, obj);
kapply_cc(K, KINERT);
@@ -141,7 +147,7 @@ void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* TEMP: for now set this by hand */
- K->curr_out = tv2port(port)->file;
+ K->curr_out = kport_file(port);
knewline(K);
kapply_cc(K, KINERT);
@@ -150,8 +156,136 @@ void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 15.2.1 call-with-input-file, call-with-output-file */
/* TODO */
+
+/* helpers for load */
+
+/* read all expressions in a file */
+TValue read_all_expr(klisp_State *K, TValue port)
+{
+ /* TEMP: for now set this by hand */
+ K->curr_in = kport_file(port);
+ ktok_reset_source_info(K);
+ /* GC: root dummy and obj */
+ TValue dummy = kcons(K, KNIL, KNIL);
+ TValue tail = dummy;
+ TValue obj = KINERT;
+
+ while(true) {
+ obj = kread(K);
+ if (ttiseof(obj)) {
+ return kcdr(dummy);
+ } else {
+ TValue new_pair = kcons(K, obj, KNIL);
+ kset_cdr(tail, new_pair);
+ tail = new_pair;
+ }
+ }
+}
+
+/* interceptor for errors during reading */
+void do_close_file(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ /*
+ ** xparams[0]: port
+ */
+ UNUSED(denv);
+
+ TValue port = xparams[0];
+ /* ptree is (object divert) */
+ TValue error_obj = kcar(ptree);
+ kclose_port(K, port);
+ /* pass the error along after closing the port */
+ kapply_cc(K, error_obj);
+}
+
+/*
+** helpers for load and get-module it discards the passed obj
+** and instead returns a previously saved object
+** this feature is used by load to return #inert and by
+** get-module to return the created environment
+*/
+void do_return_value(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** xparams[0]: port
+ */
+ UNUSED(obj);
+ TValue ret_obj = xparams[0];
+ kapply_cc(K, ret_obj);
+}
+
+inline TValue make_return_value_cont(klisp_State *K, TValue parent, TValue obj)
+{
+ return kmake_continuation(K, parent, KNIL, KNIL, do_return_value, 1, obj);
+}
+
+/*
+** guarded continuation making for read seq
+*/
+TValue make_guarded_read_cont(klisp_State *K, TValue parent, TValue port)
+{
+ /* create the guard to close file after read errors */
+ TValue exit_int = kmake_operative(K, KNIL, KNIL, do_close_file,
+ 1, port);
+ TValue exit_guard = kcons(K, K->error_cont, exit_int);
+ TValue exit_guards = kcons(K, exit_guard, KNIL);
+ TValue entry_guards = KNIL;
+ /* this is needed for interception code */
+ TValue env = kmake_empty_environment(K);
+ TValue outer_cont = kmake_continuation(K, parent, KNIL, KNIL,
+ do_pass_value, 2, entry_guards, env);
+ kset_outer_cont(outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
+ do_pass_value, 2, exit_guards, env);
+ kset_inner_cont(inner_cont);
+ return inner_cont;
+}
+
/* 15.2.2 load */
-/* TODO */
+/* TEMP: this isn't yet defined in the report, but this seems pretty
+ a sane way to do it: open the file whose name is passed
+ as only parameter. read all the expressions in file as by read and
+ accumulate them in a list. close the file. eval ($sequence . list) in
+ the dynamic environment of the call to load. return #inert. If there is
+ any error during reading, close the file and return that error.
+ This is consistent with the report description of the load-module
+ applicative.
+*/
+void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ bind_1tp(K, "load", ptree, "string", ttisstring, filename);
+
+ /* 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 inert_cont = make_return_value_cont(K, kget_cc(K), KINERT);
+
+ 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 denv
+ and #inert returned after all are done */
+ kset_cc(K, inert_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, denv);
+ kset_cc(K, new_cont);
+ }
+ ktail_eval(K, kcar(ls), denv);
+ }
+}
/* 15.2.3 get-module */
/* TODO */
diff --git a/src/kgports.h b/src/kgports.h
@@ -52,7 +52,7 @@ void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* TODO */
/* 15.2.2 load */
-/* TODO */
+void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 15.2.3 get-module */
/* TODO */
diff --git a/src/kground.c b/src/kground.c
@@ -537,7 +537,7 @@ void kinit_ground_env(klisp_State *K)
/* TODO */
/* 15.2.2 load */
- /* TODO */
+ add_applicative(K, ground_env, "load", load, 0);
/* 15.2.3 get-module */
/* TODO */
diff --git a/src/kport.h b/src/kport.h
@@ -23,4 +23,5 @@ TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
set the closed flag to true */
void kclose_port(klisp_State *K, TValue port);
+#define kport_file(p_) (tv2port(p_)->file)
#endif
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -35,6 +35,8 @@ void kwrite_error(klisp_State *K, char *msg)
klispE_throw(K, msg);
}
+/* TODO: check for return codes and throw error if necessary */
+
/*
** Helper for printing strings (correcly escapes backslashes and
** double quotes & prints embedded '\0's). It includes the surrounding
