klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
MTODO | 4++--
Msrc/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 */