klisp

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

commit e658af31fda83405053f9e1b02d0c7856d4b35c4
parent a9b8f0645ef5b1128538335430036d10dcf29951
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Wed, 14 Dec 2011 02:17:53 -0300

Added $provide-module! to the ground environment.

Diffstat:
Msrc/Makefile | 2+-
Msrc/kgmodules.c | 211++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---
Msrc/kkeyword.c | 5+++++
Msrc/kkeyword.h | 2++
Msrc/kstring.c | 10++++++++++
Msrc/kstring.h | 1+
Msrc/ksymbol.c | 5+++++
Msrc/ksymbol.h | 1+
8 files changed, 229 insertions(+), 8 deletions(-)

diff --git a/src/Makefile b/src/Makefile @@ -224,7 +224,7 @@ kgpromises.o: kgpromises.c kstate.h klimits.h klisp.h kobject.h \ kgmodules.o: kgmodules.c kstate.h klimits.h klisp.h kobject.h \ klispconf.h ktoken.h kmem.h kmodule.h kpair.h kgc.h kapplicative.h \ koperative.h kcontinuation.h kerror.h kghelpers.h kenvironment.h \ - ksymbol.h kstring.h ktable.h kgmodules.h kpair.h + ksymbol.h kstring.h ktable.h kgmodules.h kpair.h kkeyword.h kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \ ktoken.h kmem.h kground.h kghelpers.h kerror.h kpair.h kgc.h \ kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \ diff --git a/src/kgmodules.c b/src/kgmodules.c @@ -17,12 +17,14 @@ #include "kerror.h" #include "kpair.h" #include "kenvironment.h" +#include "kkeyword.h" #include "kghelpers.h" #include "kgmodules.h" /* Continuations */ -void do_module_registration(klisp_State *K); +void do_register_module(klisp_State *K); +void do_provide_module(klisp_State *K); /* ?.? module? */ @@ -32,10 +34,8 @@ void do_module_registration(klisp_State *K); inline void unmark_symbol_list(klisp_State *K, TValue ls) { UNUSED(K); - while(ttispair(ls) && kis_symbol_marked(kcar(ls))) { + for(; ttispair(ls) && kis_symbol_marked(kcar(ls)); ls = kcdr(ls)) kunmark_symbol(kcar(ls)); - ls = kcdr(ls); - } } /* ?.? make-module */ @@ -156,7 +156,7 @@ void Sget_registered_module(klisp_State *K) kapply_cc(K, kcdr(entry)); } -void do_module_registration(klisp_State *K) +void do_register_module(klisp_State *K) { /* ** xparams[0]: name @@ -190,7 +190,7 @@ void Sregister_moduleB(klisp_State *K) /* XXX could use unchecked_copy_list if available */ name = check_copy_list(K, name, false, NULL, NULL); krooted_tvs_push(K, name); - TValue cont = kmake_continuation(K, kget_cc(K), do_module_registration, + TValue cont = kmake_continuation(K, kget_cc(K), do_register_module, 1, name); krooted_tvs_pop(K); kset_cc(K, cont); @@ -217,6 +217,198 @@ void Sunregister_moduleB(klisp_State *K) kapply_cc(K, KINERT); } +/* Helpers for provide-module */ +void unmark_export_list(klisp_State *K, TValue exports, TValue last) +{ + /* exports shouldn't have the leading keyword */ + UNUSED(K); + for (; !tv_equal(exports, last); exports = kcdr(exports)) { + TValue first = kcar(exports); + if (ttissymbol(first)) + kunmark_symbol(first); + else + kunmark_symbol(kcar(kcdr(kcdr(first)))); + } +} + +void check_export_list(klisp_State *K, TValue exports) +{ + int32_t pairs; + check_list(K, false, exports, &pairs, NULL); + if (ttisnil(exports) || !ttiskeyword(kcar(exports)) || + kkeyword_cstr_cmp(kcar(exports), "export") != 0) { + + klispE_throw_simple_with_irritants(K, "missing #:export keyword", + 1, exports); + return; + } + /* empty export list are allowed (but still need #:export) */ + --pairs; + exports = kcdr(exports); + /* check that all entries are either a unique symbol or + a rename form: (#:rename int-s ext-s) with unique ext-s */ + for (TValue tail = exports; pairs > 0; --pairs, tail = kcdr(tail)) { + TValue clause = kcar(tail); + TValue symbol; + if (ttissymbol(clause)) { + symbol = clause; + } else { + int32_t pairs; + /* this use of marks doesn't interfere with symbols */ + check_list(K, false, clause, &pairs, NULL); + if (pairs != 3 || + kkeyword_cstr_cmp(kcar(clause), "rename") != 0) { + + unmark_export_list(K, exports, tail); + klispE_throw_simple_with_irritants(K, "Bad export clause " + "syntax", 1, clause); + return; + } else if (!ttissymbol(kcar(kcdr(clause))) || + !ttissymbol(kcar(kcdr(kcdr(clause))))) { + unmark_export_list(K, exports, tail); + klispE_throw_simple_with_irritants(K, "Non symbol in #:rename " + "export clause", 1, clause); + return; + } else { + symbol = kcar(kcdr(kcdr(clause))); + } + } + + if (kis_symbol_marked(symbol)) { + unmark_export_list(K, exports, tail); + klispE_throw_simple_with_irritants(K, "repeated symbol in export " + "list", 1, symbol); + return; + } + kmark_symbol(symbol); + } + unmark_export_list(K, exports, KNIL); +} + +void do_provide_module(klisp_State *K) +{ + /* + ** xparams[0]: name + ** xparams[1]: inames + ** xparams[2]: enames + ** xparams[3]: env + */ + TValue name = K->next_xparams[0]; + + if (!ttisnil(modules_registry_assoc(K, name, NULL))) { + klispE_throw_simple_with_irritants(K, "module name already registered", + 1, name); + return; + } + + TValue inames = K->next_xparams[1]; + TValue enames = K->next_xparams[2]; + TValue env = K->next_xparams[3]; + + TValue new_env = kmake_table_environment(K, KNIL); + krooted_tvs_push(K, new_env); + + for (; !ttisnil(inames); inames = kcdr(inames), enames = kcdr(enames)) { + TValue iname = kcar(inames); + if (!kbinds(K, env, iname)) { + klispE_throw_simple_with_irritants(K, "unbound exported symbol in " + "module", 1, iname); + return; + } + kadd_binding(K, new_env, kcar(enames), kget_binding(K, env, iname)); + } + + enames = K->next_xparams[2]; + TValue module = kmake_module(K, new_env, enames); + krooted_tvs_pop(K); /* new_env */ + krooted_tvs_push(K, module); + + TValue np = kcons(K, name, module); + krooted_tvs_pop(K); /* module */ + krooted_tvs_push(K, np); + np = kcons(K, np, K->modules_registry); + K->modules_registry = np; + krooted_tvs_pop(K); + kapply_cc(K, KINERT); +} + +/* ?.? $provide-module! */ +void Sprovide_moduleB(klisp_State *K) +{ + bind_al2p(K, K->next_value, name, exports, body); + check_module_name(K, name); + name = check_copy_list(K, name, false, NULL, NULL); + krooted_tvs_push(K, name); + check_export_list(K, exports); + TValue inames = kimm_cons(K, KNIL, KNIL); + TValue ilast = inames; + krooted_vars_push(K, &inames); + TValue enames = kimm_cons(K, KNIL, KNIL); + TValue elast = enames; + krooted_vars_push(K, &enames); + + for (exports = kcdr(exports); !ttisnil(exports); exports = kcdr(exports)) { + TValue clause = kcar(exports); + TValue isym, esym; + if (ttissymbol(clause)) { + isym = esym = clause; + } else { + isym = kcar(kcdr(clause)); + esym = kcar(kcdr(kcdr(clause))); + } + TValue np = kimm_cons(K, isym, KNIL); + kset_cdr_unsafe(K, ilast, np); + ilast = np; + np = kimm_cons(K, esym, KNIL); + kset_cdr_unsafe(K, elast, np); + elast = np; + } + inames = kcdr(inames); + enames = kcdr(enames); + + check_list(K, false, body, NULL, NULL); + + body = copy_es_immutable_h(K, body, false); + krooted_tvs_push(K, body); + + if (!ttisnil(modules_registry_assoc(K, name, NULL))) { + klispE_throw_simple_with_irritants(K, "module name already registered", + 1, name); + return; + } + /* TODO add some continuation protection/additional checks */ + /* TODO add cyclical definition handling */ + // do cont + + /* use a child of the dynamic environment to do evaluations */ + TValue env = kmake_table_environment(K, K->next_env); + krooted_tvs_push(K, env); + + kset_cc(K, kmake_continuation(K, kget_cc(K), do_provide_module, + 4, name, inames, enames, env)); + + if (!ttisnil(body) && !ttisnil(kcdr(body))) { + TValue cont = kmake_continuation(K, kget_cc(K), do_seq, 2, + kcdr(body), env); + kset_cc(K, cont); +#if KTRACK_SI + /* put the source info of the list including the element + that we are about to evaluate */ + kset_source_info(K, cont, ktry_get_si(K, body)); +#endif + } + + krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K); + krooted_vars_pop(K); krooted_vars_pop(K); + + if (ttisnil(body)) { + kapply_cc(K, KINERT); + } else { + ktail_eval(K, kcar(body), env); + } +} + + /* init ground */ void kinit_modules_ground_env(klisp_State *K) { @@ -230,6 +422,7 @@ void kinit_modules_ground_env(klisp_State *K) get_module_export_list, 0); add_applicative(K, ground_env, "get-module-environment", get_module_environment, 0); + add_operative(K, ground_env, "$registered-module?", Sregistered_moduleP, 0); add_operative(K, ground_env, "$get-registered-module", @@ -238,6 +431,9 @@ void kinit_modules_ground_env(klisp_State *K) 0); add_operative(K, ground_env, "$unregister-module!", Sunregister_moduleB, 0); + + add_operative(K, ground_env, "$provide-module!", Sprovide_moduleB, 0); + } /* init continuation names */ @@ -245,5 +441,6 @@ void kinit_modules_cont_names(klisp_State *K) { Table *t = tv2table(K->cont_name_table); - add_cont_name(K, t, do_module_registration, "register-module"); + add_cont_name(K, t, do_register_module, "register-module"); + add_cont_name(K, t, do_provide_module, "provide-module"); } diff --git a/src/kkeyword.c b/src/kkeyword.c @@ -96,3 +96,8 @@ TValue kkeyword_new_str(klisp_State *K, TValue str) } bool kkeywordp(TValue obj) { return ttiskeyword(obj); } + +int32_t kkeyword_cstr_cmp(TValue keyw, const char *buf) +{ + return kstring_cstr_cmp(kkeyword_str(keyw), buf); +} diff --git a/src/kkeyword.h b/src/kkeyword.h @@ -28,4 +28,6 @@ TValue kkeyword_new_str(klisp_State *K, TValue str); bool kkeywordp(TValue obj); +int32_t kkeyword_cstr_cmp(TValue str, const char *buf); + #endif diff --git a/src/kstring.c b/src/kstring.c @@ -231,3 +231,13 @@ bool kmutable_stringp(TValue obj) { return ttisstring(obj) && kis_mutable(obj); } + +int32_t kstring_cstr_cmp(TValue str, const char *buf) +{ + int32_t len1 = kstring_size(str); + int32_t len2 = strlen(buf); + if (len1 != len2) + return len1 < len2? -1 : 1; + else + return memcmp(kstring_buf(str), buf, len1); +} diff --git a/src/kstring.h b/src/kstring.h @@ -60,5 +60,6 @@ bool kstring_equalp(TValue obj1, TValue obj2); bool kstringp(TValue obj); bool kimmutable_stringp(TValue obj); bool kmutable_stringp(TValue obj); +int32_t kstring_cstr_cmp(TValue str, const char *buf); #endif diff --git a/src/ksymbol.c b/src/ksymbol.c @@ -119,3 +119,8 @@ TValue ksymbol_new_str(klisp_State *K, TValue str, TValue si) } bool ksymbolp(TValue obj) { return ttissymbol(obj); } + +int32_t ksymbol_cstr_cmp(TValue sym, const char *buf) +{ + return kstring_cstr_cmp(ksymbol_str(sym), buf); +} diff --git a/src/ksymbol.h b/src/ksymbol.h @@ -32,5 +32,6 @@ TValue ksymbol_new_str(klisp_State *K, TValue str, TValue si); #define ksymbol_size(tv_) (kstring_size(tv2sym(tv_)->str)) bool ksymbolp(TValue obj); +int32_t ksymbol_cstr_cmp(TValue sym, const char *buf); #endif