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;
}
void restore_continuation(int flag)
{
int count = 0;
if (flag & cont_env) {
count++;
env = car(cont);
}
if (flag & cont_op) {
count++;
op = cadr(cont);
}
if (flag & cont_arg) {
count++;
arg = car(cddr(cont));
}
switch (count) {
case 3:
cont = car(cdr(cddr(cont)));
break;
case 2:
cont = car(cddr(cont));
break;
case 1:
cont = car(cdr(cont));
break;
case 0:
cont = car(cont);
break;
}
}
NODE *lremprop(NODE *args)
{
NODE *plname, *pname, *plist, *val = NIL;
BOOLEANx caseig = FALSE;
if (compare_node(valnode__caseobj(Caseignoredp), Truex, TRUE) == 0)
caseig = TRUE;
plname = string_arg(args);
pname = string_arg(cdr(args));
if (NOT_THROWING)
{
plname = intern(plname);
plist = plist__caseobj(plname);
if (plist != NIL)
{
if (compare_node(car(plist), pname, caseig) == 0)
setplist__caseobj(plname, cddr(plist));
else
{
val = getprop(plist, pname, TRUE);
if (val != NIL)
setcdr(cdr(val), cddr(cddr(val)));
}
}
}
return (UNBOUND);
}
int arity(refObject type)
{ int count = 0;
refObject pars = cadr(degen(type));
while (pars != nil)
{ count += 1;
pars = cddr(pars); }
return count; }
// (let sym 'any . prg) -> any
// (let (sym 'any ..) . prg) -> any
any doLet(any x) {
any y;
x = cdr(x);
if (isSym(y = car(x))) {
bindFrame f;
x = cdr(x), Bind(y,f), val(y) = EVAL(car(x));
x = prog(cdr(x));
Unbind(f);
}
else {
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[(length(y)+1)/2];
} f;
f.link = Env.bind, Env.bind = (bindFrame*)&f;
f.i = f.cnt = 0;
do {
f.bnd[f.cnt].sym = car(y);
f.bnd[f.cnt].val = val(car(y));
++f.cnt;
val(car(y)) = EVAL(cadr(y));
} while (isCell(y = cddr(y)));
x = prog(cdr(x));
while (--f.cnt >= 0)
val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
Env.bind = f.link;
}
return x;
}
/*
* (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));
}
NODE *lpprop(NODE *args)
{
NODE *plname, *pname, *newval, *plist, *val = NIL;
plname = string_arg(args);
pname = string_arg(cdr(args));
newval = car(cddr(args));
if (NOT_THROWING)
{
plname = intern(plname);
if (flag__caseobj(plname, PLIST_TRACED))
{
ndprintf(writestream, "Pprop %s %s %s", maybe_quote(plname),
maybe_quote(pname), maybe_quote(newval));
if (ufun != NIL)
ndprintf(writestream, " in %s\n%s", ufun, this_line);
new_line(writestream);
}
plist = plist__caseobj(plname);
if (plist != NIL)
val = getprop(plist, pname, FALSE);
if (val != NIL)
setcar(cdr(val), newval);
else
setplist__caseobj(plname, cons(pname, cons(newval, plist)));
}
return (UNBOUND);
}
// ($ sym|lst lst . prg) -> any
any doTrace(any x) {
any foo, body;
outFile *oSave;
void (*putSave)(int);
cell c1;
x = cdr(x);
if (isNil(val(Dbg)))
return prog(cddr(x));
oSave = OutFile, putSave = Env.put;
OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout;
foo = car(x);
x = cdr(x), body = cdr(x);
traceIndent(++Env.trace, foo, " :");
for (x = car(x); isCell(x); x = cdr(x))
space(), print(val(car(x)));
if (!isNil(x)) {
if (x != At)
space(), print(val(x));
else {
int i = Env.next;
while (--i >= 0)
space(), print(data(Env.arg[i]));
}
}
newline();
Env.put = putSave, OutFile = oSave;
Push(c1, prog(body));
OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout;
traceIndent(Env.trace--, foo, " = "), print(data(c1));
newline();
Env.put = putSave, OutFile = oSave;
return Pop(c1);
}
cell make_long_integer(long long i) {
cell n;
n = make_ulong_integer(i < 0? -i: i);
if (i < 0)
n = new_atom(T_INTEGER, new_atom(-cadr(n), cddr(n)));
return n;
}
NODE* remdup(NODE *seq) {
NODE* okay;
if (seq == NIL)
return seq;
/* finds the first element of new seq list */
while (memq(car(seq), cdr(seq))) {
seq = cdr(seq);
}
for (okay = seq; cdr(okay) != NIL; okay = cdr(okay)) {
while (memq(cadr(okay), cddr(okay))) {
setcdr(okay, cddr(okay));
}
}
return seq;
}
// (if 'any1 'any2 . prg) -> any
any doIf(any x) {
any a;
x = cdr(x);
if (isNil(a = EVAL(car(x))))
return prog(cddr(x));
val(At) = a;
x = cdr(x);
return EVAL(car(x));
}
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));
}
}
// (ifn 'any1 'any2 . prg) -> any
any doIfn(any x) {
any a;
x = cdr(x);
if (!isNil(a = EVAL(car(x)))) {
val(At) = a;
return prog(cddr(x));
}
x = cdr(x);
return EVAL(car(x));
}
long long int64_value(char *src, cell x) {
cell n;
long long v;
if (cadr(x) < 0)
n = new_atom(T_INTEGER, new_atom(-cadr(x), cddr(x)));
else
n = x;
v = uint64_value(src, n);
return cadr(x) < 0? -v: v;
}
// (at '(cnt1 . cnt2) . prg) -> any
any doAt(any ex) {
any x;
x = cdr(ex), x = EVAL(car(x));
NeedCell(ex,x);
NeedCnt(ex,car(x));
NeedCnt(ex,cdr(x));
if (num(setDig(car(x), unDig(car(x))+2)) < unDig(cdr(x)))
return Nil;
setDig(car(x), 0);
return prog(cddr(ex));
}
/*
* (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)));
}
// (with 'sym . prg) -> any
any doWith(any ex) {
any x;
bindFrame f;
x = cdr(ex);
if (isNil(x = EVAL(car(x))))
return Nil;
NeedSym(ex,x);
Bind(This,f), val(This) = x;
x = prog(cddr(ex));
Unbind(f);
return x;
}
void PassParse::parse_declare_ftype(Val declspec)
{
const Type* pty = Type::Parse(cadr(declspec));
//= <FIXME date="2008-06-29" by="*****@*****.**">
//= We must check pty is subtype of function.
//= </FIXME>
foreach (List::Enum, oEnum, cddr(declspec))
{
if (FunRef* const pFunRef = internFunDcl(oEnum.Get()))
{
pFunRef->SetTy(pty);
}
} // for name
} // PassParse::parse_declare_ftype
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!"); }}}
FILE *open_file(NODE *arg, char *access) {
char *fnstr;
FILE *tstrm;
char *old_stringptr = print_stringptr;
int old_stringlen = print_stringlen;
if (is_list(arg)) { /* print to string */
if (*access != 'w') {
err_logo(BAD_DATA_UNREC, arg);
return NULL;
} else {
FIXNUM i = int_arg(cdr(arg));
if (NOT_THROWING && i > 0 && cddr(arg) == NIL) {
char *tmp = (char *)malloc(i);
*tmp = '\0';
return (FILE *)tmp;
}
err_logo(BAD_DATA_UNREC, car(arg));
return NULL;
}
}
arg = cnv_node_to_strnode(arg);
if (arg == UNBOUND) return(NULL);
if (file_prefix != NIL) {
print_stringlen = getstrlen(file_prefix) +
getstrlen(arg) + 2;
fnstr = (char *)malloc((size_t)print_stringlen + 1);
} else
fnstr = (char *) malloc((size_t)getstrlen(arg) + 1);
if (fnstr == NULL) {
err_logo(FILE_ERROR, make_static_strnode(message_texts[MEM_LOW]));
print_stringptr = old_stringptr;
print_stringlen = old_stringlen;
return NULL;
}
if (file_prefix != NIL) {
print_stringptr = fnstr;
ndprintf((FILE *)NULL, "%p%t%p", file_prefix, separator, arg);
*print_stringptr = '\0';
print_stringptr = old_stringptr;
print_stringlen = old_stringlen;
} else
noparity_strnzcpy(fnstr, getstrptr(arg), getstrlen(arg));
tstrm = fopen(fnstr, access);
free(fnstr);
return(tstrm);
}
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();
}
// (tick (cnt1 . cnt2) . prg) -> any
any doTick(any ex) {
any x;
clock_t n1, n2, save1, save2;
struct tms tim;
static clock_t ticks1, ticks2;
save1 = ticks1, save2 = ticks2;
times(&tim), n1 = tim.tms_utime, n2 = tim.tms_stime;
x = prog(cddr(ex));
times(&tim);
n1 = (tim.tms_utime - n1) - (ticks1 - save1);
n2 = (tim.tms_stime - n2) - (ticks2 - save2);
setDig(caadr(ex), unDig(caadr(ex)) + 2*n1);
setDig(cdadr(ex), unDig(cdadr(ex)) + 2*n2);
ticks1 += n1, ticks2 += n2;
return x;
}
NODE *getprop(NODE *plist, NODE *name, BOOLEANx before)
{
NODE *prev = NIL;
BOOLEANx caseig = FALSE;
if (compare_node(valnode__caseobj(Caseignoredp), Truex, TRUE) == 0)
caseig = TRUE;
while (plist != NIL)
{
if (compare_node(name, car(plist), caseig) == 0)
{
return (before ? prev : plist);
}
prev = plist;
plist = cddr(plist);
}
return (NIL);
}
NODE *lsetwrite(NODE *arg) {
FILE *tmp;
NODE *margs;
if (writestream == NULL) {
/* Any setwrite finishes earlier write to string */
*print_stringptr = '\0';
writestream = stdout;
if (find_file(writer_name, FALSE) == NULL) {
/* pre-5.4 compatibility mode, implicitly close string */
margs = cons(car(writer_name),
cons(make_strnode(write_buf, NULL, strlen(write_buf),
STRING, strnzcpy),
NIL));
lmake(margs);
free(write_buf);
}
writer_name = NIL;
}
if (car(arg) == NIL) {
writestream = stdout;
writer_name = NIL;
} else if (is_list(car(arg))) { /* print to string */
FIXNUM i = int_arg(cdar(arg));
if ((tmp = find_file(car(arg), FALSE)) != NULL) {
writestream = NULL;
writer_name = car(arg);
print_stringptr = (char *)tmp + strlen((char *)tmp);
print_stringlen = i - strlen((char *)tmp);
} else if (NOT_THROWING && i > 0 && cddr(car(arg)) == NIL) {
writestream = NULL;
writer_name = copy_list(car(arg));
print_stringptr = write_buf = (char *)malloc(i);
print_stringlen = i;
} else err_logo(BAD_DATA_UNREC, car(arg));
} else if ((tmp = find_file(car(arg), FALSE)) != NULL) {
writestream = tmp;
writer_name = car(arg);
} else
err_logo(NOT_OPEN_ERROR, car(arg));
return(UNBOUND);
}
LISP lgdPoint(LISP args)
{ LISP result,l;
long iflag,j,m,n = nlength(args);
gdPointPtr pt;
if ((n % 2) || (!n))
err("must be an even positive length",args);
m = n / 2;
result = cons(NIL,NIL);
result->type = tc_gdpoint;
iflag = no_interrupt(1);
pt = (gdPointPtr) must_malloc(sizeof(gdPoint) * m);
result->storage_as.string.data = (char *) pt;
result->storage_as.string.dim = m;
no_interrupt(iflag);
for(j=0,l=args; j<m; ++j,l=cddr(l))
{ pt[j].x = get_c_long(car(l));
pt[j].y = get_c_long(cadr(l));
}
return(result);
}
bool isSized(refObject type)
{ if (tag(type) == markedTag)
{ return true; }
else
{ switch (toHook(car(type)))
{ case arrayHook:
{ return isSized(caddr(type)); }
case char0Hook:
case char1Hook:
case int0Hook:
case int1Hook:
case int2Hook:
case nullHook:
case procHook:
case real0Hook:
case real1Hook:
case strTypeHook:
case voidHook:
{ return true; }
case referHook:
case rowHook:
{ if (hasForward(type))
{ return true; }
else
{ tag(type) = markedTag;
flag = isSized(cadr(type));
tag(type) = pairTag;
return flag; }}
case skoHook:
case varHook:
{ return isSized(cadr(type)); }
case tupleHook:
{ type = cdr(type);
while (type != nil)
{ if (isSized(car(type)))
{ type = cddr(type); }
else
{ return false; }}
return true; }
default:
{ return false; }}}}
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!"); }}}
LISPTR apply(LISPTR f, LISPTR args)
{
if (symbolp(f)) {
// get the function binding of f
f = symbol_function(f);
if (consp(f)) {
// function defined as S-expr
if (car(f) == LAMBDA) {
LISPTR oldBindings = lexvars;
// bind formal arguments to evaluated actual arguments:
lexvars = bind_args(cadr(f), args, lexvars);
f = progn(cddr(f));
lexvars = oldBindings;
}
} else if (compiled_function_p(f)) {
// call compiled function with args
f = call_compiled_fn(f, args);
}
}
return f;
}
/* Apply a procedure expression to a list of expressions */
static exp_t *
prim_apply(exp_t *args)
{
exp_t *op, *prev, *last;
if (isnull(args) || isnull(cdr(args)))
everr("apply: expects at least 2 arguments, given", args);
op = car(args);
if (!isnull(last = cddr(args))) {
for (prev = cdr(args); !isnull(cdr(last)); last = cdr(last))
prev = last;
cdr(prev) = car(last);
args = cdr(args);
} else {
last = cdr(args);
args = car(last);
}
if (!islist(car(last)))
everr("apply: should be a proper list", car(last));
return apply(op, args);
}
unsigned long long uint64_value(char *src, cell x) {
unsigned long long v, ov;
cell p;
cell seg;
char msg[128];
v = seg = cadr(x);
if (seg < 0) {
sprintf(msg, "%s: expected positive value, got", src);
return error(msg, x);
}
p = cddr(x);
while (p != NIL) {
ov = v;
v = v * S9_INT_SEG_LIMIT + car(p);
if ((v - car(p)) / S9_INT_SEG_LIMIT != ov || v < ov) {
sprintf(msg, "%s: integer too big", src);
return error(msg, x);
}
p = cdr(p);
}
return v;
}
