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))); }