commit c7e6f2e9617569ec54e02446714d60001cbdf0df
parent 969555a1086485e060a869b2c63fa7adb3f19c0c
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 30 Mar 2011 15:05:36 -0300
Added $import! to the ground environment.
Diffstat:
5 files changed, 134 insertions(+), 5 deletions(-)
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -77,6 +77,12 @@ void SsetB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* Helpers for $set! */
void do_set_eval_obj(klisp_State *K, TValue *xparams, TValue obj)
{
+ /*
+ ** xparams[0]: name as symbol
+ ** xparams[1]: ptree
+ ** xparams[2]: expression to be eval'ed
+ ** xparams[3]: dynamic environment
+ */
TValue sname = xparams[0];
TValue formals = xparams[1];
TValue eval_exp = xparams[2];
@@ -97,8 +103,126 @@ void do_set_eval_obj(klisp_State *K, TValue *xparams, TValue obj)
}
}
+/* Helpers for $provide! & $import! */
+
+inline void unmark_maybe_symbol_list(klisp_State *K, TValue ls)
+{
+ UNUSED(K);
+ while(ttispair(ls) && kis_marked(ls)) {
+ TValue first = kcar(ls);
+ if (ttissymbol(first))
+ kunmark(first);
+ kunmark(ls);
+ ls = kcdr(ls);
+ }
+}
+
+/*
+** Check that obj is a finite list of symbols with no duplicates and
+** returns a copy of the list (cf. check_copy_ptree)
+*/
+TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
+{
+ TValue tail = obj;
+ bool type_errorp = false;
+ bool repeated_errorp = false;
+ TValue dummy = kcons(K, KNIL, KNIL);
+ TValue last_pair = dummy;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ /* even if there is a type error continue checking the structure */
+ TValue first = kcar(tail);
+ if (ksymbolp(first)) {
+ repeated_errorp |= kis_marked(first);
+ kmark(first);
+ } else {
+ type_errorp = true;
+ }
+ kmark(tail);
+
+ TValue new_pair = kcons(K, first, KNIL);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+
+ tail = kcdr(tail);
+ }
+ unmark_maybe_symbol_list(K, obj);
+
+ if (!ttisnil(tail)) {
+ klispE_throw_extra(K, name, ": expected finite list");
+ return KNIL;
+ } else if (type_errorp) {
+ /* TODO put type name too */
+ klispE_throw_extra(K, name , ": bad operand type (expected list of "
+ "symbols)");
+ return KNIL;
+ } else if (repeated_errorp) {
+ klispE_throw_extra(K, name , ": repeated symbols");
+ }
+ return kcdr(dummy);
+}
+
+void do_import(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** xparams[0]: name as symbol
+ ** xparams[1]: symbols
+ ** xparams[2]: dynamic environment
+ */
+ TValue sname = xparams[0];
+ TValue symbols = xparams[1];
+ TValue denv = xparams[2];
+
+ if (!ttisenvironment(obj)) {
+ klispE_throw_extra(K, ksymbol_buf(sname), ": bad type from first "
+ "operand evaluation (expected environment)");
+ return;
+ } else {
+ TValue env = obj;
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_match, 3,
+ symbols, denv, sname);
+ kset_cc(K, new_cont);
+ ktail_eval(K, kcons(K, K->list_app, symbols), env);
+ }
+}
+
/* 6.8.2 $provide! */
/* TODO */
+
/* 6.8.3 $import! */
-/* TODO */
+void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ /* ASK John: The report says that symbols can have repeated symbols
+ and even be cyclical (cf $provide!) however this doesn't work
+ in the derivation (that uses $set! and so needs a ptree, which are
+ acyclical and with no repeated symbols).
+ Here I follow $provide! and don't allow repeated symbols or cyclical
+ lists, NOTE: is this restriction is to be lifted the code to copy the
+ list should guarantee to contruct an acyclical list or do_import be
+ changed to work with cyclical lists (at the moment it uses do_match
+ that expects a ptree (although it works with repeated symbols provided
+ they all have the same value, it loops indefinitely with cyclical ptree)
+ */
+ /*
+ ** xparams[0]: name as symbol
+ */
+ TValue sname = xparams[0];
+ char *name = ksymbol_buf(sname);
+
+ bind_al1p(K, name, ptree, env_expr, symbols);
+
+ symbols = check_copy_symbol_list(K, name, symbols);
+
+ /* REFACTOR/ASK John: another way for this kind of operative would be
+ to first eval the env expression and only then check the type
+ of the symbol list (other operatives that could use this model to
+ avoid copying are $set!, $define! & $binds?) */
+
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_import, 3,
+ sname, symbols, denv);
+ kset_cc(K, new_cont);
+ ktail_eval(K, env_expr, denv);
+}
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -241,7 +241,10 @@ void do_set_eval_obj(klisp_State *K, TValue *xparams, TValue obj);
/* 6.8.2 $provide! */
/* TODO */
+/* Helper for $import! */
+void do_import(klisp_State *K, TValue *xparams, TValue obj);
+
/* 6.8.3 $import! */
-/* TODO */
+void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
#endif
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -198,7 +198,7 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_extra(K, name , allow_infp? ": expected list":
- "expected finite list");
+ ": expected finite list");
return 0;
} else if(ttispair(tail) && !allow_infp) {
klispE_throw_extra(K, name , ": expected finite list");
@@ -226,7 +226,7 @@ int32_t check_list(klisp_State *K, char *name, bool allow_infp,
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_extra(K, name, allow_infp? ": expected list":
- "expected finite list");
+ ": expected finite list");
return 0;
} else if(ttispair(tail) && !allow_infp) {
klispE_throw_extra(K, name , ": expected finite list");
diff --git a/src/kground.c b/src/kground.c
@@ -484,7 +484,7 @@ void kinit_ground_env(klisp_State *K)
/* TODO */
/* 6.8.3 $import! */
- /* TODO */
+ add_operative(K, ground_env, "$import!", SimportB, 1, symbol);
/*
** 6.9 Control
diff --git a/src/kobject.h b/src/kobject.h
@@ -469,6 +469,8 @@ extern char *ktv_names[];
#define kget_mark(p_) (tv2mgch(p_)->mark)
#ifdef KTRACK_MARKS
+/* XXX: marking macros should take a klisp_State parameter and
+ keep track of marks in the klisp_State */
int32_t kmark_count;
#define kset_mark(p_, m_) ({ TValue new_mark_ = (m_); \
TValue obj_ = (p_); \
