cell pp_curs_mvcur(cell x) {
char name[] = "curs:mvcur";
if (!Running) return UNSPECIFIC;
if (!integer_p(cadddr(x)))
return error("curs:mvcur: expected integer, got",
caddr(cdr(x)));
mvcur(integer_value(name, car(x)),
integer_value(name, cadr(x)),
integer_value(name, caddr(x)),
integer_value(name, cadddr(x)));
return UNSPECIFIC;
}
void
eval_coeff(void)
{
push(cadr(p1)); // 1st arg, p
eval();
push(caddr(p1)); // 2nd arg, x
eval();
push(cadddr(p1)); // 3rd arg, n
eval();
N = pop();
X = pop();
P = pop();
if (N == symbol(NIL)) { // only 2 args?
N = X;
X = symbol(SYMBOL_X);
}
push(P); // divide p by x^n
push(X);
push(N);
power();
divide();
push(X); // keep the constant part
filter();
}
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.
*/
}
object *if_alternative(object *exp) {
if (is_the_empty_list(cdddr(exp))) {
return false;
} else {
return cadddr(exp);
}
}
/*
* (set-video-mode <width> <height> <bits per pixel>?) or
* (set-video-mode <width> <height> <bits per pixel> <mode flags>+)
*
* where <symbols> are:
* swsurface
* hwsurface
* asyncblit
* anyformat
* hwpalette
* doublebuf
* fullscreen
* opengl
* openglblit
* resizable
* noframe
*
*/
cons_t* set_video_mode(cons_t* p, environment_t*)
{
assert_length_min(p, 2);
assert_type(INTEGER, car(p));
assert_type(INTEGER, cadr(p));
// dimension
int x = car(p)->integer;
int y = cadr(p)->integer;
// default values
int bits = 32;
uint32_t mode = 0;
///////////////////
raise(runtime_exception("Testing"));
///////////////////
// bits per pixel
if ( integerp(caddr(p)) )
bits = caddr(p)->integer;
// options
cons_t *opts = symbolp(caddr(p))? cddr(p) :
symbolp(cadddr(p))? cdddr(p) : nil();;
for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {
assert_type(SYMBOL, car(s));
std::string sym = symbol_name(s);
int size = sizeof(sdl_flags) / sizeof(key_value_t<std::string, uint32_t>);
for ( int n=0; n < size; ++n )
if ( sym == sdl_flags[n].key ) {
///////////////////
printf("flag %s\n", sym.c_str());
printf("value %d and %d\n", sdl_flags[n].value, SDL_HWSURFACE);
///////////////////
mode |= sdl_flags[n].value;
goto NEXT_FLAG;
}
raise(runtime_exception("Unknown SDL video mode flag: " + sym));
NEXT_FLAG:
continue;
}
mode = SDL_HWSURFACE;
///////////////////
printf("video mode\n"); fflush(stdout);
///////////////////
SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);
if ( screen == NULL )
raise(runtime_exception(SDL_GetError()));
return pointer(new pointer_t("sdl-surface", (void*)screen));
}
static pSlipObject if_alternative(pSlip gd, pSlipObject exp)
{
if (sIsObject_EmptyList(gd, cdddr(exp)) == S_TRUE)
{
return gd->singleton_False;
}
else
{
return cadddr(exp);
}
}
/*
* (set-video-mode <width> <height> <bits per pixel>?) or
* (set-video-mode <width> <height> <bits per pixel> <mode flags>+)
*
* where <symbols> are:
* swsurface
* hwsurface
* asyncblit
* anyformat
* hwpalette
* doublebuf
* fullscreen
* opengl
* openglblit
* resizable
* noframe
*
*/
cons_t* set_video_mode(cons_t* p, environment_t*)
{
assert_length_min(p, 2);
assert_type(INTEGER, car(p));
assert_type(INTEGER, cadr(p));
// dimension
int x = intval(car(p));
int y = intval(cadr(p));
// default values
int bits = 32;
uint32_t mode = 0;
// bits per pixel
if ( length(p) > 2 && integerp(caddr(p)) )
bits = intval(caddr(p));
// mode options
if ( length(p) > 3 ) {
cons_t *opts = symbolp(caddr(p))? cddr(p) :
symbolp(cadddr(p))? cdddr(p) : nil();;
DPRINT(opts);
for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) {
assert_type(SYMBOL, car(s));
std::string sym = symbol_name(car(s));
for ( size_t n=0; n < num_sdl_flags; ++n )
if ( sym == sdl_flags[n].key ) {
mode |= sdl_flags[n].value;
goto NEXT_FLAG;
}
raise(runtime_exception("Unknown SDL video mode flag: " + sym));
NEXT_FLAG:
continue;
}
}
SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode);
if ( screen == NULL )
raise(runtime_exception(SDL_GetError()));
return pointer(
new pointer_t("sdl-surface",
reinterpret_cast<void*>(screen)));
}
void
eval_product(void)
{
int i, j, k;
// 1st arg (quoted)
X = cadr(p1);
if (!issymbol(X))
stop("product: 1st arg?");
// 2nd arg
push(caddr(p1));
eval();
j = pop_integer();
if (j == (int) 0x80000000)
stop("product: 2nd arg?");
// 3rd arg
push(cadddr(p1));
eval();
k = pop_integer();
if (k == (int) 0x80000000)
stop("product: 3rd arg?");
// 4th arg
// fix
p1 = cddddr(p1);
p1 = car(p1);
B = get_binding(X);
A = get_arglist(X);
push_integer(1);
for (i = j; i <= k; i++) {
push_integer(i);
I = pop();
set_binding(X, I);
push(p1);
eval();
multiply();
}
set_binding_and_arglist(X, B, A);
}
int typeSize(refObject type)
{ switch (toHook(car(type)))
{ case arrayHook:
{ type = cdr(type);
return toInteger(car(type)) * typeSize(cadr(type)); }
case char0Hook:
{ return sizeof(char0Type); }
case char1Hook:
{ return sizeof(char1Type); }
case int0Hook:
{ return sizeof(int0Type); }
case int1Hook:
{ return sizeof(int1Type); }
case int2Hook:
{ return sizeof(int2Type); }
case nullHook:
case referHook:
case rowHook:
{ return sizeof(pointerType); }
case procHook:
{ return sizeof(procType); }
case real0Hook:
{ return sizeof(real0Type); }
case real1Hook:
{ return sizeof(real1Type); }
case skoHook:
case varHook:
{ return typeSize(cadr(type)); }
case strTypeHook:
{ return toInteger(cadddr(type)); }
case tupleHook:
{ int slotAlign;
refObject slotType;
int tupleAlign = 1;
int tupleSize = 0;
type = cdr(type);
while (type != nil)
{ slotType = car(type);
slotAlign = typeAlign(slotType);
tupleAlign = (slotAlign > tupleAlign ? slotAlign : tupleAlign);
tupleSize += typeSize(slotType);
tupleSize += rounder(tupleSize, slotAlign);
type = cddr(type); }
return tupleSize + rounder(tupleSize, tupleAlign); }
case voidHook:
{ return sizeof(voidType); }
default:
{ fail("Type has undefined size in typeSize!"); }}}
void
eval_transpose(void)
{
push(cadr(p1));
eval();
if (cddr(p1) == symbol(NIL)) {
push_integer(1);
push_integer(2);
} else {
push(caddr(p1));
eval();
push(cadddr(p1));
eval();
}
transpose();
}
void
eval_quotient(void)
{
push(cadr(p1)); // 1st arg, p(x)
eval();
push(caddr(p1)); // 2nd arg, q(x)
eval();
push(cadddr(p1)); // 3rd arg, x
eval();
p1 = pop(); // default x
if (p1 == symbol(NIL))
p1 = symbol(SYMBOL_X);
push(p1);
divpoly_void();
}
void
eval_cofactor(void)
{
int i, j, n;
push(cadr(p1));
eval();
p2 = pop();
if (istensor(p2) && p2->u.tensor->ndim == 2 && p2->u.tensor->dim[0] == p2->u.tensor->dim[1])
;
else
stop("cofactor: 1st arg: square matrix expected");
n = p2->u.tensor->dim[0];
push(caddr(p1));
eval();
i = pop_integer();
if (i < 1 || i > n)
stop("cofactor: 2nd arg: row index expected");
push(cadddr(p1));
eval();
j = pop_integer();
if (j < 1 || j > n)
stop("cofactor: 3rd arg: column index expected");
cofactor(p2, n, i - 1, j - 1);
}
object *if_alternative(object *exp) {
return is_empty(cdddr(exp)) ? make_boolean(false) : cadddr(exp);
}
//TODO check number of arguments given to builtins
object_t *eval(object_t *exp, object_t *env) {
char comeback = 1;
while(comeback) {
comeback = 0;
if(is_self_evaluating(exp)) {
return exp;
}
if(list_begins_with(exp, quote_symbol)) {
return cadr(exp);
}
// (define... )
if(list_begins_with(exp, define_symbol)) {
object_t *var = cadr(exp);
// (define a b)
if(issymbol(var)) {
object_t *val = caddr(exp);
return define_var(env, var, val);
}
// (define (a ...) ...) TODO use scheme macro
if(ispair(var)) {
object_t *name = car(cadr(exp)),
*formals = cdr(cadr(exp)),
*body = cddr(exp),
*lambda = cons(lambda_symbol,
cons(formals, body));
exp = cons(define_symbol,
cons(name, cons(lambda, empty_list)));
comeback = 1;
continue;
}
fprintf(stderr, "Syntax error.\n");
exit(-1);
}
// (set! a b)
if(list_begins_with(exp, set_symbol)) {
object_t *var = cadr(exp);
object_t *val = caddr(exp);
return set_var(env, var, val);
}
// (if c a b)
if(list_begins_with(exp, if_symbol)) {
exp = eval_if(env, cadr(exp), caddr(exp), cadddr(exp));
comeback = 1;
continue;
}
// (cond ...)
if(list_begins_with(exp, cond_symbol)) {
object_t *tail = cons(void_symbol, empty_list);
object_t *ifs = tail; //empty_list;
object_t *rules = reverse_list(cdr(exp));
while(!isemptylist(rules)) {
object_t *rule = car(rules),
*condition = car(rule),
*consequence = cadr(rule);
if(isemptylist(consequence)) {
consequence = cons(void_obj, empty_list);
}
ifs = cons(if_symbol,
cons(condition,
cons(consequence,
cons(ifs, empty_list))));
rules = cdr(rules);
}
exp = ifs;
comeback = 1;
continue;
}
// (begin ...)
if(list_begins_with(exp, begin_symbol)) {
object_t *result = empty_list, *exps;
for(exps = cdr(exp); ! isemptylist(exps); exps = cdr(exps)) {
result = eval(car(exps), env);
}
return result;
}
if(list_begins_with(exp, lambda_symbol)) {
object_t *fn = cons(begin_symbol,
cdr(cdr(exp)));
return make_compound_proc(empty_list, cadr(exp),
fn,
env);
}
// (let ...)
if(list_begins_with(exp, let_symbol)) {
//if(! issymbol(cadr(exp)))
object_t *bindings = cadr(exp);
object_t *body = cddr(exp);
object_t *formals = empty_list;
object_t *values = empty_list;
while(!isemptylist(bindings)) {
formals = cons(caar(bindings), formals);
values = cons(cadr(car(bindings)), values);
bindings = cdr(bindings);
}
exp = cons(cons(lambda_symbol, cons(formals, body)),
values);
comeback = 1;
continue;
}
if(issymbol(exp)) {
return var_get_value(env, exp);
}
if(ispair(exp)) {
object_t *exp_car = car(exp);
object_t *fn = eval(exp_car, env); //var_get_value(env, car);
if(!iscallable(fn)) {
fprintf(stderr, "object_t is not callable\n");
exit(-1);
}
object_t *args = cdr(exp);
object_t *evaluated_args = evaluate_list(env, args, empty_list);
if(isprimitiveproc(fn)) {
return fn->value.prim_proc.fn(evaluated_args);
} else if(iscompoundproc(fn)) {
object_t *fn_formals = fn->value.compound_proc.formals;
object_t *fn_body = fn->value.compound_proc.body;
object_t *fn_env = fn->value.compound_proc.env;
ARGS_EQ(evaluated_args, list_size(fn_formals));
exp = fn_body;
env = extend_environment(fn_formals, evaluated_args, fn_env);
comeback = 1;
continue;
}
assert(0);
}
}
fprintf(stderr, "Unable to evaluate expression: \n");
write(exp);
exit(-1);
}
/*
* (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);
}