commit feebadac091c96121f6ac2551fe09a22fb923771
parent e658af31fda83405053f9e1b02d0c7856d4b35c4
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 14 Dec 2011 08:38:23 -0300
Added $import-module to the ground environment and completed the modules section.
Diffstat:
| M | TODO | | | 4 | ++-- |
| M | src/kgmodules.c | | | 328 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----- |
2 files changed, 311 insertions(+), 21 deletions(-)
diff --git a/TODO b/TODO
@@ -1,6 +1,4 @@
* Release 0.3
-** modules:
-*** simple modules (something inspired in r7rs) (r7rs)
** documentation:
*** update the manual with the current features
*** add a section to the manual with the interpreter usage
@@ -28,6 +26,8 @@
- currently
- int32_t (used in lists)
- uint32_t (used in strings, vectors and bytevectors)
+*** add static qualifiers (especially in all kg*.c files
+*** add const qualifiers where sensible
** fix:
*** fix char-ready? and u8-ready? (r7rs)
** reader/writer
diff --git a/src/kgmodules.c b/src/kgmodules.c
@@ -7,6 +7,7 @@
#include <stdlib.h>
#include <stdbool.h>
#include <stdint.h>
+#include <string.h>
#include "kstate.h"
#include "kobject.h"
@@ -23,15 +24,15 @@
#include "kgmodules.h"
/* Continuations */
-void do_register_module(klisp_State *K);
-void do_provide_module(klisp_State *K);
+static void do_register_module(klisp_State *K);
+static void do_provide_module(klisp_State *K);
/* ?.? module? */
/* uses typep */
/* Helper for make-module */
-inline void unmark_symbol_list(klisp_State *K, TValue ls)
+static inline void unmark_symbol_list(klisp_State *K, TValue ls)
{
UNUSED(K);
for(; ttispair(ls) && kis_symbol_marked(kcar(ls)); ls = kcdr(ls))
@@ -39,7 +40,7 @@ inline void unmark_symbol_list(klisp_State *K, TValue ls)
}
/* ?.? make-module */
-void make_module(klisp_State *K)
+static void make_module(klisp_State *K)
{
bind_1p(K, K->next_value, obj);
@@ -91,7 +92,7 @@ void make_module(klisp_State *K)
}
/* ?.? get-module-export-list */
-void get_module_export_list(klisp_State *K)
+static void get_module_export_list(klisp_State *K)
{
bind_1tp(K, K->next_value, "module", ttismodule, mod);
/* return mutable list (following the Kernel report) */
@@ -101,24 +102,28 @@ void get_module_export_list(klisp_State *K)
}
/* ?.? get-module-environment */
-void get_module_environment(klisp_State *K)
+static void get_module_environment(klisp_State *K)
{
bind_1tp(K, K->next_value, "module", ttismodule, mod);
kapply_cc(K, kmake_environment(K, kmodule_env(mod)));
}
/* Helpers for working with module names */
-bool valid_name_partp(TValue obj)
+static bool valid_name_partp(TValue obj)
{
return ttissymbol(obj) || (keintegerp(obj) && !knegativep(obj));
}
-void check_module_name(klisp_State *K, TValue name)
+static void check_module_name(klisp_State *K, TValue name)
{
+ if (ttisnil(name)) {
+ klispE_throw_simple(K, "Empty module name");
+ return;
+ }
check_typed_list(K, valid_name_partp, false, name, NULL, NULL);
}
-TValue modules_registry_assoc(klisp_State *K, TValue name, TValue *lastp)
+static TValue modules_registry_assoc(klisp_State *K, TValue name, TValue *lastp)
{
TValue last = KNIL;
TValue res = KNIL;
@@ -134,7 +139,7 @@ TValue modules_registry_assoc(klisp_State *K, TValue name, TValue *lastp)
}
/* ?.? $registered-module? */
-void Sregistered_moduleP(klisp_State *K)
+static void Sregistered_moduleP(klisp_State *K)
{
bind_1p(K, K->next_value, name);
check_module_name(K, name);
@@ -143,7 +148,7 @@ void Sregistered_moduleP(klisp_State *K)
}
/* ?.? $get-registered-module */
-void Sget_registered_module(klisp_State *K)
+static void Sget_registered_module(klisp_State *K)
{
bind_1p(K, K->next_value, name);
check_module_name(K, name);
@@ -156,7 +161,7 @@ void Sget_registered_module(klisp_State *K)
kapply_cc(K, kcdr(entry));
}
-void do_register_module(klisp_State *K)
+static void do_register_module(klisp_State *K)
{
/*
** xparams[0]: name
@@ -182,7 +187,7 @@ void do_register_module(klisp_State *K)
}
/* ?.? $register-module! */
-void Sregister_moduleB(klisp_State *K)
+static void Sregister_moduleB(klisp_State *K)
{
bind_2p(K, K->next_value, name, module);
check_module_name(K, name);
@@ -198,7 +203,7 @@ void Sregister_moduleB(klisp_State *K)
}
/* ?.? $unregister-module! */
-void Sunregister_moduleB(klisp_State *K)
+static void Sunregister_moduleB(klisp_State *K)
{
bind_1p(K, K->next_value, name);
check_module_name(K, name);
@@ -218,7 +223,7 @@ void Sunregister_moduleB(klisp_State *K)
}
/* Helpers for provide-module */
-void unmark_export_list(klisp_State *K, TValue exports, TValue last)
+static void unmark_export_list(klisp_State *K, TValue exports, TValue last)
{
/* exports shouldn't have the leading keyword */
UNUSED(K);
@@ -231,7 +236,7 @@ void unmark_export_list(klisp_State *K, TValue exports, TValue last)
}
}
-void check_export_list(klisp_State *K, TValue exports)
+static void check_export_list(klisp_State *K, TValue exports)
{
int32_t pairs;
check_list(K, false, exports, &pairs, NULL);
@@ -285,7 +290,7 @@ void check_export_list(klisp_State *K, TValue exports)
unmark_export_list(K, exports, KNIL);
}
-void do_provide_module(klisp_State *K)
+static void do_provide_module(klisp_State *K)
{
/*
** xparams[0]: name
@@ -333,7 +338,7 @@ void do_provide_module(klisp_State *K)
}
/* ?.? $provide-module! */
-void Sprovide_moduleB(klisp_State *K)
+static void Sprovide_moduleB(klisp_State *K)
{
bind_al2p(K, K->next_value, name, exports, body);
check_module_name(K, name);
@@ -408,6 +413,291 @@ void Sprovide_moduleB(klisp_State *K)
}
}
+/* Helpers from $import-module! */
+
+/* This takes a keyword import clause */
+static void check_distinct_symbols(klisp_State *K, TValue clause)
+{
+ /* probably no need to use a table environment for this */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ bool pairp = kkeyword_cstr_cmp(kcar(clause), "rename") == 0;
+ for (TValue ls = kcdr(kcdr(clause)); !ttisnil(ls); ls = kcdr(ls)) {
+ TValue s = kcar(ls);
+ TValue s2 = s;
+ if (pairp) {
+ if (!ttispair(s) || !ttispair(kcdr(s)) ||
+ !ttisnil(kcdr(kcdr(s)))) {
+
+ klispE_throw_simple_with_irritants(K, "bad syntax in #:rename "
+ "import clause", 1, clause);
+ return;
+ }
+ s2 = kcar(s);
+ /* s is the one that is checked for repeats */
+ s = kcar(kcdr(s));
+ }
+ if (!ttissymbol(s) || !ttissymbol(s2)) {
+ klispE_throw_simple_with_irritants(
+ K, "Not a symbol in import clause", 1, ttissymbol(s)? s2 : s);
+ return;
+ } else if (kbinds(K, env, s)) {
+ klispE_throw_simple_with_irritants(K, "Repeated symbol in import "
+ "clause", 1, s);
+ return;
+ }
+ kadd_binding(K, env, s, KINERT);
+ }
+ krooted_tvs_pop(K);
+}
+
+static void check_import_list(klisp_State *K, TValue imports)
+{
+ /* will use a stack for accumulating clauses */
+ TValue stack = KNIL;
+ krooted_vars_push(K, &stack);
+ check_list(K, false, imports, NULL, NULL);
+
+ while(!ttisnil(stack) || !ttisnil(imports)) {
+ TValue clause;
+ if (ttisnil(stack)) {
+ clause = kcar(imports);
+ while (ttispair(clause) && ttiskeyword(kcar(clause))) {
+ stack = kcons(K, clause, stack);
+ clause = kcar(kcdr(clause));
+ }
+ check_module_name(K, clause);
+ } else {
+ /* this is always a keyword clause */
+ clause = kcar(stack);
+ stack = kcdr(stack);
+ int32_t pairs;
+ check_list(K, false, clause, &pairs, NULL);
+ if (pairs < 3) {
+ klispE_throw_simple_with_irritants(K, "bad syntax in import "
+ "clause", 1, clause);
+ return;
+ }
+ TValue keyw = kcar(clause);
+
+ if (kkeyword_cstr_cmp(keyw, "only") == 0 ||
+ kkeyword_cstr_cmp(keyw, "except") == 0 ||
+ kkeyword_cstr_cmp(keyw, "rename") == 0) {
+
+ check_distinct_symbols(K, clause);
+ } else if (kkeyword_cstr_cmp(keyw, "prefix") == 0) {
+ if (pairs != 3) {
+ klispE_throw_simple_with_irritants(K, "import clause is too "
+ "short", 1, clause);
+ return;
+ } else if (!ttissymbol(kcar(kcdr(kcdr(clause))))) {
+ klispE_throw_simple_with_irritants(
+ K, "Non symbol in #:prefix import clause", 1, clause);
+ return;
+ }
+ } else {
+ klispE_throw_simple_with_irritants(K, "unknown keyword in "
+ "import clause", 1, clause);
+ return;
+ }
+ }
+ if (ttisnil(stack))
+ imports = kcdr(imports);
+ }
+ krooted_vars_pop(K);
+}
+
+static void check_symbols_in_bindings(klisp_State *K, TValue ls, TValue env)
+{
+ for (; !ttisnil(ls); ls = kcdr(ls)) {
+ TValue s = kcar(ls);
+ if (ttispair(s)) s = kcar(s);
+
+ if (!kbinds(K, env, s)) {
+ klispE_throw_simple_with_irritants(
+ K, "Unknown symbol in import clause", 1, s);
+ return;
+ }
+ }
+}
+
+static TValue extract_import_bindings(klisp_State *K, TValue imports)
+{
+ TValue ret_ls = kcons(K, KNIL, KNIL);
+ TValue lp = ret_ls;
+ krooted_tvs_push(K, ret_ls);
+ TValue np = KNIL;
+ krooted_vars_push(K, &np);
+ /* will use a stack for accumulating clauses */
+ TValue stack = KNIL;
+ krooted_vars_push(K, &stack);
+ TValue menv = KINERT;
+ TValue mls = KINERT;
+ krooted_vars_push(K, &menv);
+ krooted_vars_push(K, &mls);
+
+ while(!ttisnil(stack) || !ttisnil(imports)) {
+ TValue clause;
+ if (ttisnil(stack)) {
+ /* clause can't be nil */
+ clause = kcar(imports);
+ while (ttiskeyword(kcar(clause))) {
+ stack = kcons(K, clause, stack);
+ clause = kcar(kcdr(clause));
+ }
+ TValue entry = modules_registry_assoc(K, clause, NULL);
+ if (ttisnil(entry)) {
+ klispE_throw_simple_with_irritants(K, "module name not "
+ "registered", 1, clause);
+ return KINERT;
+ }
+ menv = kmodule_env(kcdr(entry));
+ mls = kmodule_exp_list(kcdr(entry));
+
+ if (ttisnil(stack))
+ continue;
+ } else {
+ clause = kcar(stack);
+ stack = kcdr(stack);
+ }
+
+ if (ttiskeyword(kcar(clause))) {
+ TValue keyw = kcar(clause);
+
+ TValue rest = kcdr(kcdr(clause));
+ if (kkeyword_cstr_cmp(keyw, "only") == 0) {
+ check_symbols_in_bindings(K, rest, menv);
+ mls = rest;
+ } else if (kkeyword_cstr_cmp(keyw, "except") == 0) {
+ check_symbols_in_bindings(K, rest, menv);
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ for (TValue ls = rest; !ttisnil(ls); ls = kcdr(ls))
+ kadd_binding(K, env, kcar(ls), KINERT);
+ /* filter */
+ TValue nmls = kcons(K, KNIL, KNIL);
+ TValue nmls_lp = nmls;
+ krooted_tvs_push(K, nmls);
+ for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) {
+ TValue s = kcar(ls);
+ if (!kbinds(K, env, s)) {
+ np = kcons(K, s, KNIL);
+ kset_cdr(nmls_lp, np);
+ nmls_lp = np;
+ }
+ }
+ mls = kcdr(nmls);
+ krooted_tvs_pop(K); krooted_tvs_pop(K);
+ } else if (kkeyword_cstr_cmp(keyw, "prefix") == 0) {
+ TValue pre = kcar(rest);
+ TValue obj = KNIL;
+ krooted_vars_push(K, &obj);
+ TValue nmls = kcons(K, KNIL, KNIL);
+ TValue nmls_lp = nmls;
+ krooted_tvs_push(K, nmls);
+ TValue nmenv = kmake_empty_environment(K);
+ krooted_tvs_push(K, nmenv);
+ for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) {
+ TValue s = kcar(ls);
+ obj = kstring_new_s(K, ksymbol_size(pre) +
+ ksymbol_size(s));
+ memcpy(kstring_buf(obj), ksymbol_buf(pre),
+ ksymbol_size(pre));
+ memcpy(kstring_buf(obj) + ksymbol_size(pre),
+ ksymbol_buf(s), ksymbol_size(s));
+ /* TODO attach si */
+ obj = ksymbol_new_str(K, obj, KNIL);
+ np = kcons(K, obj, KNIL);
+ kset_cdr(nmls_lp, np);
+ nmls_lp = np;
+
+ kadd_binding(K, nmenv, obj, kget_binding(K, menv, s));
+ }
+ mls = kcdr(nmls);
+ menv = nmenv;
+ krooted_vars_pop(K);
+ krooted_tvs_pop(K); krooted_tvs_pop(K);
+ } else if (kkeyword_cstr_cmp(keyw, "rename") == 0) {
+ check_distinct_symbols(K, clause);
+ TValue nmls = kcons(K, KNIL, KNIL);
+ TValue nmls_lp = nmls;
+ krooted_tvs_push(K, nmls);
+ TValue nmenv = kmake_empty_environment(K);
+ krooted_tvs_push(K, nmenv);
+
+ for (TValue ls = rest; !ttisnil(ls); ls = kcdr(ls)) {
+ TValue p = kcar(ls);
+ TValue si = kcar(p);
+ TValue se = kcar(kcdr(p));
+
+ np = kcons(K, se, KNIL);
+ kset_cdr(nmls_lp, np);
+ nmls_lp = np;
+
+ kadd_binding(K, nmenv, se, kget_binding(K, menv, si));
+ }
+ mls = kcdr(nmls);
+ menv = nmenv;
+ krooted_tvs_pop(K); krooted_tvs_pop(K);
+ }
+ }
+
+ if (ttisnil(stack)) {
+ /* move to next import clause */
+ for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) {
+ TValue s = kcar(ls);
+ np = kcons(K, s, kget_binding(K, menv, s));
+ np = kcons(K, np, KNIL);
+ kset_cdr(lp, np);
+ lp = np;
+ }
+ imports = kcdr(imports);
+ }
+ }
+ krooted_vars_pop(K); krooted_vars_pop(K);
+ krooted_vars_pop(K); krooted_vars_pop(K);
+ krooted_tvs_pop(K);
+ return kcdr(ret_ls);
+}
+
+/* ?.? $import-module! */
+static void Simport_moduleB(klisp_State *K)
+{
+ TValue imports = K->next_value;
+ TValue denv = K->next_env;
+
+ check_import_list(K, imports);
+ /* list of (name . value) pairs */
+ TValue bindings = extract_import_bindings(K, imports);
+ krooted_tvs_push(K, bindings);
+
+ TValue env = kmake_table_environment(K, KNIL);
+ krooted_tvs_push(K, env);
+ TValue tail;
+ for (tail = bindings; !ttisnil(tail); tail = kcdr(tail)) {
+ TValue s = kcar(kcar(tail));
+ TValue v = kcdr(kcar(tail));
+ if (kbinds(K, env, s)) {
+ TValue v2 = kget_binding(K, env, s);
+ if (!eq2p(K, v, v2)) {
+ klispE_throw_simple_with_irritants(
+ K, "imported a symbol twice with un-eq? values",
+ 3, s, v, v2);
+ return;
+ }
+ } else {
+ kadd_binding(K, env, s, v);
+ }
+ }
+
+ for (tail = bindings; !ttisnil(tail); tail = kcdr(tail)) {
+ TValue s = kcar(kcar(tail));
+ TValue v = kcdr(kcar(tail));
+ kadd_binding(K, denv, s, v);
+ }
+ krooted_tvs_pop(K); krooted_tvs_pop(K);
+ kapply_cc(K, KINERT);
+}
/* init ground */
void kinit_modules_ground_env(klisp_State *K)
@@ -433,7 +723,7 @@ void kinit_modules_ground_env(klisp_State *K)
0);
add_operative(K, ground_env, "$provide-module!", Sprovide_moduleB, 0);
-
+ add_operative(K, ground_env, "$import-module!", Simport_moduleB, 0);
}
/* init continuation names */
