commit 0b485995252e4dda89df986163b713390fa80d80
parent e8285d8f494e7e2139830eec517b55cb20f33de4
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 24 Feb 2012 00:27:54 -0300
Refactor: renamed modules to libraries to follow scheme (r7rs & r6rs) and to avoid confusion with the report use of modules.
Diffstat:
20 files changed, 1128 insertions(+), 1141 deletions(-)
diff --git a/TODO b/TODO
@@ -4,7 +4,7 @@
**** Add missing sections
- vector
- bytevector
-- module/library
+- library
- error
** Test
*** Windows
@@ -20,19 +20,6 @@
- Add a couple of flags to turn debug on/off
** Webpage
- Have Maria Sol draw a simple logo
-
-** Refactor
-*** change 'module' to 'library'
- This follows r6rs and r7rs new draft, and avoids problems with the
- report uses of the word 'module'
-- c & h files
-- c function names
-- bound kernel names
-- documentation
-- tests
-- reference implementation in klisp-extra
-- libraries in klisp-extra
-
* Release 0.4+
** refactor:
*** clean stand alone interpreter
diff --git a/src/Makefile b/src/Makefile
@@ -36,8 +36,8 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kcontinuation.o koperative.o kapplicative.o keval.o krepl.o \
kencapsulation.o kpromise.o kport.o kinteger.o krational.o ksystem.o \
kreal.o ktable.o kgc.o imath.o imrat.o kbytevector.o kvector.o \
- kchar.o kkeyword.o kmodule.o \
- kground.o kghelpers.o kgbooleans.o kgeqp.o kgmodules.o \
+ kchar.o kkeyword.o klibrary.o \
+ kground.o kghelpers.o kgbooleans.o kgeqp.o kglibraries.o \
kgequalp.o kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o \
kgenvironments.o kgenv_mut.o kgcombiners.o kgcontinuations.o \
kgencapsulations.o kgpromises.o kgkd_vars.o kgks_vars.o kgports.o \
@@ -229,10 +229,10 @@ kgpromises.o: kgpromises.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpromise.h kpair.h kgc.h kapplicative.h \
koperative.h kcontinuation.h kerror.h kghelpers.h kenvironment.h \
ksymbol.h kstring.h ktable.h kgpromises.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 \
+kglibraries.o: kglibraries.c kstate.h klimits.h klisp.h kobject.h \
+ klispconf.h ktoken.h kmem.h klibrary.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 kkeyword.h
+ ksymbol.h kstring.h ktable.h kglibraries.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 \
@@ -240,7 +240,7 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgcontrol.h kgpairs_lists.h kgpair_mut.h kgenvironments.h kgenv_mut.h \
kgcombiners.h kgcontinuations.h kgencapsulations.h kgpromises.h \
kgkd_vars.h kgks_vars.h kgnumbers.h kgstrings.h kgchars.h kgports.h \
- kgbytevectors.h kgvectors.h kgsystem.h kgerrors.h kgmodules.h \
+ kgbytevectors.h kgvectors.h kgsystem.h kgerrors.h kglibraries.h \
kgffi.h keval.h krepl.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
@@ -279,8 +279,8 @@ kport.o: kport.c kport.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kerror.h kpair.h kgc.h kstring.h kbytevector.h
kpromise.o: kpromise.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kpromise.h kpair.h kgc.h
-kmodule.o: kmodule.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h kmodule.h kgc.h
+klibrary.o: klibrary.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
+ ktoken.h kmem.h klibrary.h kgc.h
krational.o: krational.c krational.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kinteger.h imath.h imrat.h kgc.h
kread.o: kread.c kread.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
diff --git a/src/kgc.c b/src/kgc.c
@@ -114,7 +114,7 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
case K_TVECTOR:
case K_TFPORT:
case K_TMPORT:
- case K_TMODULE:
+ case K_TLIBRARY:
o->gch.gclist = K->gray;
K->gray = o;
break;
@@ -348,11 +348,11 @@ static int32_t propagatemark (klisp_State *K) {
markvaluearray(K, v->array, v->sizearray);
return sizeof(Vector) + v->sizearray * sizeof(TValue);
}
- case K_TMODULE: {
- Module *m = cast(Module *, o);
- markvalue(K, m->env);
- markvalue(K, m->exp_list);
- return sizeof(Module);
+ case K_TLIBRARY: {
+ Library *l = cast(Library *, o);
+ markvalue(K, l->env);
+ markvalue(K, l->exp_list);
+ return sizeof(Library);
}
default:
fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
@@ -506,8 +506,8 @@ static void freeobj (klisp_State *K, GCObject *o) {
case K_TVECTOR:
klispM_freemem(K, o, sizeof(Vector) + sizeof(TValue) * o->vector.sizearray);
break;
- case K_TMODULE:
- klispM_free(K, (Module *)o);
+ case K_TLIBRARY:
+ klispM_free(K, (Library *)o);
break;
default:
/* shouldn't happen */
@@ -652,7 +652,7 @@ static void markroot (klisp_State *K) {
markvalue(K, K->require_path);
markvalue(K, K->require_table);
- markvalue(K, K->modules_registry);
+ markvalue(K, K->libraries_registry);
/* Mark all objects in the auxiliary stack,
(all valid indexes are below top) and all the objects in
diff --git a/src/kglibraries.c b/src/kglibraries.c
@@ -0,0 +1,762 @@
+/*
+** kglibraries.c
+** Libraries features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+#include <string.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "klibrary.h"
+#include "kapplicative.h"
+#include "koperative.h"
+#include "kcontinuation.h"
+#include "kerror.h"
+#include "kpair.h"
+#include "kenvironment.h"
+#include "kkeyword.h"
+
+#include "kghelpers.h"
+#include "kglibraries.h"
+
+/* Continuations */
+static void do_register_library(klisp_State *K);
+static void do_provide_library(klisp_State *K);
+
+
+/* ?.? library? */
+/* uses typep */
+
+/* Helper for make-library */
+static inline void unmark_symbol_list(klisp_State *K, TValue ls)
+{
+ UNUSED(K);
+ for(; ttispair(ls) && kis_symbol_marked(kcar(ls)); ls = kcdr(ls))
+ kunmark_symbol(kcar(ls));
+}
+
+/* ?.? make-library */
+static void make_library(klisp_State *K)
+{
+ bind_1p(K, K->next_value, obj);
+
+ int32_t pairs;
+ /* list can't be cyclical */
+ check_list(K, false, obj, &pairs, NULL);
+ /*
+ ** - check the type (also check symbols aren't repeated)
+ ** - copy the symbols in an immutable list
+ ** - put the values in a new empty env
+ */
+ TValue dummy = kcons(K, KNIL, KNIL);
+ krooted_tvs_push(K, dummy);
+ TValue lp = dummy;
+ TValue tail = obj;
+ /* use a table environment for libraries */
+ TValue env = kmake_table_environment(K, KNIL);
+ krooted_tvs_push(K, env);
+
+ for (int32_t i = 0; i < pairs; ++i, tail = kcdr(tail)) {
+ TValue p = kcar(tail);
+ if (!ttispair(p) || !ttissymbol(kcar(p))) {
+ unmark_symbol_list(K, kcdr(dummy));
+ klispE_throw_simple_with_irritants(K, "Bad type in bindings",
+ 1, tail);
+ return;
+ }
+
+ TValue sym = kcar(p);
+ TValue val = kcdr(p);
+ if (kis_symbol_marked(sym)) {
+ unmark_symbol_list(K, kcdr(dummy));
+ klispE_throw_simple_with_irritants(K, "Repeated symbol in "
+ "bindings", 1, sym);
+ return;
+ }
+ kmark_symbol(sym);
+
+ TValue np = kimm_cons(K, sym, KNIL);
+ kset_cdr_unsafe(K, lp, np);
+ lp = np;
+ kadd_binding(K, env, sym, val);
+ }
+
+ unmark_symbol_list(K, kcdr(dummy));
+ TValue new_lib = kmake_library(K, env, kcdr(dummy));
+ krooted_tvs_pop(K); krooted_tvs_pop(K);
+ kapply_cc(K, new_lib);
+}
+
+/* ?.? get-library-export-list */
+static void get_library_export_list(klisp_State *K)
+{
+ bind_1tp(K, K->next_value, "library", ttislibrary, lib);
+ /* return mutable list (following the Kernel report) */
+ /* XXX could use unchecked_copy_list if available */
+ TValue copy = check_copy_list(K, klibrary_exp_list(lib), true, NULL, NULL);
+ kapply_cc(K, copy);
+}
+
+/* ?.? get-library-environment */
+static void get_library_environment(klisp_State *K)
+{
+ bind_1tp(K, K->next_value, "library", ttislibrary, lib);
+ kapply_cc(K, kmake_environment(K, klibrary_env(lib)));
+}
+
+/* Helpers for working with library names */
+static bool valid_name_partp(TValue obj)
+{
+ return ttissymbol(obj) || (keintegerp(obj) && !knegativep(obj));
+}
+
+static void check_library_name(klisp_State *K, TValue name)
+{
+ if (ttisnil(name)) {
+ klispE_throw_simple(K, "Empty library name");
+ return;
+ }
+ check_typed_list(K, valid_name_partp, false, name, NULL, NULL);
+}
+
+static TValue libraries_registry_assoc(klisp_State *K, TValue name, TValue *lastp)
+{
+ TValue last = KNIL;
+ TValue res = KNIL;
+ for (TValue ls = K->libraries_registry; !ttisnil(ls); last = ls,
+ ls = kcdr(ls)) {
+ if (equal2p(K, kcar(kcar(ls)), name)) {
+ res = kcar(ls);
+ break;
+ }
+ }
+ if (lastp != NULL) *lastp = last;
+ return res;
+}
+
+/* ?.? $registered-library? */
+static void Sregistered_libraryP(klisp_State *K)
+{
+ bind_1p(K, K->next_value, name);
+ check_library_name(K, name);
+ TValue entry = libraries_registry_assoc(K, name, NULL);
+ kapply_cc(K, ttisnil(entry)? KFALSE : KTRUE);
+}
+
+/* ?.? $get-registered-library */
+static void Sget_registered_library(klisp_State *K)
+{
+ bind_1p(K, K->next_value, name);
+ check_library_name(K, name);
+ TValue entry = libraries_registry_assoc(K, name, NULL);
+ if (ttisnil(entry)) {
+ klispE_throw_simple_with_irritants(K, "Unregistered library name",
+ 1, name);
+ return;
+ }
+ kapply_cc(K, kcdr(entry));
+}
+
+static void do_register_library(klisp_State *K)
+{
+ /*
+ ** xparams[0]: name
+ */
+ TValue obj = K->next_value;
+ if (!ttislibrary(obj)) {
+ klispE_throw_simple_with_irritants(K, "not a library", 1, obj);
+ return;
+ }
+ TValue name = K->next_xparams[0];
+ TValue entry = libraries_registry_assoc(K, name, NULL);
+ if (!ttisnil(entry)) {
+ klispE_throw_simple_with_irritants(K, "library name already registered",
+ 1, name);
+ return;
+ }
+ TValue np = kcons(K, name, obj);
+ krooted_tvs_push(K, np);
+ np = kcons(K, np, K->libraries_registry);
+ K->libraries_registry = np;
+ krooted_tvs_pop(K);
+ kapply_cc(K, KINERT);
+}
+
+/* ?.? $register-library! */
+static void Sregister_libraryB(klisp_State *K)
+{
+ bind_2p(K, K->next_value, name, library);
+ check_library_name(K, name);
+ /* copy the name to avoid mutation */
+ /* 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_register_library,
+ 1, name);
+ krooted_tvs_pop(K);
+ kset_cc(K, cont);
+ ktail_eval(K, library, K->next_env);
+}
+
+/* ?.? $unregister-library! */
+static void Sunregister_libraryB(klisp_State *K)
+{
+ bind_1p(K, K->next_value, name);
+ check_library_name(K, name);
+ TValue last;
+ TValue entry = libraries_registry_assoc(K, name, &last);
+ if (ttisnil(entry)) {
+ klispE_throw_simple_with_irritants(K, "library name not registered",
+ 1, name);
+ return;
+ }
+ if (ttisnil(last)) { /* it's in the first pair */
+ K->libraries_registry = kcdr(K->libraries_registry);
+ } else {
+ kset_cdr(last, kcdr(kcdr(last)));
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* Helpers for provide-library */
+static 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))));
+ }
+}
+
+static 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);
+}
+
+static void do_provide_library(klisp_State *K)
+{
+ /*
+ ** xparams[0]: name
+ ** xparams[1]: inames
+ ** xparams[2]: enames
+ ** xparams[3]: env
+ */
+ TValue name = K->next_xparams[0];
+
+ if (!ttisnil(libraries_registry_assoc(K, name, NULL))) {
+ klispE_throw_simple_with_irritants(K, "library 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 "
+ "library", 1, iname);
+ return;
+ }
+ kadd_binding(K, new_env, kcar(enames), kget_binding(K, env, iname));
+ }
+
+ enames = K->next_xparams[2];
+ TValue library = kmake_library(K, new_env, enames);
+ krooted_tvs_pop(K); /* new_env */
+ krooted_tvs_push(K, library);
+
+ TValue np = kcons(K, name, library);
+ krooted_tvs_pop(K); /* library */
+ krooted_tvs_push(K, np);
+ np = kcons(K, np, K->libraries_registry);
+ K->libraries_registry = np;
+ krooted_tvs_pop(K);
+ kapply_cc(K, KINERT);
+}
+
+/* ?.? $provide-library! */
+static void Sprovide_libraryB(klisp_State *K)
+{
+ bind_al2p(K, K->next_value, name, exports, body);
+ check_library_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(libraries_registry_assoc(K, name, NULL))) {
+ klispE_throw_simple_with_irritants(K, "library 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_library,
+ 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);
+ }
+}
+
+/* Helpers from $import-library! */
+
+/* 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_library_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 = libraries_registry_assoc(K, clause, NULL);
+ if (ttisnil(entry)) {
+ klispE_throw_simple_with_irritants(K, "library name not "
+ "registered", 1, clause);
+ return KINERT;
+ }
+ menv = klibrary_env(kcdr(entry));
+ mls = klibrary_exp_list(kcdr(entry));
+
+ klisp_assert(ttispair(clause) && !ttiskeyword(kcar(clause)));
+ } 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);
+ /* env is for renamed symbols info */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+
+ /* remember all renamed symbols info first */
+ for (TValue ls = rest; !ttisnil(ls); ls = kcdr(ls)) {
+ TValue p = kcar(ls);
+ kadd_binding(K, env, kcar(p), kcar(kcdr(p)));
+ }
+
+ /* now we can construct the list and env */
+ 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);
+
+
+ /* add all renamed symbols first */
+ for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) {
+ TValue si = kcar(ls);
+ TValue se;
+ if (kbinds(K, env, si)) /* renamed binding */
+ se = kget_binding(K, env, si);
+ else se = si;
+
+ /* check that symbol wasn't already defined
+ (can happen if a binding is renamed to another binding
+ of the same library and that other binding isn't itself
+ renamed) */
+ if (kbinds(K, nmenv, se)) {
+ klispE_throw_simple_with_irritants(
+ K, "imported a symbol twice in #:rename clause",
+ 1, se);
+ return KINERT;
+ }
+
+ 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); 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-library! */
+static void Simport_libraryB(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_libraries_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ add_applicative(K, ground_env, "library?", typep, 2, symbol,
+ i2tv(K_TLIBRARY));
+ add_applicative(K, ground_env, "make-library", make_library, 0);
+ add_applicative(K, ground_env, "get-library-export-list",
+ get_library_export_list, 0);
+ add_applicative(K, ground_env, "get-library-environment",
+ get_library_environment, 0);
+
+ add_operative(K, ground_env, "$registered-library?", Sregistered_libraryP,
+ 0);
+ add_operative(K, ground_env, "$get-registered-library",
+ Sget_registered_library, 0);
+ add_operative(K, ground_env, "$register-library!", Sregister_libraryB,
+ 0);
+ add_operative(K, ground_env, "$unregister-library!", Sunregister_libraryB,
+ 0);
+
+ add_operative(K, ground_env, "$provide-library!", Sprovide_libraryB, 0);
+ add_operative(K, ground_env, "$import-library!", Simport_libraryB, 0);
+}
+
+/* init continuation names */
+void kinit_libraries_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_register_library, "register-library");
+ add_cont_name(K, t, do_provide_library, "provide-library");
+}
diff --git a/src/kglibraries.h b/src/kglibraries.h
@@ -0,0 +1,17 @@
+/*
+** kglibraries.h
+** Libraries features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kglibraries_h
+#define kglibraries_h
+
+#include "kstate.h"
+
+/* init ground */
+void kinit_libraries_ground_env(klisp_State *K);
+/* init continuation names */
+void kinit_libraries_cont_names(klisp_State *K);
+
+#endif
diff --git a/src/kgmodules.c b/src/kgmodules.c
@@ -1,762 +0,0 @@
-/*
-** kgmodules.c
-** Modules features for the ground environment
-** See Copyright Notice in klisp.h
-*/
-
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-#include <string.h>
-
-#include "kstate.h"
-#include "kobject.h"
-#include "kmodule.h"
-#include "kapplicative.h"
-#include "koperative.h"
-#include "kcontinuation.h"
-#include "kerror.h"
-#include "kpair.h"
-#include "kenvironment.h"
-#include "kkeyword.h"
-
-#include "kghelpers.h"
-#include "kgmodules.h"
-
-/* Continuations */
-static void do_register_module(klisp_State *K);
-static void do_provide_module(klisp_State *K);
-
-
-/* ?.? module? */
-/* uses typep */
-
-/* Helper for make-module */
-static inline void unmark_symbol_list(klisp_State *K, TValue ls)
-{
- UNUSED(K);
- for(; ttispair(ls) && kis_symbol_marked(kcar(ls)); ls = kcdr(ls))
- kunmark_symbol(kcar(ls));
-}
-
-/* ?.? make-module */
-static void make_module(klisp_State *K)
-{
- bind_1p(K, K->next_value, obj);
-
- int32_t pairs;
- /* list can't be cyclical */
- check_list(K, false, obj, &pairs, NULL);
- /*
- ** - check the type (also check symbols aren't repeated)
- ** - copy the symbols in an immutable list
- ** - put the values in a new empty env
- */
- TValue dummy = kcons(K, KNIL, KNIL);
- krooted_tvs_push(K, dummy);
- TValue lp = dummy;
- TValue tail = obj;
- /* use a table environment for modules */
- TValue env = kmake_table_environment(K, KNIL);
- krooted_tvs_push(K, env);
-
- for (int32_t i = 0; i < pairs; ++i, tail = kcdr(tail)) {
- TValue p = kcar(tail);
- if (!ttispair(p) || !ttissymbol(kcar(p))) {
- unmark_symbol_list(K, kcdr(dummy));
- klispE_throw_simple_with_irritants(K, "Bad type in bindings",
- 1, tail);
- return;
- }
-
- TValue sym = kcar(p);
- TValue val = kcdr(p);
- if (kis_symbol_marked(sym)) {
- unmark_symbol_list(K, kcdr(dummy));
- klispE_throw_simple_with_irritants(K, "Repeated symbol in "
- "bindings", 1, sym);
- return;
- }
- kmark_symbol(sym);
-
- TValue np = kimm_cons(K, sym, KNIL);
- kset_cdr_unsafe(K, lp, np);
- lp = np;
- kadd_binding(K, env, sym, val);
- }
-
- unmark_symbol_list(K, kcdr(dummy));
- TValue new_mod = kmake_module(K, env, kcdr(dummy));
- krooted_tvs_pop(K); krooted_tvs_pop(K);
- kapply_cc(K, new_mod);
-}
-
-/* ?.? get-module-export-list */
-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) */
- /* XXX could use unchecked_copy_list if available */
- TValue copy = check_copy_list(K, kmodule_exp_list(mod), true, NULL, NULL);
- kapply_cc(K, copy);
-}
-
-/* ?.? get-module-environment */
-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 */
-static bool valid_name_partp(TValue obj)
-{
- return ttissymbol(obj) || (keintegerp(obj) && !knegativep(obj));
-}
-
-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);
-}
-
-static TValue modules_registry_assoc(klisp_State *K, TValue name, TValue *lastp)
-{
- TValue last = KNIL;
- TValue res = KNIL;
- for (TValue ls = K->modules_registry; !ttisnil(ls); last = ls,
- ls = kcdr(ls)) {
- if (equal2p(K, kcar(kcar(ls)), name)) {
- res = kcar(ls);
- break;
- }
- }
- if (lastp != NULL) *lastp = last;
- return res;
-}
-
-/* ?.? $registered-module? */
-static void Sregistered_moduleP(klisp_State *K)
-{
- bind_1p(K, K->next_value, name);
- check_module_name(K, name);
- TValue entry = modules_registry_assoc(K, name, NULL);
- kapply_cc(K, ttisnil(entry)? KFALSE : KTRUE);
-}
-
-/* ?.? $get-registered-module */
-static void Sget_registered_module(klisp_State *K)
-{
- bind_1p(K, K->next_value, name);
- check_module_name(K, name);
- TValue entry = modules_registry_assoc(K, name, NULL);
- if (ttisnil(entry)) {
- klispE_throw_simple_with_irritants(K, "Unregistered module name",
- 1, name);
- return;
- }
- kapply_cc(K, kcdr(entry));
-}
-
-static void do_register_module(klisp_State *K)
-{
- /*
- ** xparams[0]: name
- */
- TValue obj = K->next_value;
- if (!ttismodule(obj)) {
- klispE_throw_simple_with_irritants(K, "not a module", 1, obj);
- return;
- }
- TValue name = K->next_xparams[0];
- TValue entry = modules_registry_assoc(K, name, NULL);
- if (!ttisnil(entry)) {
- klispE_throw_simple_with_irritants(K, "module name already registered",
- 1, name);
- return;
- }
- TValue np = kcons(K, name, obj);
- krooted_tvs_push(K, np);
- np = kcons(K, np, K->modules_registry);
- K->modules_registry = np;
- krooted_tvs_pop(K);
- kapply_cc(K, KINERT);
-}
-
-/* ?.? $register-module! */
-static void Sregister_moduleB(klisp_State *K)
-{
- bind_2p(K, K->next_value, name, module);
- check_module_name(K, name);
- /* copy the name to avoid mutation */
- /* 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_register_module,
- 1, name);
- krooted_tvs_pop(K);
- kset_cc(K, cont);
- ktail_eval(K, module, K->next_env);
-}
-
-/* ?.? $unregister-module! */
-static void Sunregister_moduleB(klisp_State *K)
-{
- bind_1p(K, K->next_value, name);
- check_module_name(K, name);
- TValue last;
- TValue entry = modules_registry_assoc(K, name, &last);
- if (ttisnil(entry)) {
- klispE_throw_simple_with_irritants(K, "module name not registered",
- 1, name);
- return;
- }
- if (ttisnil(last)) { /* it's in the first pair */
- K->modules_registry = kcdr(K->modules_registry);
- } else {
- kset_cdr(last, kcdr(kcdr(last)));
- }
- kapply_cc(K, KINERT);
-}
-
-/* Helpers for provide-module */
-static 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))));
- }
-}
-
-static 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);
-}
-
-static 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! */
-static 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);
- }
-}
-
-/* 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));
-
- klisp_assert(ttispair(clause) && !ttiskeyword(kcar(clause)));
- } 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);
- /* env is for renamed symbols info */
- TValue env = kmake_empty_environment(K);
- krooted_tvs_push(K, env);
-
- /* remember all renamed symbols info first */
- for (TValue ls = rest; !ttisnil(ls); ls = kcdr(ls)) {
- TValue p = kcar(ls);
- kadd_binding(K, env, kcar(p), kcar(kcdr(p)));
- }
-
- /* now we can construct the list and env */
- 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);
-
-
- /* add all renamed symbols first */
- for (TValue ls = mls; !ttisnil(ls); ls = kcdr(ls)) {
- TValue si = kcar(ls);
- TValue se;
- if (kbinds(K, env, si)) /* renamed binding */
- se = kget_binding(K, env, si);
- else se = si;
-
- /* check that symbol wasn't already defined
- (can happen if a binding is renamed to another binding
- of the same module and that other binding isn't itself
- renamed) */
- if (kbinds(K, nmenv, se)) {
- klispE_throw_simple_with_irritants(
- K, "imported a symbol twice in #:rename clause",
- 1, se);
- return KINERT;
- }
-
- 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); 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)
-{
- TValue ground_env = K->ground_env;
- TValue symbol, value;
-
- add_applicative(K, ground_env, "module?", typep, 2, symbol,
- i2tv(K_TMODULE));
- add_applicative(K, ground_env, "make-module", make_module, 0);
- add_applicative(K, ground_env, "get-module-export-list",
- 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",
- Sget_registered_module, 0);
- add_operative(K, ground_env, "$register-module!", Sregister_moduleB,
- 0);
- add_operative(K, ground_env, "$unregister-module!", Sunregister_moduleB,
- 0);
-
- add_operative(K, ground_env, "$provide-module!", Sprovide_moduleB, 0);
- add_operative(K, ground_env, "$import-module!", Simport_moduleB, 0);
-}
-
-/* init continuation names */
-void kinit_modules_cont_names(klisp_State *K)
-{
- Table *t = tv2table(K->cont_name_table);
-
- add_cont_name(K, t, do_register_module, "register-module");
- add_cont_name(K, t, do_provide_module, "provide-module");
-}
diff --git a/src/kgmodules.h b/src/kgmodules.h
@@ -1,17 +0,0 @@
-/*
-** kgmodules.h
-** Modules features for the ground environment
-** See Copyright Notice in klisp.h
-*/
-
-#ifndef kgmodules_h
-#define kgmodules_h
-
-#include "kstate.h"
-
-/* init ground */
-void kinit_modules_ground_env(klisp_State *K);
-/* init continuation names */
-void kinit_modules_cont_names(klisp_State *K);
-
-#endif
diff --git a/src/kground.c b/src/kground.c
@@ -40,7 +40,7 @@
#include "kgsystem.h"
#include "kgerrors.h"
#include "kgkeywords.h"
-#include "kgmodules.h"
+#include "kglibraries.h"
#if KUSE_LIBFFI
# include "kgffi.h"
@@ -85,7 +85,7 @@ void kinit_cont_names(klisp_State *K)
#if KUSE_LIBFFI
kinit_ffi_cont_names(K);
#endif
- kinit_modules_cont_names(K);
+ kinit_libraries_cont_names(K);
}
/*
@@ -120,7 +120,7 @@ void kinit_ground_env(klisp_State *K)
kinit_system_ground_env(K);
kinit_error_ground_env(K);
kinit_keywords_ground_env(K);
- kinit_modules_ground_env(K);
+ kinit_libraries_ground_env(K);
#if KUSE_LIBFFI
kinit_ffi_ground_env(K);
#endif
diff --git a/src/klibrary.c b/src/klibrary.c
@@ -0,0 +1,28 @@
+/*
+** klibrary.c
+** Kernel Libraries
+** See Copyright Notice in klisp.h
+*/
+
+#include "kobject.h"
+#include "kstate.h"
+#include "klibrary.h"
+#include "kmem.h"
+#include "kgc.h"
+
+/* GC: Assumes env & ext_list are roooted */
+/* ext_list should be immutable (and it may be empty) */
+TValue kmake_library(klisp_State *K, TValue env, TValue exp_list)
+{
+ klisp_assert(ttisnil(exp_list) || kis_immutable(exp_list));
+ Library *new_lib = klispM_new(K, Library);
+
+ /* header + gc_fields */
+ klispC_link(K, (GCObject *) new_lib, K_TLIBRARY,
+ K_FLAG_CAN_HAVE_NAME);
+
+ /* library specific fields */
+ new_lib->env = env;
+ new_lib->exp_list = exp_list;
+ return gc2lib(new_lib);
+}
diff --git a/src/klibrary.h b/src/klibrary.h
@@ -0,0 +1,20 @@
+/*
+** klibrary.h
+** Kernel Libraries
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef klibrary_h
+#define klibrary_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+/* GC: Assumes env & ext_list are roooted */
+/* ext_list should be immutable */
+TValue kmake_library(klisp_State *K, TValue env, TValue exp_list);
+
+#define klibrary_env(p_) (tv2lib(p_)->env)
+#define klibrary_exp_list(p_) (tv2lib(p_)->exp_list)
+
+#endif
diff --git a/src/kmodule.c b/src/kmodule.c
@@ -1,28 +0,0 @@
-/*
-** kmodule.c
-** Kernel Modules
-** See Copyright Notice in klisp.h
-*/
-
-#include "kobject.h"
-#include "kstate.h"
-#include "kmodule.h"
-#include "kmem.h"
-#include "kgc.h"
-
-/* GC: Assumes env & ext_list are roooted */
-/* ext_list should be immutable (and it may be empty) */
-TValue kmake_module(klisp_State *K, TValue env, TValue exp_list)
-{
- klisp_assert(ttisnil(exp_list) || kis_immutable(exp_list));
- Module *new_mod = klispM_new(K, Module);
-
- /* header + gc_fields */
- klispC_link(K, (GCObject *) new_mod, K_TMODULE,
- K_FLAG_CAN_HAVE_NAME);
-
- /* module specific fields */
- new_mod->env = env;
- new_mod->exp_list = exp_list;
- return gc2mod(new_mod);
-}
diff --git a/src/kmodule.h b/src/kmodule.h
@@ -1,20 +0,0 @@
-/*
-** kmodule.h
-** Kernel Modules
-** See Copyright Notice in klisp.h
-*/
-
-#ifndef kmodule_h
-#define kmodule_h
-
-#include "kobject.h"
-#include "kstate.h"
-
-/* GC: Assumes env & ext_list are roooted */
-/* ext_list should be immutable */
-TValue kmake_module(klisp_State *K, TValue env, TValue exp_list);
-
-#define kmodule_env(p_) (tv2mod(p_)->env)
-#define kmodule_exp_list(p_) (tv2mod(p_)->exp_list)
-
-#endif
diff --git a/src/kobject.c b/src/kobject.c
@@ -83,7 +83,7 @@ char *ktv_names[] = {
[K_TFPORT] = "file port",
[K_TMPORT] = "mem port",
[K_TKEYWORD] = "keyword",
- [K_TMODULE] = "module"
+ [K_TLIBRARY] = "library"
};
int32_t klispO_log2 (uint32_t x) {
diff --git a/src/kobject.h b/src/kobject.h
@@ -169,7 +169,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TMPORT 43
#define K_TVECTOR 44
#define K_TKEYWORD 45
-#define K_TMODULE 46
+#define K_TLIBRARY 46
/* for tables */
#define K_TDEADKEY 60
@@ -226,7 +226,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAG_MPORT K_MAKE_VTAG(K_TMPORT)
#define K_TAG_VECTOR K_MAKE_VTAG(K_TVECTOR)
#define K_TAG_KEYWORD K_MAKE_VTAG(K_TKEYWORD)
-#define K_TAG_MODULE K_MAKE_VTAG(K_TMODULE)
+#define K_TAG_LIBRARY K_MAKE_VTAG(K_TLIBRARY)
/*
** Macros to test types
@@ -328,7 +328,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
t_ == K_TAG_FPORT || t_ == K_TAG_MPORT;})
#define ttisvector(o) (tbasetype_(o) == K_TAG_VECTOR)
#define ttiskeyword(o) (tbasetype_(o) == K_TAG_KEYWORD)
-#define ttismodule(o) (tbasetype_(o) == K_TAG_MODULE)
+#define ttislibrary(o) (tbasetype_(o) == K_TAG_LIBRARY)
/* macros to easily check boolean values */
#define kis_true(o_) (tv_equal((o_), KTRUE))
@@ -558,7 +558,7 @@ typedef struct __attribute__ ((__packed__)) {
CommonHeader; /* symbols are marked via their strings */
TValue env; /* this is inherited and a child is returned */
TValue exp_list; /* this is an immutable list of symbols */
-} Module;
+} Library;
/*
** `module' operation for hashing (size is always a power of 2)
@@ -623,7 +623,7 @@ union GCObject {
MPort mport;
Vector vector;
Keyword keyw;
- Module mod;
+ Library lib;
};
@@ -739,7 +739,7 @@ const TValue kfree;
#define gc2bytevector(o_) (gc2tv(K_TAG_BYTEVECTOR, o_))
#define gc2vector(o_) (gc2tv(K_TAG_VECTOR, o_))
#define gc2keyw(o_) (gc2tv(K_TAG_KEYWORD, o_))
-#define gc2mod(o_) (gc2tv(K_TAG_MODULE, o_))
+#define gc2lib(o_) (gc2tv(K_TAG_LIBRARY, o_))
#define gc2deadkey(o_) (gc2tv(K_TAG_DEADKEY, o_))
/* Macro to convert a TValue into a specific heap allocated object */
@@ -762,7 +762,7 @@ const TValue kfree;
#define tv2mport(v_) ((MPort *) gcvalue(v_))
#define tv2port(v_) ((Port *) gcvalue(v_))
#define tv2keyw(v_) ((Keyword *) gcvalue(v_))
-#define tv2mod(v_) ((Module *) gcvalue(v_))
+#define tv2lib(v_) ((Library *) gcvalue(v_))
#define tv2gch(v_) ((GCheader *) gcvalue(v_))
#define tv2mgch(v_) ((MGCheader *) gcvalue(v_))
diff --git a/src/kstate.c b/src/kstate.c
@@ -207,8 +207,8 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
}
K->require_table = klispH_new(K, 0, MINREQUIRETABSIZE, 0);
- /* initialize module facilities */
- K->modules_registry = KNIL;
+ /* initialize library facilities */
+ K->libraries_registry = KNIL;
/* initialize temp stack */
K->ssize = KS_ISSIZE;
diff --git a/src/kstate.h b/src/kstate.h
@@ -158,8 +158,8 @@ struct klisp_State {
TValue require_path;
TValue require_table;
- /* modules */
- TValue modules_registry; /* this is a list, because module names
+ /* libraries */
+ TValue libraries_registry; /* this is a list, because library names
are list of symbols and numbers so
putting them in a table isn't easy */
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -702,8 +702,8 @@ void kwrite_scalar(klisp_State *K, TValue obj)
#endif
kw_printf(K, "]");
break;
- case K_TMODULE:
- kw_printf(K, "#[module");
+ case K_TLIBRARY:
+ kw_printf(K, "#[library");
#if KTRACK_NAMES
if (khas_name(obj)) {
kw_print_name(K, obj);
diff --git a/src/tests/libraries.k b/src/tests/libraries.k
@@ -0,0 +1,265 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of library system.
+;;
+
+;; N.B. Library registry is a hidden global variable. Library imports
+;; work anywhere in environment or continuation hierarchy.
+;;
+;; ($fresh A1 A2 ..) evaluates A1 A2... in a fresh environment.
+;;
+($define! $fresh
+ ($vau args #ignore
+ (eval (list* $sequence args) (make-kernel-standard-environment))))
+
+;; XXX $provide-library! $import-library!
+
+($check-predicate (operative? $provide-library!))
+($check-predicate (operative? $import-library!))
+
+($check-no-error
+ ($provide-library! (mod-a) (#:export p q)
+ ($define! p 1)
+ ($define! q 2)
+ ($define! r 3)))
+
+($check-error mod-a)
+($check-error p)
+($check-error q)
+($check-error r)
+
+($check-no-error
+ ($provide-library! (mod-b 1 2 x) (#:export p u (#:rename v w))
+ ($import-library! (#:only (mod-a) p))
+ ($define! u 4)
+ ($define! v 5)))
+
+($check-error mod-b)
+($check-error p)
+($check-error u)
+
+($check-no-error
+ ($provide-library! (mod-c) (#:export)
+ ($define! w 6)))
+
+($check-no-error
+ ($provide-library! (mod-d) (#:export p q)
+ ($define! p 7)
+ ($define! q 2)))
+
+($check-error w)
+
+($check-no-error ($provide-library! (mod-e) (#:export)))
+
+($check-error ($provide-library! (mod-a) (#:export) 1))
+($check-error ($provide-library! () (#:export)))
+($check-error ($provide-library! (mod-q) (a) ($define! a 1)))
+($check-error ($provide-library! (mod-q) (#:export #:a) ($define! a 1)))
+($check-error ($provide-library! (mod-q) (#:export a a) ($define! a 1)))
+($check-error ($provide-library! (mod-q) (#:export (a b)) ($define! a 1)))
+($check-error ($provide-library! (mod-q) (#:export (#:re-na-me a b)) ($define! a 1)))
+($check-error ($provide-library! (mod-q) (#:export (#:rename b a)) ($define! a 1)))
+($check-error ($provide-library! (mod-q) (#:export (#:rename a)) ($define! a 1)))
+($check-error ($provide-library! (mod-q) (#:export (#:rename a 2)) ($define! a 1)))
+($check-error ($provide-library! (mod-q) 1))
+($check-error ($provide-library! (mod-q) 1 (#:export)))
+($check-not-predicate ($registered-library? (mod-q)))
+
+($check equal? ($fresh ($import-library! (mod-a)) p) 1)
+($check equal? ($fresh ($import-library! (mod-a)) q) 2)
+($check-error ($fresh ($import-library! (mod-a)) r))
+
+($check equal? ($fresh ($import-library! (#:only (mod-a) p)) p) 1)
+($check equal? ($fresh ($import-library! (#:only (mod-a) q)) q) 2)
+($check equal? ($fresh ($import-library! (#:only (mod-a) p q)) p) 1)
+($check equal? ($fresh ($import-library! (#:only (mod-a) p q)) q) 2)
+($check-error ($fresh ($import-library! (#:only (mod-a) p)) q))
+($check-error ($fresh ($import-library! (#:only (mod-a) q)) p))
+($check-error ($fresh ($import-library! (#:only (mod-a) r))))
+($check-error ($fresh ($import-library! (#:only (mod-a) p p))))
+($check-error ($fresh ($import-library! (#:only (mod-a) "p"))))
+($check-error ($fresh ($import-library! (#:only (mod-a) #:p))))
+($check-error ($import-library! (#:only (mod-a))))
+
+($check equal? ($fresh ($import-library! (#:except (mod-a) p)) q) 2)
+($check equal? ($fresh ($import-library! (#:except (mod-a) q)) p) 1)
+($check-error ($fresh ($import-library! (#:except (mod-a) p q)) p))
+($check-error ($fresh ($import-library! (#:except (mod-a) p)) r))
+($check-error ($fresh ($import-library! (#:except (mod-a) r))))
+($check-error ($fresh ($import-library! (#:except (mod-a) p p))))
+($check-error ($fresh ($import-library! (#:except (mod-a) "p"))))
+($check-error ($fresh ($import-library! (#:except (mod-a) #:p))))
+($check-error ($import-library! (#:except (mod-a))))
+
+($check equal? ($fresh ($import-library! (#:prefix (mod-a) a-)) a-p) 1)
+($check equal? ($fresh ($import-library! (#:prefix (mod-a) a-)) a-q) 2)
+($check-error ($fresh ($import-library! (#:prefix (mod-a) a-)) a-r))
+($check-error ($fresh ($import-library! (#:prefix (mod-a) a-)) p))
+($check-error ($fresh ($import-library! (#:prefix (mod-a) a-)) q))
+($check-error ($fresh ($import-library! (#:prefix (mod-a) a- b-))))
+($check-error ($fresh ($import-library! (#:prefix (mod-a) "a"))))
+($check-error ($fresh ($import-library! (#:prefix (mod-a) #:a))))
+($check-error ($fresh ($import-library! (#:prefix (mod-a)))))
+
+($check equal? ($fresh ($import-library! (#:rename (mod-a) (p pp))) pp) 1)
+($check equal? ($fresh ($import-library! (#:rename (mod-a) (p pp))) q) 2)
+($check equal? ($fresh ($import-library! (#:rename (mod-a) (p q) (q p))) p) 2)
+($check equal? ($fresh ($import-library! (#:rename (mod-a) (p q) (q p))) q) 1)
+($check-error ($fresh ($import-library! (#:rename (mod-a) (p pp))) r))
+($check-error ($fresh ($import-library! (#:rename (mod-a) (1 2)))))
+($check-error ($fresh ($import-library! (#:rename (mod-a) p))))
+($check-error ($fresh ($import-library! (#:rename (mod-a)))))
+($check-error ($fresh ($import-library! (#:rename (mod-a) (p q))) r))
+
+($check equal? ($fresh ($import-library! (#:only (mod-b 1 2 x) u)) u) 4)
+($check equal? ($fresh ($import-library! (#:only (mod-b 1 2 x) p)) p) 1)
+($check equal? ($fresh ($import-library! (#:only (mod-b 1 2 x) w)) w) 5)
+($check-error ($fresh ($import-library! (#:only (mod-b 1 2 x) v))))
+
+($check equal?
+ ($fresh ($import-library! (#:only (mod-b 1 2 x) u) (#:only (mod-a) q)) q)
+ 2)
+
+($check equal?
+ ($fresh
+ ($import-library!
+ (#:rename (#:rename (#:rename (mod-a) (p p1)) (p1 p2)) (p2 p3)))
+ p3)
+ 1)
+
+($check equal?
+ ($fresh
+ ($import-library! (#:prefix (#:only (#:rename (mod-a) (q z)) z) p-))
+ p-z)
+ 2)
+
+($check equal?
+ ($fresh
+ ($import-library! (#:rename (#:except (mod-a) p) (q r)))
+ r)
+ 2)
+
+($check-error ($import-library! ((mod-a))))
+($check-error ($import-library! (#:only ((mod-a)) a)))
+($check-error ($import-library! (#:prefix bad prefix)))
+($check-error ($import-library! (#:replace (mod-a))))
+
+($check-error ($import-library! (mod-a) (mod-d)))
+($check-no-error ($fresh ($import-library! (#:only (mod-a) p) (#:only (mod-d) q))))
+($check-no-error ($fresh ($import-library! (#:only (mod-a) q) (#:only (mod-d) q))))
+
+;; XXX library? make-library get-library-export-list get-library-environment
+
+($check-predicate
+ (applicative?
+ library? make-library get-library-export-list get-library-environment))
+
+($check-predicate (library?))
+($check-not-predicate (library? ()))
+($check-not-predicate (library? "x"))
+
+($check-predicate
+ (library?
+ ($get-registered-library (mod-a))
+ ($get-registered-library (mod-b 1 2 x))
+ ($get-registered-library (mod-c))))
+
+($check equal?
+ (get-library-export-list ($get-registered-library (mod-a)))
+ ($quote (p q)))
+($check equal?
+ (get-library-export-list ($get-registered-library (mod-b 1 2 x)))
+ ($quote (p u w)))
+($check equal?
+ (get-library-export-list ($get-registered-library (mod-c)))
+ ())
+
+($check equal?
+ ($let ((env (get-library-environment ($get-registered-library (mod-a)))))
+ (list
+ ($binds? env p)
+ ($binds? env q)
+ ($binds? env r)
+ ($binds? env $lambda)))
+ (list #t #t #f #f))
+
+($check equal?
+ ($let ((m (make-library ())))
+ (list
+ (library? m)
+ (null? (get-library-export-list m))
+ (environment? (get-library-environment m))))
+ (list #t #t #t))
+
+($check equal?
+ ($let ((m (make-library (list (cons ($quote a) 1)))))
+ (list
+ (library? m)
+ (get-library-export-list m)
+ ($remote-eval a (get-library-environment m))))
+ (list #t (list ($quote a)) 1))
+
+($check-error
+ (make-library
+ (list
+ (list ($quote a) 1)
+ (list ($quote a) 2))))
+
+;; XXX $registered-library?
+
+($check-predicate (operative? $registered-library?))
+($check-predicate ($registered-library? (mod-a)))
+($check-predicate ($registered-library? (mod-b 1 2 x)))
+($check-predicate ($registered-library? (mod-c)))
+($check-predicate ($registered-library? (mod-d)))
+($check-predicate ($registered-library? (mod-e)))
+($check-not-predicate ($registered-library? (mod-f)))
+($check-error ($registered-library? "abc"))
+($check-error ($registered-library?))
+($check-error ($registered-library? (mod-a) (mod-b)))
+
+;; XXX $get-registered-library
+
+($check-predicate (operative? $get-registered-library))
+($check-no-error ($get-registered-library (mod-a)))
+($check-error ($get-registered-library (mod-f)))
+($check-error ($get-registered-library))
+($check-error ($get-registered-library (mod-a) (mod-c)))
+
+;; $register-library!
+
+($check-predicate (operative? $register-library!))
+($check-no-error
+ ($register-library!
+ (mod-z) (make-library (list (cons ($quote z) #:z)))))
+($check equal?
+ ($let ((m ($get-registered-library (mod-z))))
+ (list
+ (library? m)
+ (get-library-export-list m)
+ ($remote-eval z (get-library-environment m))))
+ (list #t (list ($quote z)) #:z))
+($check equal? ($fresh ($import-library! (mod-z)) z) #:z)
+
+($check-error ($register-library! badname (make-library ())))
+($check-error ($register-library! (mod-q) ()))
+($check-not-predicate ($registered-library? (mod-q)))
+
+;; XXX $unregister-library!
+
+($check-predicate (operative? $unregister-library!))
+($check-no-error ($unregister-library! (mod-z)))
+($check-not-predicate ($registered-library? (mod-z)))
+($check-predicate ($registered-library? (mod-b 1 2 x)))
+($check-no-error ($unregister-library! (mod-b 1 2 x)))
+($check-not-predicate ($registered-library? (mod-z)))
+($check-not-predicate ($registered-library? (mod-b 1 2 x)))
+($check-error ($unregister-library! (mod-nonexistent)))
+($check-error ($unregister-library! badname))
+
+;; cleanup - unregister remaining testing libraries
+
+($check-no-error ($unregister-library! (mod-a)))
+($check-no-error ($unregister-library! (mod-c)))
+($check-no-error ($unregister-library! (mod-d)))
+($check-no-error ($unregister-library! (mod-e)))
diff --git a/src/tests/modules.k b/src/tests/modules.k
@@ -1,265 +0,0 @@
-;; check.k & test-helpers.k should be loaded
-;;
-;; Tests of module system.
-;;
-
-;; N.B. Module registry is a hidden global variable. Module imports
-;; work anywhere in environment or continuation hierarchy.
-;;
-;; ($fresh A1 A2 ..) evaluates A1 A2... in a fresh environment.
-;;
-($define! $fresh
- ($vau args #ignore
- (eval (list* $sequence args) (make-kernel-standard-environment))))
-
-;; XXX $provide-module! $import-module!
-
-($check-predicate (operative? $provide-module!))
-($check-predicate (operative? $import-module!))
-
-($check-no-error
- ($provide-module! (mod-a) (#:export p q)
- ($define! p 1)
- ($define! q 2)
- ($define! r 3)))
-
-($check-error mod-a)
-($check-error p)
-($check-error q)
-($check-error r)
-
-($check-no-error
- ($provide-module! (mod-b 1 2 x) (#:export p u (#:rename v w))
- ($import-module! (#:only (mod-a) p))
- ($define! u 4)
- ($define! v 5)))
-
-($check-error mod-b)
-($check-error p)
-($check-error u)
-
-($check-no-error
- ($provide-module! (mod-c) (#:export)
- ($define! w 6)))
-
-($check-no-error
- ($provide-module! (mod-d) (#:export p q)
- ($define! p 7)
- ($define! q 2)))
-
-($check-error w)
-
-($check-no-error ($provide-module! (mod-e) (#:export)))
-
-($check-error ($provide-module! (mod-a) (#:export) 1))
-($check-error ($provide-module! () (#:export)))
-($check-error ($provide-module! (mod-q) (a) ($define! a 1)))
-($check-error ($provide-module! (mod-q) (#:export #:a) ($define! a 1)))
-($check-error ($provide-module! (mod-q) (#:export a a) ($define! a 1)))
-($check-error ($provide-module! (mod-q) (#:export (a b)) ($define! a 1)))
-($check-error ($provide-module! (mod-q) (#:export (#:re-na-me a b)) ($define! a 1)))
-($check-error ($provide-module! (mod-q) (#:export (#:rename b a)) ($define! a 1)))
-($check-error ($provide-module! (mod-q) (#:export (#:rename a)) ($define! a 1)))
-($check-error ($provide-module! (mod-q) (#:export (#:rename a 2)) ($define! a 1)))
-($check-error ($provide-module! (mod-q) 1))
-($check-error ($provide-module! (mod-q) 1 (#:export)))
-($check-not-predicate ($registered-module? (mod-q)))
-
-($check equal? ($fresh ($import-module! (mod-a)) p) 1)
-($check equal? ($fresh ($import-module! (mod-a)) q) 2)
-($check-error ($fresh ($import-module! (mod-a)) r))
-
-($check equal? ($fresh ($import-module! (#:only (mod-a) p)) p) 1)
-($check equal? ($fresh ($import-module! (#:only (mod-a) q)) q) 2)
-($check equal? ($fresh ($import-module! (#:only (mod-a) p q)) p) 1)
-($check equal? ($fresh ($import-module! (#:only (mod-a) p q)) q) 2)
-($check-error ($fresh ($import-module! (#:only (mod-a) p)) q))
-($check-error ($fresh ($import-module! (#:only (mod-a) q)) p))
-($check-error ($fresh ($import-module! (#:only (mod-a) r))))
-($check-error ($fresh ($import-module! (#:only (mod-a) p p))))
-($check-error ($fresh ($import-module! (#:only (mod-a) "p"))))
-($check-error ($fresh ($import-module! (#:only (mod-a) #:p))))
-($check-error ($import-module! (#:only (mod-a))))
-
-($check equal? ($fresh ($import-module! (#:except (mod-a) p)) q) 2)
-($check equal? ($fresh ($import-module! (#:except (mod-a) q)) p) 1)
-($check-error ($fresh ($import-module! (#:except (mod-a) p q)) p))
-($check-error ($fresh ($import-module! (#:except (mod-a) p)) r))
-($check-error ($fresh ($import-module! (#:except (mod-a) r))))
-($check-error ($fresh ($import-module! (#:except (mod-a) p p))))
-($check-error ($fresh ($import-module! (#:except (mod-a) "p"))))
-($check-error ($fresh ($import-module! (#:except (mod-a) #:p))))
-($check-error ($import-module! (#:except (mod-a))))
-
-($check equal? ($fresh ($import-module! (#:prefix (mod-a) a-)) a-p) 1)
-($check equal? ($fresh ($import-module! (#:prefix (mod-a) a-)) a-q) 2)
-($check-error ($fresh ($import-module! (#:prefix (mod-a) a-)) a-r))
-($check-error ($fresh ($import-module! (#:prefix (mod-a) a-)) p))
-($check-error ($fresh ($import-module! (#:prefix (mod-a) a-)) q))
-($check-error ($fresh ($import-module! (#:prefix (mod-a) a- b-))))
-($check-error ($fresh ($import-module! (#:prefix (mod-a) "a"))))
-($check-error ($fresh ($import-module! (#:prefix (mod-a) #:a))))
-($check-error ($fresh ($import-module! (#:prefix (mod-a)))))
-
-($check equal? ($fresh ($import-module! (#:rename (mod-a) (p pp))) pp) 1)
-($check equal? ($fresh ($import-module! (#:rename (mod-a) (p pp))) q) 2)
-($check equal? ($fresh ($import-module! (#:rename (mod-a) (p q) (q p))) p) 2)
-($check equal? ($fresh ($import-module! (#:rename (mod-a) (p q) (q p))) q) 1)
-($check-error ($fresh ($import-module! (#:rename (mod-a) (p pp))) r))
-($check-error ($fresh ($import-module! (#:rename (mod-a) (1 2)))))
-($check-error ($fresh ($import-module! (#:rename (mod-a) p))))
-($check-error ($fresh ($import-module! (#:rename (mod-a)))))
-($check-error ($fresh ($import-module! (#:rename (mod-a) (p q))) r))
-
-($check equal? ($fresh ($import-module! (#:only (mod-b 1 2 x) u)) u) 4)
-($check equal? ($fresh ($import-module! (#:only (mod-b 1 2 x) p)) p) 1)
-($check equal? ($fresh ($import-module! (#:only (mod-b 1 2 x) w)) w) 5)
-($check-error ($fresh ($import-module! (#:only (mod-b 1 2 x) v))))
-
-($check equal?
- ($fresh ($import-module! (#:only (mod-b 1 2 x) u) (#:only (mod-a) q)) q)
- 2)
-
-($check equal?
- ($fresh
- ($import-module!
- (#:rename (#:rename (#:rename (mod-a) (p p1)) (p1 p2)) (p2 p3)))
- p3)
- 1)
-
-($check equal?
- ($fresh
- ($import-module! (#:prefix (#:only (#:rename (mod-a) (q z)) z) p-))
- p-z)
- 2)
-
-($check equal?
- ($fresh
- ($import-module! (#:rename (#:except (mod-a) p) (q r)))
- r)
- 2)
-
-($check-error ($import-module! ((mod-a))))
-($check-error ($import-module! (#:only ((mod-a)) a)))
-($check-error ($import-module! (#:prefix bad prefix)))
-($check-error ($import-module! (#:replace (mod-a))))
-
-($check-error ($import-module! (mod-a) (mod-d)))
-($check-no-error ($fresh ($import-module! (#:only (mod-a) p) (#:only (mod-d) q))))
-($check-no-error ($fresh ($import-module! (#:only (mod-a) q) (#:only (mod-d) q))))
-
-;; XXX module? make-module get-module-export-list get-module-environment
-
-($check-predicate
- (applicative?
- module? make-module get-module-export-list get-module-environment))
-
-($check-predicate (module?))
-($check-not-predicate (module? ()))
-($check-not-predicate (module? "x"))
-
-($check-predicate
- (module?
- ($get-registered-module (mod-a))
- ($get-registered-module (mod-b 1 2 x))
- ($get-registered-module (mod-c))))
-
-($check equal?
- (get-module-export-list ($get-registered-module (mod-a)))
- ($quote (p q)))
-($check equal?
- (get-module-export-list ($get-registered-module (mod-b 1 2 x)))
- ($quote (p u w)))
-($check equal?
- (get-module-export-list ($get-registered-module (mod-c)))
- ())
-
-($check equal?
- ($let ((env (get-module-environment ($get-registered-module (mod-a)))))
- (list
- ($binds? env p)
- ($binds? env q)
- ($binds? env r)
- ($binds? env $lambda)))
- (list #t #t #f #f))
-
-($check equal?
- ($let ((m (make-module ())))
- (list
- (module? m)
- (null? (get-module-export-list m))
- (environment? (get-module-environment m))))
- (list #t #t #t))
-
-($check equal?
- ($let ((m (make-module (list (cons ($quote a) 1)))))
- (list
- (module? m)
- (get-module-export-list m)
- ($remote-eval a (get-module-environment m))))
- (list #t (list ($quote a)) 1))
-
-($check-error
- (make-module
- (list
- (list ($quote a) 1)
- (list ($quote a) 2))))
-
-;; XXX $registered-module?
-
-($check-predicate (operative? $registered-module?))
-($check-predicate ($registered-module? (mod-a)))
-($check-predicate ($registered-module? (mod-b 1 2 x)))
-($check-predicate ($registered-module? (mod-c)))
-($check-predicate ($registered-module? (mod-d)))
-($check-predicate ($registered-module? (mod-e)))
-($check-not-predicate ($registered-module? (mod-f)))
-($check-error ($registered-module? "abc"))
-($check-error ($registered-module?))
-($check-error ($registered-module? (mod-a) (mod-b)))
-
-;; XXX $get-registered-module
-
-($check-predicate (operative? $get-registered-module))
-($check-no-error ($get-registered-module (mod-a)))
-($check-error ($get-registered-module (mod-f)))
-($check-error ($get-registered-module))
-($check-error ($get-registered-module (mod-a) (mod-c)))
-
-;; $register-module!
-
-($check-predicate (operative? $register-module!))
-($check-no-error
- ($register-module!
- (mod-z) (make-module (list (cons ($quote z) #:z)))))
-($check equal?
- ($let ((m ($get-registered-module (mod-z))))
- (list
- (module? m)
- (get-module-export-list m)
- ($remote-eval z (get-module-environment m))))
- (list #t (list ($quote z)) #:z))
-($check equal? ($fresh ($import-module! (mod-z)) z) #:z)
-
-($check-error ($register-module! badname (make-module ())))
-($check-error ($register-module! (mod-q) ()))
-($check-not-predicate ($registered-module? (mod-q)))
-
-;; XXX $unregister-module!
-
-($check-predicate (operative? $unregister-module!))
-($check-no-error ($unregister-module! (mod-z)))
-($check-not-predicate ($registered-module? (mod-z)))
-($check-predicate ($registered-module? (mod-b 1 2 x)))
-($check-no-error ($unregister-module! (mod-b 1 2 x)))
-($check-not-predicate ($registered-module? (mod-z)))
-($check-not-predicate ($registered-module? (mod-b 1 2 x)))
-($check-error ($unregister-module! (mod-nonexistent)))
-($check-error ($unregister-module! badname))
-
-;; cleanup - unregister remaining testing modules
-
-($check-no-error ($unregister-module! (mod-a)))
-($check-no-error ($unregister-module! (mod-c)))
-($check-no-error ($unregister-module! (mod-d)))
-($check-no-error ($unregister-module! (mod-e)))
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -28,6 +28,6 @@
(load "tests/vectors.k")
(load "tests/system.k")
(load "tests/keywords.k")
-(load "tests/modules.k")
+(load "tests/libraries.k")
(check-report)
