cons_t* proc_boundp(cons_t* p, environment_t* e)
{
assert_length(p, 1);
assert_type(SYMBOL, car(p));
return boolean(e->lookup(*car(p)->symbol) != NULL);
}
cons_t* proc_env_has_parentp(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_type(ENVIRONMENT, car(p));
return boolean(car(p)->environment->outer != NULL);
}
cons_t* proc_oddp(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_type(INTEGER, car(p));
return boolean(car(p)->number.integer & 1);
}
cons_t* proc_closure_source(cons_t* p, environment_t*)
{
assert_type(CLOSURE, car(p));
closure_t *c = car(p)->closure;
return cons(symbol("lambda"), list(c->args, c->body));
}
cons_t* proc_circularp(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_type(PAIR, car(p));
return boolean(circularp(car(p)));
}
/*
* 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;
}
/*
* (call <tag_ffi_cif>
* <closure w/C function pointer>
* <rvalue size in bytes>
* )
*/
cons_t* proc_ffi_call(cons_t* p, environment_t*)
{
assert_length(p, 2, 4);
assert_pointer(tag_ffi_cif, car(p));
assert_type(CLOSURE, cadr(p));
assert_type(INTEGER, caddr(p));
/*
* libffi description of function.
*/
ffi_cif *cif = static_cast<ffi_cif*>(car(p)->pointer->value);
/*
* Pointer to function to call.
*/
if ( cadr(p)->closure->function == NULL )
raise(runtime_exception(
"Can only call foreign C functions; not Scheme procedures"));
void (*funptr)() =
reinterpret_cast<void(*)()>(cadr(p)->closure->function);
/*
* Size of return value.
*/
integer_t size = 0;
if ( length(p)>2 )
size = caddr(p)->number.integer;
if ( size < 0 )
raise(runtime_exception(format(
"Cannot allocate a negative number of bytes: %d", size)));
/*
* Allocate enough memory necessary to hold return data.
*/
value_t *retval = new value_t(size);
/*
* Function arguments (currently unsupported).
*/
void **funargs = NULL;
if ( !nullp(cadddr(p)) ) {
cons_t *args = cadddr(p);
if ( length(args) != cif->nargs )
raise(runtime_exception(format(
"Foreign function expects %d arguments",
cif->nargs)));
funargs = static_cast<void**>(malloc(sizeof(void*)*(cif->nargs+1)));
size_t n=0;
for ( cons_t *a = args; !nullp(a); a = cdr(a), ++n ) {
funargs[n] = make_arg(cif->arg_types[n], car(a));
}
funargs[cif->nargs] = NULL; // TODO: is this necessary?
}
/*
* TODO: Destroy allocated funargs data after ffi_call, unless those are
* pointer values used to store returned data.
*/
ffi_call(cif, funptr, &retval->data, funargs);
return pointer(tag_ffi_retval, retval);
}