2014-08-25 00:38:09 -04:00
|
|
|
/**
|
|
|
|
* See Copyright Notice in picrin.h
|
|
|
|
*/
|
|
|
|
|
|
|
|
#include "picrin.h"
|
|
|
|
|
|
|
|
struct pic_lib *
|
2014-09-01 00:07:38 -04:00
|
|
|
pic_open_library(pic_state *pic, pic_value name)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
|
|
|
struct pic_lib *lib;
|
2015-05-30 09:39:03 -04:00
|
|
|
struct pic_env *env;
|
2015-01-18 07:32:16 -05:00
|
|
|
struct pic_dict *exports;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
if ((lib = pic_find_library(pic, name)) != NULL) {
|
|
|
|
|
|
|
|
#if DEBUG
|
|
|
|
printf("* reopen library: ");
|
|
|
|
pic_debug(pic, name);
|
|
|
|
puts("");
|
|
|
|
#endif
|
|
|
|
|
|
|
|
return lib;
|
|
|
|
}
|
|
|
|
|
2015-05-30 09:39:03 -04:00
|
|
|
env = pic_null_syntactic_environment(pic);
|
2015-01-18 07:32:16 -05:00
|
|
|
exports = pic_make_dict(pic);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
|
|
|
|
lib->name = name;
|
2015-05-30 09:39:03 -04:00
|
|
|
lib->env = env;
|
2015-01-18 07:32:16 -05:00
|
|
|
lib->exports = exports;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
/* register! */
|
|
|
|
pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs);
|
|
|
|
|
|
|
|
return lib;
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_in_library(pic_state *pic, pic_value spec)
|
|
|
|
{
|
|
|
|
struct pic_lib *lib;
|
|
|
|
|
|
|
|
lib = pic_find_library(pic, spec);
|
|
|
|
if (! lib) {
|
|
|
|
pic_errorf(pic, "library not found: ~a", spec);
|
|
|
|
}
|
|
|
|
pic->lib = lib;
|
|
|
|
}
|
|
|
|
|
|
|
|
struct pic_lib *
|
|
|
|
pic_find_library(pic_state *pic, pic_value spec)
|
|
|
|
{
|
|
|
|
pic_value v;
|
|
|
|
|
|
|
|
v = pic_assoc(pic, spec, pic->libs, NULL);
|
|
|
|
if (pic_false_p(v)) {
|
|
|
|
return NULL;
|
|
|
|
}
|
|
|
|
return pic_lib_ptr(pic_cdr(pic, v));
|
|
|
|
}
|
|
|
|
|
2014-09-14 23:32:20 -04:00
|
|
|
static void
|
2015-01-18 07:55:17 -05:00
|
|
|
import_table(pic_state *pic, pic_value spec, struct pic_dict *imports)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
|
|
|
struct pic_lib *lib;
|
2015-01-18 07:55:17 -05:00
|
|
|
struct pic_dict *table;
|
2015-01-22 05:28:31 -05:00
|
|
|
pic_value val, tmp, prefix, it;
|
2015-01-20 02:02:28 -05:00
|
|
|
pic_sym *sym, *id, *tag;
|
2015-01-22 05:33:42 -05:00
|
|
|
xh_entry *iter;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2015-01-18 07:55:17 -05:00
|
|
|
table = pic_make_dict(pic);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2014-09-16 02:02:47 -04:00
|
|
|
if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) {
|
|
|
|
|
2015-01-20 01:31:17 -05:00
|
|
|
tag = pic_sym_ptr(pic_car(pic, spec));
|
2014-09-16 02:02:47 -04:00
|
|
|
|
|
|
|
if (tag == pic->sONLY) {
|
2015-01-18 07:55:17 -05:00
|
|
|
import_table(pic, pic_cadr(pic, spec), table);
|
|
|
|
|
2015-01-22 05:28:31 -05:00
|
|
|
pic_for_each (val, pic_cddr(pic, spec), it) {
|
2015-01-20 01:31:17 -05:00
|
|
|
pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val)));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2015-01-18 07:55:17 -05:00
|
|
|
return;
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2014-09-16 02:02:47 -04:00
|
|
|
if (tag == pic->sRENAME) {
|
2014-09-14 23:32:20 -04:00
|
|
|
import_table(pic, pic_cadr(pic, spec), imports);
|
2015-01-18 07:55:17 -05:00
|
|
|
|
2015-01-22 05:28:31 -05:00
|
|
|
pic_for_each (val, pic_cddr(pic, spec), it) {
|
2015-01-20 01:31:17 -05:00
|
|
|
tmp = pic_dict_ref(pic, imports, pic_sym_ptr(pic_car(pic, val)));
|
|
|
|
pic_dict_del(pic, imports, pic_sym_ptr(pic_car(pic, val)));
|
|
|
|
pic_dict_set(pic, imports, pic_sym_ptr(pic_cadr(pic, val)), tmp);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2015-01-18 07:55:17 -05:00
|
|
|
return;
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2014-09-16 02:02:47 -04:00
|
|
|
if (tag == pic->sPREFIX) {
|
2015-01-18 07:55:17 -05:00
|
|
|
import_table(pic, pic_cadr(pic, spec), table);
|
|
|
|
|
|
|
|
prefix = pic_list_ref(pic, spec, 2);
|
2015-01-22 05:33:42 -05:00
|
|
|
pic_dict_for_each (sym, table, iter) {
|
2015-01-18 21:08:27 -05:00
|
|
|
id = pic_intern(pic, pic_format(pic, "~s~s", prefix, pic_obj_value(sym)));
|
2015-01-18 07:55:17 -05:00
|
|
|
pic_dict_set(pic, imports, id, pic_dict_ref(pic, table, sym));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2015-01-18 07:55:17 -05:00
|
|
|
return;
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2014-09-16 02:02:47 -04:00
|
|
|
if (tag == pic->sEXCEPT) {
|
2014-09-14 23:32:20 -04:00
|
|
|
import_table(pic, pic_cadr(pic, spec), imports);
|
2015-01-22 05:28:31 -05:00
|
|
|
pic_for_each (val, pic_cddr(pic, spec), it) {
|
2015-01-20 01:31:17 -05:00
|
|
|
pic_dict_del(pic, imports, pic_sym_ptr(val));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2015-01-18 07:55:17 -05:00
|
|
|
return;
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
lib = pic_find_library(pic, spec);
|
|
|
|
if (! lib) {
|
|
|
|
pic_errorf(pic, "library not found: ~a", spec);
|
|
|
|
}
|
2015-01-22 05:33:42 -05:00
|
|
|
pic_dict_for_each (sym, lib->exports, iter) {
|
2015-01-18 07:55:17 -05:00
|
|
|
pic_dict_set(pic, imports, sym, pic_dict_ref(pic, lib->exports, sym));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
static void
|
|
|
|
import(pic_state *pic, pic_value spec)
|
|
|
|
{
|
2015-01-18 07:55:17 -05:00
|
|
|
struct pic_dict *imports;
|
2015-01-20 02:02:28 -05:00
|
|
|
pic_sym *sym;
|
2015-01-22 05:33:42 -05:00
|
|
|
xh_entry *it;
|
2014-09-14 23:32:20 -04:00
|
|
|
|
2015-01-18 07:55:17 -05:00
|
|
|
imports = pic_make_dict(pic);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2015-01-18 07:55:17 -05:00
|
|
|
import_table(pic, spec, imports);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2015-01-22 05:33:42 -05:00
|
|
|
pic_dict_for_each (sym, imports, it) {
|
2015-01-20 01:31:17 -05:00
|
|
|
pic_put_rename(pic, pic->lib->env, sym, pic_sym_ptr(pic_dict_ref(pic, imports, sym)));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
static void
|
|
|
|
export(pic_state *pic, pic_value spec)
|
|
|
|
{
|
2015-01-20 02:02:28 -05:00
|
|
|
pic_sym *sRENAME = pic_intern_cstr(pic, "rename");
|
2014-08-25 00:38:09 -04:00
|
|
|
pic_value a, b;
|
2015-01-20 02:02:28 -05:00
|
|
|
pic_sym *rename;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
if (pic_sym_p(spec)) { /* (export a) */
|
|
|
|
a = b = spec;
|
|
|
|
} else { /* (export (rename a b)) */
|
|
|
|
if (! pic_list_p(spec))
|
|
|
|
goto fail;
|
2014-09-19 05:28:55 -04:00
|
|
|
if (! (pic_length(pic, spec) == 3))
|
2014-08-25 00:38:09 -04:00
|
|
|
goto fail;
|
2015-01-18 21:08:27 -05:00
|
|
|
if (! pic_eq_p(pic_car(pic, spec), pic_obj_value(sRENAME)))
|
2014-08-25 00:38:09 -04:00
|
|
|
goto fail;
|
|
|
|
if (! pic_sym_p(a = pic_list_ref(pic, spec, 1)))
|
|
|
|
goto fail;
|
|
|
|
if (! pic_sym_p(b = pic_list_ref(pic, spec, 2)))
|
|
|
|
goto fail;
|
|
|
|
}
|
|
|
|
|
2015-01-20 01:31:17 -05:00
|
|
|
if (! pic_find_rename(pic, pic->lib->env, pic_sym_ptr(a), &rename)) {
|
|
|
|
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym_ptr(a)));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
#if DEBUG
|
2015-01-20 02:02:44 -05:00
|
|
|
printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym_ptr(b)), pic_symbol_name(pic, rename));
|
2014-08-25 00:38:09 -04:00
|
|
|
#endif
|
|
|
|
|
2015-01-20 01:31:17 -05:00
|
|
|
pic_dict_set(pic, pic->lib->exports, pic_sym_ptr(b), pic_obj_value(rename));
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
return;
|
|
|
|
|
|
|
|
fail:
|
|
|
|
pic_errorf(pic, "illegal export spec: ~s", spec);
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_import(pic_state *pic, pic_value spec)
|
|
|
|
{
|
|
|
|
import(pic, spec);
|
|
|
|
}
|
|
|
|
|
2014-09-14 05:14:23 -04:00
|
|
|
void
|
|
|
|
pic_import_library(pic_state *pic, struct pic_lib *lib)
|
|
|
|
{
|
|
|
|
import(pic, lib->name);
|
|
|
|
}
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
void
|
2015-01-20 02:02:28 -05:00
|
|
|
pic_export(pic_state *pic, pic_sym *sym)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
2015-01-18 21:08:27 -05:00
|
|
|
export(pic, pic_obj_value(sym));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
2014-09-09 13:08:58 -04:00
|
|
|
static bool
|
|
|
|
condexpand(pic_state *pic, pic_value clause)
|
2014-09-09 12:48:20 -04:00
|
|
|
{
|
2015-01-20 02:02:28 -05:00
|
|
|
pic_sym *tag;
|
2015-01-22 05:28:31 -05:00
|
|
|
pic_value c, feature, it;
|
2014-09-09 12:48:20 -04:00
|
|
|
|
2015-01-18 21:08:27 -05:00
|
|
|
if (pic_eq_p(clause, pic_obj_value(pic->sELSE))) {
|
2014-09-09 12:48:20 -04:00
|
|
|
return true;
|
2014-09-09 13:08:58 -04:00
|
|
|
}
|
|
|
|
if (pic_sym_p(clause)) {
|
2015-01-22 05:28:31 -05:00
|
|
|
pic_for_each (feature, pic->features, it) {
|
2014-09-09 13:08:58 -04:00
|
|
|
if(pic_eq_p(feature, clause))
|
|
|
|
return true;
|
|
|
|
}
|
|
|
|
return false;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) {
|
2014-09-09 12:48:20 -04:00
|
|
|
pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause);
|
2014-09-09 13:08:58 -04:00
|
|
|
} else {
|
2015-01-20 01:31:17 -05:00
|
|
|
tag = pic_sym_ptr(pic_car(pic, clause));
|
2014-09-09 13:08:58 -04:00
|
|
|
}
|
|
|
|
|
2014-09-16 02:02:47 -04:00
|
|
|
if (tag == pic->sLIBRARY) {
|
2014-09-09 13:08:58 -04:00
|
|
|
return pic_find_library(pic, pic_list_ref(pic, clause, 1)) != NULL;
|
|
|
|
}
|
2014-09-16 02:02:47 -04:00
|
|
|
if (tag == pic->sNOT) {
|
2014-09-09 13:08:58 -04:00
|
|
|
return ! condexpand(pic, pic_list_ref(pic, clause, 1));
|
|
|
|
}
|
2014-09-16 02:02:47 -04:00
|
|
|
if (tag == pic->sAND) {
|
2015-01-22 05:28:31 -05:00
|
|
|
pic_for_each (c, pic_cdr(pic, clause), it) {
|
2014-09-09 13:08:58 -04:00
|
|
|
if (! condexpand(pic, c))
|
|
|
|
return false;
|
|
|
|
}
|
|
|
|
return true;
|
|
|
|
}
|
2014-09-16 02:02:47 -04:00
|
|
|
if (tag == pic->sOR) {
|
2015-01-22 05:28:31 -05:00
|
|
|
pic_for_each (c, pic_cdr(pic, clause), it) {
|
2014-09-09 13:08:58 -04:00
|
|
|
if (condexpand(pic, c))
|
|
|
|
return true;
|
|
|
|
}
|
2014-09-09 12:48:20 -04:00
|
|
|
return false;
|
|
|
|
}
|
2014-09-09 13:08:58 -04:00
|
|
|
|
|
|
|
pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause);
|
2014-09-09 12:48:20 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
static pic_value
|
|
|
|
pic_lib_condexpand(pic_state *pic)
|
|
|
|
{
|
|
|
|
pic_value *clauses;
|
|
|
|
size_t argc, i;
|
|
|
|
|
|
|
|
pic_get_args(pic, "*", &argc, &clauses);
|
|
|
|
|
2014-09-09 13:08:58 -04:00
|
|
|
for (i = 0; i < argc; i++) {
|
|
|
|
if (condexpand(pic, pic_car(pic, clauses[i]))) {
|
2015-01-18 21:08:27 -05:00
|
|
|
return pic_cons(pic, pic_obj_value(pic->rBEGIN), pic_cdr(pic, clauses[i]));
|
2014-09-09 13:08:58 -04:00
|
|
|
}
|
|
|
|
}
|
2014-09-09 12:48:20 -04:00
|
|
|
|
|
|
|
return pic_none_value();
|
|
|
|
}
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
static pic_value
|
|
|
|
pic_lib_import(pic_state *pic)
|
|
|
|
{
|
|
|
|
size_t argc, i;
|
|
|
|
pic_value *argv;
|
|
|
|
|
|
|
|
pic_get_args(pic, "*", &argc, &argv);
|
|
|
|
|
|
|
|
for (i = 0; i < argc; ++i) {
|
|
|
|
import(pic, argv[i]);
|
|
|
|
}
|
|
|
|
|
|
|
|
return pic_none_value();
|
|
|
|
}
|
|
|
|
|
|
|
|
static pic_value
|
|
|
|
pic_lib_export(pic_state *pic)
|
|
|
|
{
|
|
|
|
size_t argc, i;
|
|
|
|
pic_value *argv;
|
|
|
|
|
|
|
|
pic_get_args(pic, "*", &argc, &argv);
|
|
|
|
|
|
|
|
for (i = 0; i < argc; ++i) {
|
|
|
|
export(pic, argv[i]);
|
|
|
|
}
|
|
|
|
|
|
|
|
return pic_none_value();
|
|
|
|
}
|
|
|
|
|
|
|
|
static pic_value
|
|
|
|
pic_lib_define_library(pic_state *pic)
|
|
|
|
{
|
|
|
|
struct pic_lib *prev = pic->lib;
|
|
|
|
size_t argc, i;
|
|
|
|
pic_value spec, *argv;
|
|
|
|
|
|
|
|
pic_get_args(pic, "o*", &spec, &argc, &argv);
|
|
|
|
|
2014-09-01 00:07:38 -04:00
|
|
|
pic_open_library(pic, spec);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
pic_try {
|
|
|
|
pic_in_library(pic, spec);
|
|
|
|
|
|
|
|
for (i = 0; i < argc; ++i) {
|
|
|
|
pic_void(pic_eval(pic, argv[i], pic->lib));
|
|
|
|
}
|
|
|
|
|
|
|
|
pic_in_library(pic, prev->name);
|
|
|
|
}
|
|
|
|
pic_catch {
|
|
|
|
pic_in_library(pic, prev->name); /* restores pic->lib even if an error occurs */
|
2014-09-16 11:28:55 -04:00
|
|
|
pic_raise(pic, pic->err);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
return pic_none_value();
|
|
|
|
}
|
|
|
|
|
|
|
|
static pic_value
|
|
|
|
pic_lib_in_library(pic_state *pic)
|
|
|
|
{
|
|
|
|
pic_value spec;
|
|
|
|
|
|
|
|
pic_get_args(pic, "o", &spec);
|
|
|
|
|
|
|
|
pic_in_library(pic, spec);
|
|
|
|
|
|
|
|
return pic_none_value();
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_init_lib(pic_state *pic)
|
|
|
|
{
|
2015-01-20 02:02:28 -05:00
|
|
|
void pic_defmacro(pic_state *, pic_sym *, pic_sym *, pic_func_t);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2014-09-09 12:48:20 -04:00
|
|
|
pic_defmacro(pic, pic->sCOND_EXPAND, pic->rCOND_EXPAND, pic_lib_condexpand);
|
2014-08-25 00:38:09 -04:00
|
|
|
pic_defmacro(pic, pic->sIMPORT, pic->rIMPORT, pic_lib_import);
|
|
|
|
pic_defmacro(pic, pic->sEXPORT, pic->rEXPORT, pic_lib_export);
|
|
|
|
pic_defmacro(pic, pic->sDEFINE_LIBRARY, pic->rDEFINE_LIBRARY, pic_lib_define_library);
|
|
|
|
pic_defmacro(pic, pic->sIN_LIBRARY, pic->rIN_LIBRARY, pic_lib_in_library);
|
|
|
|
}
|