cons_t* proc_read_from_port(cons_t* p, environment_t* e)
{
assert_length(p, 1);
assert_type(PORT, car(p));
port_t* port = car(p)->port;
FILE *f = port->file();
std::string s;
int ch = ' ';
while ( ch != '\n' && !feof(f) ) {
s += ch;
ch = fgetc(f);
}
program_t *prog = parse(s, e);
return car(prog->root);
/*
* TODO: If you do this:
*
* > (read (current-input-port))
* (+ 1 2 3) (* 4 5 6)
*
* it should RETURN '(+ 1 2 3) and
* EVALUATE (* 4 5 6) the reader should
* stop parsing as soon as it is finished,
* so the loop above should check balanced
* parens. When balanced, it should bail out.
*/
}
cons_t* proc_display(cons_t *p, environment_t*)
{
assert_length(p, 1, 2);
/*
* Get port to write to.
*
* TODO: Should we check if the file descriptor
* is open?
*/
port_t* port = &global_opts.current_output_device;
if ( length(p) == 2 ) {
assert_type(PORT, cadr(p));
port = cadr(p)->port;
}
/*
* TODO: Implement display in terms of (write) and
* use tail call elimination to be able to
* endlessly print circular lists.
*/
std::string s = print(car(p));
fwrite(s.c_str(), s.length(), 1, port->file());
return unspecified();
}
cons_t* proc_retval_to_u8vector(cons_t* p, environment_t*)
{
assert_length(p, 2);
assert_pointer(tag_ffi_retval, car(p));
value_t* value = static_cast<value_t*>(car(p)->pointer->value);
return bytevector(value->size, static_cast<uint8_t*>(value->data));
}
cons_t* proc_retval_to_pointer(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_pointer(tag_ffi_retval, car(p));
value_t* value = static_cast<value_t*>(car(p)->pointer->value);
return pointer(tag_void_pointer, value->data);
}
/*
* Query sizes of basic C data types.
*
*/
extern "C" cons_t* proc_sizeof(cons_t* p, environment_t*)
{
static struct {
const char* name;
size_t size;
} sizes[] = {
{"char", sizeof(char)},
{"int", sizeof(int)},
{"long", sizeof(long)},
{"longlong", sizeof(long long)},
{"pointer", sizeof(void*)}, // shorthand
{"short", sizeof(short)},
{"void*", sizeof(void*)},
{NULL, 0}
};
assert_length(p, 1);
assert_type(SYMBOL, car(p));
std::string s = symbol_name(car(p));
for ( size_t n=0; sizes[n].name != NULL; ++n )
if ( s == sizes[n].name )
return integer(sizes[n].size);
// not found
return boolean(false);
}
/*
* (fclose <file-obj>)
*/
cons_t* proc_fclose(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_pointer("FILE*", car(p));
FILE *f = reinterpret_cast<FILE*>(car(p)->pointer->value);
return !fclose(f)? nil() : boolean(false);
}
cons_t* proc_env_assign(cons_t* p, environment_t*)
{
assert_length(p, 3);
assert_type(ENVIRONMENT, car(p));
assert_type(SYMBOL, cadr(p));
const std::string name = symbol_name(cadr(p));
environment_t *e = car(p)->environment;
cons_t *value = caddr(p);
if ( value == NULL )
raise(runtime_exception(
"Symbol is not bound in any environment: " + name));
environment_t *i = e;
// search for definition and set if found
for ( ; i != NULL; i = i->outer ) {
if ( i->symbols.find(name) != i->symbols.end() ) {
i->symbols[name] = value;
return nil();
}
}
// only set if NOT found
if ( i == NULL )
e->define(name, value);
return nil();
}
cons_t* proc_retval_to_uchar(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_pointer(tag_ffi_retval, car(p));
value_t* value = static_cast<value_t*>(car(p)->pointer->value);
return character(value->character());
}
cons_t* proc_ffi_prep_cif_var(cons_t* p, environment_t*)
{
assert_length(p, 3, 4);
ffi_abi abi = FFI_DEFAULT_ABI;
/*
* ARGUMENT 1: ABI for foreign function
*/
abi = parse_ffi_abi(car(p));
/*
* ARGUMENT 2:
* Return type for foreign function
*/
ffi_type* rtype = parse_ffi_type(cadr(p));
/*
* ARGUMENT 3:
* Number of fixed vars
*/
assert_type(INTEGER, caddr(p));
unsigned int fixedargs = caddr(p)->number.integer;
/*
* ARGUMENT 4:
* Types for foreign function's input parameters.
*/
ffi_type** argtypes = NULL;
unsigned int nargs = 0;
if ( length(p) >= 4 ) {
cons_t *args = cadddr(p);
assert_type(PAIR, args);
nargs = length(args);
if ( nargs > 0 ) {
argtypes = static_cast<ffi_type**>(malloc(nargs*sizeof(ffi_type*)));
for ( unsigned int n=0; n<nargs; ++n ) {
argtypes[n] = parse_ffi_type(car(args));
args = cdr(args);
}
}
}
/*
* Initialize returned struct
*/
ffi_cif *cif = new ffi_cif();
memset(cif, 0, sizeof(ffi_cif));
check(ffi_prep_cif_var(cif, abi, fixedargs, nargs, rtype, argtypes));
return pointer(tag_ffi_cif, cif);
/*
* In the future, the malloced argtypes should be added to the
* pointer-return value here, so that it too can be freed.
*/
}
/*
* (make-type (<type1> <type2>) size alignment)
*/
cons_t* proc_make_type(cons_t* p, environment_t*)
{
cons_t *types = car(p),
*size = cadr(p),
*align = caddr(p);
assert_length(p, 3);
assert_type(PAIR, types);
assert_type(INTEGER, size);
assert_type(INTEGER, align);
const size_t ntypes = length(types);
if ( ntypes == 0 )
raise(runtime_exception("No types given"));
ffi_type *t = new ffi_type();
t->size = size->number.integer;
t->alignment = align->number.integer;
t->elements = new ffi_type*[1+ntypes];
t->elements[ntypes] = NULL;
p = types;
for ( size_t n=0; n<ntypes; ++n ) {
t->elements[n] = parse_ffi_type(car(p));
p = cdr(p);
}
return pointer(tag_ffi_type, t);
}
cons_t* proc_positivep(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
return boolean(integerp(car(p)) ? car(p)->number.integer > 0 :
car(p)->number.real > 0);
}
cons_t* proc_retval_to_double(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_pointer(tag_ffi_retval, car(p));
value_t* value = static_cast<value_t*>(car(p)->pointer->value);
return real(value->real_double());
}
cons_t* proc_feof(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_pointer("FILE*", car(p));
FILE *f = reinterpret_cast<FILE*>(car(p)->pointer->value);
return boolean(feof(f) != 0);
}
cons_t* proc_version(cons_t* p, environment_t*)
{
assert_length(p, 0);
#ifdef PACKAGE_VERSION
return string(PACKAGE_VERSION);
#else
return string("<unknown version>");
#endif
}
cons_t* proc_env_parent(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_type(ENVIRONMENT, car(p));
if ( car(p)->environment->outer == NULL )
raise(runtime_exception("Environment has no parent"));
return environment(car(p)->environment->outer);
}
cons_t* proc_truncate(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
if ( integerp(car(p)) )
return integer(car(p)->number.integer);
else
return real(truncf(car(p)->number.real));
}
cons_t* proc_env_eval(cons_t* p, environment_t* e)
{
assert_length(p, 2);
// evaluate environment argument
cons_t *env = eval(cadr(p), e);
assert_type(ENVIRONMENT, env);
return eval(car(p), env->environment);
}
cons_t* proc_nanp(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
if ( realp(car(p)) )
return boolean(std::isnan(car(p)->number.real));
return boolean(false);
}
cons_t* proc_infinitep(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
if ( type_of(car(p)) == INTEGER )
return boolean(false);
return boolean(std::fpclassify(car(p)->number.real) == FP_INFINITE);
}
cons_t* proc_finitep(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
if ( type_of(car(p)) == INTEGER )
return boolean(true);
return boolean(std::isfinite(car(p)->number.real));
}
cons_t* proc_expt(cons_t* p, environment_t*)
{
assert_length(p, 2);
cons_t *base = car(p),
*expn = cadr(p);
assert_number(base);
assert_number(expn);
bool exact = integerp(base) && integerp(expn);
if ( exact ) {
int a = base->number.integer,
n = expn->number.integer,
r = a;
// Per definition
if ( n == 0 )
return integer(1);
if ( n < 0 )
raise(runtime_exception("Negative exponents not implemented"));
// This is a slow version
// TODO: Implement O(log n) version
while ( n-- > 1 )
r *= a;
return integer(r);
}
// Floating point exponentiation
real_t a = number_to_real(base),
n = number_to_real(expn),
r = a;
if ( n == 0.0 )
return real(1.0);
if ( n < 0.0 )
raise(runtime_exception("Negative exponents not implemented"));
while ( floor(n) > 1.0 ) {
r *= a;
n -= 1.0;
}
if ( n > 1.0 )
raise(runtime_exception("Fractional exponents not supported"));
// TODO: Compute r^n, where n is in [0..1)
return real(r);
}
/*
* (return-value->string <retval>)
*
* USE AT YOUR OWN RISK! :-)
*/
cons_t* proc_retval_to_string(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_pointer(tag_ffi_retval, car(p));
/*
* Note that string() duplicates the string, so this is a bit potential
* risk. We'll assume the authors know they're doing :-)
*/
value_t* value = static_cast<value_t*>(car(p)->pointer->value);
return string(value->string());
}
extern "C" cons_t* proc_gethostname(cons_t* p, environment_t*)
{
assert_length(p, 0);
size_t len = 1+sysconf(_SC_HOST_NAME_MAX);
char *s = static_cast<char*>(malloc(sizeof(char)*len));
gethostname(s, len);
cons_t *r = string(s);
free(s);
return r;
}
cons_t* proc_env_boundp(cons_t* p, environment_t*)
{
assert_length(p, 2);
assert_type(ENVIRONMENT, car(p));
assert_type(SYMBOL, cadr(p));
const std::string name = symbol_name(cadr(p));
environment_t *e = car(p)->environment;
// follow parent environments
return boolean(e->lookup(name) != NULL);
}
cons_t* proc_round(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
if ( integerp(car(p)) )
return integer(car(p)->number.integer);
else if ( rationalp(car(p)) )
return real(roundf(make_inexact(car(p))->number.real));
assert_type(REAL, car(p));
return real(roundf(car(p)->number.real));
}
/*
* (freopen <filename>) <mode> <file-obj>)
*/
cons_t* proc_freopen(cons_t* p, environment_t*)
{
assert_length(p, 3);
assert_type(STRING, car(p));
assert_type(STRING, cadr(p));
assert_pointer("FILE*", caddr(p));
const char* filename = car(p)->string;
const char* mode = cadr(p)->string;
FILE* f = reinterpret_cast<FILE*>(caddr(p)->pointer->value);
return !freopen(filename, mode, f)? nil() : boolean(false);
}
cons_t* proc_exact_to_inexact(cons_t* p, environment_t*)
{
assert_length(p, 1);
cons_t *q = car(p);
assert_number(q);
assert_exact(q);
cons_t *r = new cons_t();
*r = *q;
r->number.exact = false;
return r;
}
cons_t* proc_abs(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_number(car(p));
if ( realp(car(p)) ) {
real_t n = car(p)->number.real;
return real(n<0.0? -n : n);
}
int n = car(p)->number.integer;
return integer(n<0? -n : n);
}
cons_t* proc_env_lookup(cons_t* p, environment_t*)
{
assert_length(p, 2);
assert_type(ENVIRONMENT, car(p));
assert_type(SYMBOL, cadr(p));
const std::string name = symbol_name(cadr(p));
environment_t *e = car(p)->environment;
// follow parent environments, don't signal error
// if not found (TODO: Correct?)
return nil_coalesce(e->lookup(name));
}
extern "C" cons_t* proc_usleep(cons_t* p, environment_t*)
{
assert_length(p, 1);
assert_type(INTEGER, car(p));
int usecs = car(p)->number.integer;
if ( usecs < 0 )
raise(runtime_exception("usleep doesn't like negative time"));
// TODO: If it returns -1, lookup error and return it
return integer(usleep(usecs));
}