picrin/lib.c

350 lines
7.7 KiB
C
Raw Normal View History

2014-08-25 00:38:09 -04:00
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/lib.h"
#include "picrin/pair.h"
#include "picrin/macro.h"
#include "picrin/error.h"
#include "picrin/string.h"
#include "picrin/proc.h"
2014-08-25 00:38:09 -04:00
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;
struct pic_senv *senv;
if ((lib = pic_find_library(pic, name)) != NULL) {
#if DEBUG
printf("* reopen library: ");
pic_debug(pic, name);
puts("");
#endif
return lib;
}
senv = pic_null_syntactic_environment(pic);
lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
lib->env = senv;
lib->name = name;
xh_init_int(&lib->exports, sizeof(pic_sym));
/* 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
import_table(pic_state *pic, pic_value spec, xhash *imports)
2014-08-25 00:38:09 -04:00
{
struct pic_lib *lib;
2014-09-14 23:32:20 -04:00
xhash table;
pic_value val;
2014-09-16 02:02:47 -04:00
pic_sym sym, id, tag;
2014-09-16 03:44:44 -04:00
xh_entry *it;
2014-08-25 00:38:09 -04:00
2014-09-14 23:32:20 -04:00
xh_init_int(&table, sizeof(pic_sym));
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))) {
tag = pic_sym(pic_car(pic, spec));
if (tag == pic->sONLY) {
2014-09-14 23:32:20 -04:00
import_table(pic, pic_cadr(pic, spec), &table);
2014-08-25 00:38:09 -04:00
pic_for_each (val, pic_cddr(pic, spec)) {
2014-09-14 23:32:20 -04:00
xh_put_int(imports, pic_sym(val), &xh_val(xh_get_int(&table, pic_sym(val)), pic_sym));
2014-08-25 00:38:09 -04:00
}
2014-09-14 23:32:20 -04:00
goto exit;
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);
2014-08-25 00:38:09 -04:00
pic_for_each (val, pic_cddr(pic, spec)) {
2014-09-14 23:32:20 -04:00
id = xh_val(xh_get_int(imports, pic_sym(pic_car(pic, val))), pic_sym);
xh_del_int(imports, pic_sym(pic_car(pic, val)));
xh_put_int(imports, pic_sym(pic_cadr(pic, val)), &id);
2014-08-25 00:38:09 -04:00
}
2014-09-14 23:32:20 -04:00
goto exit;
2014-08-25 00:38:09 -04:00
}
2014-09-16 02:02:47 -04:00
if (tag == pic->sPREFIX) {
2014-09-14 23:32:20 -04:00
import_table(pic, pic_cadr(pic, spec), &table);
2014-09-16 03:44:44 -04:00
for (it = xh_begin(&table); it != NULL; it = xh_next(it)) {
2014-08-26 00:30:34 -04:00
val = pic_list_ref(pic, spec, 2);
2014-09-16 03:44:44 -04:00
sym = pic_intern_str(pic, pic_format(pic, "~s~s", val, pic_sym_value(xh_key(it, pic_sym))));
xh_put_int(imports, sym, &xh_val(it, pic_sym));
2014-08-25 00:38:09 -04:00
}
2014-09-14 23:32:20 -04:00
goto exit;
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);
2014-08-25 00:38:09 -04:00
pic_for_each (val, pic_cddr(pic, spec)) {
2014-09-14 23:32:20 -04:00
xh_del_int(imports, pic_sym(val));
2014-08-25 00:38:09 -04:00
}
2014-09-14 23:32:20 -04:00
goto exit;
2014-08-25 00:38:09 -04:00
}
}
lib = pic_find_library(pic, spec);
if (! lib) {
pic_errorf(pic, "library not found: ~a", spec);
}
2014-09-16 03:44:44 -04:00
for (it = xh_begin(&lib->exports); it != NULL; it = xh_next(it)) {
xh_put_int(imports, xh_key(it, pic_sym), &xh_val(it, pic_sym));
2014-08-25 00:38:09 -04:00
}
2014-09-14 23:32:20 -04:00
exit:
xh_destroy(&table);
2014-08-25 00:38:09 -04:00
}
static void
import(pic_state *pic, pic_value spec)
{
2014-09-14 23:32:20 -04:00
xhash imports;
2014-09-16 03:44:44 -04:00
xh_entry *it;
2014-08-25 00:38:09 -04:00
2014-09-14 23:32:20 -04:00
xh_init_int(&imports, sizeof(pic_sym)); /* pic_sym to pic_sym */
import_table(pic, spec, &imports);
2014-08-25 00:38:09 -04:00
2014-09-16 03:44:44 -04:00
for (it = xh_begin(&imports); it != NULL; it = xh_next(it)) {
2014-08-25 00:38:09 -04:00
2014-09-14 23:34:57 -04:00
#if DEBUG
2014-09-16 03:44:44 -04:00
printf("* importing %s as %s\n", pic_symbol_name(pic, xh_key(it, pic_sym)), pic_symbol_name(pic, xh_val(it, pic_sym)));
2014-08-25 00:38:09 -04:00
#endif
2014-09-16 03:44:44 -04:00
pic_put_rename(pic, pic->lib->env, xh_key(it, pic_sym), xh_val(it, pic_sym));
2014-08-25 00:38:09 -04:00
}
2014-09-14 23:32:20 -04:00
xh_destroy(&imports);
2014-08-25 00:38:09 -04:00
}
static void
export(pic_state *pic, pic_value spec)
{
const pic_sym sRENAME = pic_intern_cstr(pic, "rename");
pic_value a, b;
pic_sym rename;
if (pic_sym_p(spec)) { /* (export a) */
a = b = spec;
} else { /* (export (rename a b)) */
if (! pic_list_p(spec))
goto fail;
if (! pic_length(pic, spec) == 3)
goto fail;
if (! pic_eq_p(pic_car(pic, spec), pic_sym_value(sRENAME)))
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;
}
if (! pic_find_rename(pic, pic->lib->env, pic_sym(a), &rename)) {
pic_errorf(pic, "export: symbol not defined %s", pic_symbol_name(pic, pic_sym(a)));
}
#if DEBUG
printf("* exporting %s as %s\n", pic_symbol_name(pic, pic_sym(b)), pic_symbol_name(pic, rename));
#endif
xh_put_int(&pic->lib->exports, pic_sym(b), &rename);
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
pic_export(pic_state *pic, pic_sym sym)
{
export(pic, pic_sym_value(sym));
}
2014-09-09 13:08:58 -04:00
static bool
condexpand(pic_state *pic, pic_value clause)
{
2014-09-09 13:08:58 -04:00
pic_sym tag;
pic_value c, feature;
2014-09-16 02:02:47 -04:00
if (pic_eq_p(clause, pic_sym_value(pic->sELSE))) {
return true;
2014-09-09 13:08:58 -04:00
}
if (pic_sym_p(clause)) {
pic_for_each (feature, pic->features) {
if(pic_eq_p(feature, clause))
return true;
}
return false;
}
if (! (pic_pair_p(clause) && pic_sym_p(pic_car(pic, clause)))) {
pic_errorf(pic, "invalid 'cond-expand' clause ~s", clause);
2014-09-09 13:08:58 -04:00
} else {
tag = pic_sym(pic_car(pic, clause));
}
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) {
2014-09-09 13:08:58 -04:00
pic_for_each (c, pic_cdr(pic, clause)) {
if (! condexpand(pic, c))
return false;
}
return true;
}
2014-09-16 02:02:47 -04:00
if (tag == pic->sOR) {
2014-09-09 13:08:58 -04:00
pic_for_each (c, pic_cdr(pic, clause)) {
if (condexpand(pic, c))
return true;
}
return false;
}
2014-09-09 13:08:58 -04:00
pic_errorf(pic, "unknown 'cond-expand' directive ~s", clause);
}
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]))) {
return pic_cons(pic, pic_sym_value(pic->rBEGIN), pic_cdr(pic, clauses[i]));
2014-09-09 13:08:58 -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)
{
void pic_defmacro(pic_state *, pic_sym, pic_sym, pic_func_t);
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);
}