void
dpower(void)
{
push(caddr(p1)); // v/u
push(cadr(p1));
divide();
push(cadr(p1)); // du/dx
push(p2);
derivative();
multiply();
push(cadr(p1)); // log u
logarithm();
push(caddr(p1)); // dv/dx
push(p2);
derivative();
multiply();
add();
push(p1); // u^v
multiply();
}
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.
*/
}
/*
* (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));
}
int
brz_is_nullable( atom_t atom )
{
return re_is_eps( atom )
|| re_is_rep( atom )
|| (re_is_alt( atom ) && (brz_is_nullable( cadr(atom) ) || brz_is_nullable( caddr(atom) )))
|| (re_is_seq( atom ) && brz_is_nullable( cadr(atom) ) && brz_is_nullable( caddr(atom) ));
}
/*
* (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)));
}
/*
* (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);
}
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_roots(void)
{
// A == B -> A - B
p2 = cadr(p1);
if (car(p2) == symbol(SETQ) || car(p2) == symbol(TESTEQ)) {
push(cadr(p2));
eval();
push(caddr(p2));
eval();
subtract();
} else {
push(p2);
eval();
p2 = pop();
if (car(p2) == symbol(SETQ) || car(p2) == symbol(TESTEQ)) {
push(cadr(p2));
eval();
push(caddr(p2));
eval();
subtract();
} else
push(p2);
}
// 2nd arg, x
push(caddr(p1));
eval();
p2 = pop();
if (p2 == symbol(NIL))
guess();
else
push(p2);
p2 = pop();
p1 = pop();
if (!ispoly(p1, p2))
stop("roots: 1st argument is not a polynomial");
push(p1);
push(p2);
roots();
}
void
eval_factor(void)
{
push(cadr(p1));
eval();
push(caddr(p1));
eval();
p2 = pop();
if (p2 == symbol(NIL))
guess();
else
push(p2);
factor();
// more factoring?
p1 = cdddr(p1);
while (iscons(p1)) {
push(car(p1));
eval();
factor_again();
p1 = cdr(p1);
}
}
void
eval_draw(void)
{
F = cadr(p1);
T = caddr(p1);
if (T == symbol(NIL)) {
push(F);
rewrite();
guess();
T = pop();
F = pop();
}
push(get_binding(T));
push(get_arglist(T));
draw_main();
p2 = pop();
p1 = pop();
set_binding_and_arglist(T, p1, p2);
// return value
push(symbol(NIL));
}
// (term-prinl ['num 'num] 'any ..) -> any
any plisp_term_prinl(any ex) {
any x, y;
long n1, n2;
// if number of args > 1, we accept
// a min of 3 args - x, y and the value
// to print.
if (plen(ex) > 1 && isNum(cadr(ex)) && isNum(caddr(ex))) {
x = cdr(ex), y = EVAL(car(x));
NeedNum(ex, y);
n1 = unBox(y); // we get x here.
x = cdr(x), y = EVAL(car(x));
NeedNum(ex, y);
n2 = unBox(y); // we get y here.
term_gotoxy(n1, n2);
// now, get the rest of the params
// and prinl.
while (isCell(x = cdr(x)))
ptermh_prin(y = EVAL(car(x)));
} else {
// We don't have the coordinates.
// we just print the first value
// in the list (including NIL).
x = cdr(ex), y = EVAL(car(x));
ptermh_prin(y);
while (isCell(x = cdr(x)))
ptermh_prin(y = EVAL(car(x)));
}
newline();
return y;
}
void
expand_get_AF(void)
{ int d, i, j, n = 1;
if (!find(F, X))
return;
if (car(F) == symbol(POWER)) {
push(caddr(F));
n = pop_integer();
F = cadr(F);
}
push(F);
push(X);
degree();
d = pop_integer();
for (i = n; i > 0; i--) {
for (j = 0; j < d; j++) {
push(F);
push_integer(i);
power();
reciprocate();
push(X);
push_integer(j);
power();
multiply();
}
}
}
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();
}
/*
* (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);
}
void
expand_get_CF(void)
{ int d, i, j, n;
if (!find(F, X))
return;
trivial_divide();
if (car(F) == symbol(POWER)) {
push(caddr(F));
n = pop_integer();
P = cadr(F);
} else {
n = 1;
P = F;
}
push(P);
push(X);
degree();
d = pop_integer();
for (i = 0; i < n; i++) {
for (j = 0; j < d; j++) {
push(T);
push(P);
push_integer(i);
power();
multiply();
push(X);
push_integer(j);
power();
multiply();
}
}
}
node returntype(node fun){
node t = type(fun);
if (iscons(t) && car(t) == function_S && length(t) == 3) {
return caddr(t);
}
else return bad_or_undefined_T;
}
static environment_t* import_set(cons_t* p)
{
std::string s = symbol_name(car(p));
/*
* Each import set can be either of:
*/
// (rename <import set> (<identifier1> <identifier2>) ...)
if ( s == "rename" )
return rename(import_set(cadr(p)), cddr(p));
// (prefix <import set> <identifier>)
else if ( s == "prefix" )
return prefix(import_set(cadr(p)), caddr(p));
// (only <import set> <identifier> ...)
else if ( s == "only" )
return only(import_set(cadr(p)), cddr(p));
// (except <import set> <identifier> ...)
else if ( s == "except" )
return except(import_set(cadr(p)), cddr(p));
// <library name>
else if ( !s.empty() )
return import_library(sprint(p));
raise(runtime_exception("Unknown import set: " + sprint(p)));
return NULL;
}
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();
}
void
dhermite(void)
{
push(cadr(p1));
push(p2);
derivative();
push_integer(2);
push(caddr(p1));
multiply();
multiply();
push(cadr(p1));
push(caddr(p1));
push_integer(-1);
add();
hermite();
multiply();
}
void
yydegree(U *p)
{
if (equal(p, X)) {
if (iszero(DEGREE))
DEGREE = one;
} else if (car(p) == symbol(POWER)) {
if (equal(cadr(p), X) && isnum(caddr(p)) && lessp(DEGREE, caddr(p)))
DEGREE = caddr(p);
} else if (iscons(p)) {
p = cdr(p);
while (iscons(p)) {
yydegree(car(p));
p = cdr(p);
}
}
}
void
eval_power(void)
{
push(cadr(p1));
eval();
push(caddr(p1));
eval();
power();
}
cell pp_curs_mvinsch(cell x) {
char name[] = "curs:mvinsch";
if (!Running) return UNSPECIFIC;
mvinsch(integer_value(name, car(x)),
integer_value(name, cadr(x)),
char_value(caddr(x)));
return UNSPECIFIC;
}
cell pp_curs_mvaddstr(cell x) {
char name[] = "curs:mvaddstr";
if (!Running) return UNSPECIFIC;
mvaddstr(integer_value(name, car(x)),
integer_value(name, cadr(x)),
string(caddr(x)));
return UNSPECIFIC;
}
void
eval_besselj(void)
{
push(cadr(p1));
eval();
push(caddr(p1));
eval();
besselj();
}
void
eval_binomial(void)
{
push(cadr(p1));
eval();
push(caddr(p1));
eval();
binomial();
}
atom_t
brz_deriv( atom_t atom, int c )
{
if( characterp(atom) )
return PREDICATE( equalp(atom, ULISP_CHAR(c)) );
if( re_is_seq(atom) )
return re_alt(
re_seq( brz_deriv(cadr(atom), c), caddr(atom) ),
re_seq( PREDICATE(brz_is_nullable(cadr(atom))), brz_deriv(caddr(atom), c) ));
if( re_is_alt(atom) )
return re_alt( brz_deriv(cadr(atom), c), brz_deriv(caddr(atom), c) );
if( re_is_rep(atom) )
return re_seq( brz_deriv(cadr(atom), c), re_rep(cadr(atom)) );
return PREDICATE( re_is_any(atom) );
}
symbol * line_number(int x)
{
int c = 0;
int v = 0;
int l = 0;
symbol * q = NULL;
char s[256];
sprintf(s, "lino_%d", x);
l = caddr(sym_addr(s, &c, &v, &q));
return q;
}
static pSlipObject definition_value(pSlip gd, pSlipObject exp, pSlipEnvironment env)
{
if (sIsObject_Symbol(cadr(exp)) == S_TRUE)
{
return caddr(exp);
}
else
{
return make_lambda(gd, cdadr(exp), cddr(exp));
}
}
symbol * unnamed(void)
{
int c = 0;
int v = 0;
int l = 0;
symbol * q = NULL;
char s[256];
sprintf(s, "sym_%d", serial++);
l = caddr(sym_addr(s, &c, &v, &q));
return q;
}
int typeAlign(refObject type)
{ switch (toHook(car(type)))
{ case arrayHook:
{ return typeAlign(caddr(type)); }
case char0Hook:
{ return alignof(char0Type); }
case char1Hook:
{ return alignof(char1Type); }
case int0Hook:
{ return alignof(int0Type); }
case int1Hook:
{ return alignof(int1Type); }
case int2Hook:
{ return alignof(int2Type); }
case nullHook:
case referHook:
case rowHook:
{ return alignof(pointerType); }
case procHook:
{ return alignof(procType); }
case real0Hook:
{ return alignof(real0Type); }
case real1Hook:
{ return alignof(real1Type); }
case skoHook:
case varHook:
{ return typeAlign(cadr(type)); }
case strTypeHook:
{ return toInteger(caddr(type)); }
case tupleHook:
{ int maxAlign = 1;
type = cdr(type);
while (type != nil)
{ int align = typeAlign(car(type));
maxAlign = (align > maxAlign ? align : maxAlign);
type = cddr(type); }
return maxAlign; }
case voidHook:
{ return alignof(voidType); }
default:
{ fail("Type has undefined alignment in typeAlign!"); }}}
