static environment_t* rename(environment_t* e, cons_t* ids)
{
assert_type(PAIR, ids);
// build a new environment and return it
environment_t *r = null_environment();
// TODO: Below code runs in slow O(n^2) time
for ( dict_t::const_iterator i = e->symbols.begin();
i != e->symbols.end(); ++i )
{
std::string name = (*i).first;
// find new name
for ( cons_t *id = ids; !nullp(id); id = cdr(id) ) {
assert_type(PAIR, car(id));
assert_type(SYMBOL, caar(id));
assert_type(SYMBOL, cadar(id));
if ( symbol_name(caar(id)) == name ) {
name = symbol_name(cadar(id));
break;
}
}
r->symbols[name] = (*i).second;
}
return r;
}
// (dm sym . fun|cls2) -> sym
// (dm (sym . cls) . fun|cls2) -> sym
// (dm (sym sym2 [. cls]) . fun|cls2) -> sym
any doDm(any ex) {
any x, y, msg, cls;
x = cdr(ex);
if (!isCell(car(x)))
msg = car(x), cls = val(Class);
else {
msg = caar(x);
cls = !isCell(cdar(x))? cdar(x) :
get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x));
}
if (msg != T)
redefine(ex, msg, val(Meth));
if (isSym(cdr(x))) {
y = val(cdr(x));
for (;;) {
if (!isCell(y) || !isCell(car(y)))
err(ex, msg, "Bad message");
if (caar(y) == msg) {
x = car(y);
break;
}
y = cdr(y);
}
}
for (y = val(cls); isCell(y) && isCell(car(y)); y = cdr(y))
if (caar(y) == msg) {
if (!equal(cdr(x), cdar(y)))
redefMsg(msg, cls);
cdar(y) = cdr(x);
putSrc(cls, msg);
return msg;
}
if (!isCell(car(x)))
val(cls) = cons(x, val(cls));
else
val(cls) = cons(cons(msg, cdr(x)), val(cls));
putSrc(cls, msg);
return msg;
}
VCSI_OBJECT caadar(VCSI_CONTEXT vc,
VCSI_OBJECT x) {
return car(vc,cadar(vc,x));
}
/*
* Parse (define-library ...) form into given environment, with the
* following format:
*
* (define-library <library name>
* <library declaration> ...)
*
* where <library declaration> is any of:
*
* - (export <export spec> ...)
* - (import <import set> ...)
* - (begin <command or definition> ...)
* - (include <filename1> <filename2> ...)
* - (include-ci <filename1> <filename2> ...)
* - (cond-expand <cond-expand clause> ...)
*/
static library_t* define_library(cons_t* p, const char* file)
{
library_t *r = new library_t();
cons_t *exports = nil();
// find current dir for resolving include and include-ci
std::string curdir = sdirname(file);
// define-library
if ( symbol_name(caar(p)) != "define-library" )
raise(syntax_error(format(
"Imported file does not begin with define-library: %s", file)));
// <library name>
r->name = verify_library_name(cadar(p));
// A <library declaration> can be either ...
for ( p = cdr(cdar(p)); !nullp(p); p = cdr(p) ) {
cons_t *id = caar(p);
cons_t *body = cdar(p);
std::string s = symbol_name(id);
if ( s == "export" ) {
exports = body;
continue;
}
if ( s == "import" ) {
// TODO: Make sure that proc_import does not override
// r->internals->outer
proc_import(body, r->internals);
continue;
}
if ( s == "begin" ) {
eval(car(p), r->internals);
continue;
}
if ( s == "include" ) {
eval(splice(list(symbol("begin")),
include(body, r->internals, curdir.c_str())),
r->internals);
continue;
}
if ( s == "include-ci" ) {
eval(splice(list(symbol("begin")),
include_ci(body, r->internals, curdir.c_str())),
r->internals);
continue;
}
if ( s == "cond-expand" ) {
eval(cond_expand(body, r->internals), r->internals);
continue;
}
}
// copy exports into exports-environemnt
for ( p = exports; !nullp(p); p = cdr(p) ) {
// handle renaming
if ( listp(car(p)) && length(car(p))==3 &&
symbol_name(caar(p))=="rename" )
{
assert_type(SYMBOL, cadar(p));
assert_type(SYMBOL, caddar(p));
std::string internal_name = symbol_name(cadar(p));
std::string external_name = symbol_name(caddar(p));
r->exports->define(external_name,
r->internals->lookup(internal_name));
} else if ( listp(car(p)) )
raise(syntax_error("(export <spec> ...) only allows (rename x y)"));
else if ( type_of(car(p)) == SYMBOL ) {
r->exports->define(symbol_name(car(p)),
r->internals->lookup(symbol_name(car(p))));
} else
raise(syntax_error(
"(export <spec> ...) requires <spec> to be "
"either an identifier or a pair of them."));
}
return r;
}
void load_library_index()
{
if ( library_map != NULL )
return;
std::string filename = library_file(library_index_file);
environment_t *env = null_environment();
program_t *p = parse(slurp(open_file(filename)), env);
cons_t *index = p->root;
if ( !pairp(index) || !symbolp(caar(index)) )
invalid_index_format(filename + ": no list with symbols");
for ( ; !nullp(index); index = cdr(index) ) {
if ( symbol_name(caar(index)) == "define-library-index" ) {
if ( library_map != NULL )
invalid_index_format(filename + ": only one define-library-index allowed");
if ( !listp(cdar(index)) ) {
invalid_index_format(filename
+ ": define-library-index is not a list");
}
size_t len = length(cdar(index));
library_map = (library_map_t*) malloc((1+len)*sizeof(library_map_t));
size_t i = 0;
for ( cons_t *lib = cdar(index); !nullp(lib); lib = cdr(lib), ++i ) {
cons_t *name = caar(lib);
cons_t *file = cadar(lib);
if ( !listp(name) || !stringp(file) )
invalid_index_format(filename + ": not list/string pair");
library_map[i].library_name = strdup(sprint(name).c_str());
library_map[i].source_file = strdup(file->string);
}
// important to signal end of list:
library_map[i].library_name = NULL;
library_map[i].source_file = NULL;
continue;
} else if ( symbol_name(caar(index)) == "define-repl-imports" ) {
if ( repl_libraries != NULL )
invalid_index_format(filename + ": only one define-repl-imports allowed");
if ( !listp(cdar(index)) ) {
invalid_index_format(filename
+ ": define-repl-imports is not a list");
}
size_t len = length(cdar(index));
repl_libraries = (const char**) malloc((1+len)*sizeof(char*));
const char **s = repl_libraries;
for ( cons_t *lib = cdar(index); !nullp(lib); lib = cdr(lib), ++s ) {
cons_t *name = car(lib);
*s = strdup(sprint(name).c_str());
}
*s = NULL;
continue;
} else
invalid_index_format(filename + ": unknown label "
+ sprint(caar(index)));
}
}
static data_t *get_let_exp(const data_t *assignment) {
if(assignment == NULL)
return NULL;
return cons(cadar(assignment), get_let_exp(cdr(assignment)));
}
