// (job 'lst . prg) -> any
any doJob(any ex) {
any x = cdr(ex);
any y = EVAL(car(x));
cell c1;
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[length(y)];
} f;
Push(c1,y);
f.link = Env.bind, Env.bind = (bindFrame*)&f;
f.i = f.cnt = 0;
while (isCell(y)) {
f.bnd[f.cnt].sym = caar(y);
f.bnd[f.cnt].val = val(caar(y));
val(caar(y)) = cdar(y);
++f.cnt, y = cdr(y);
}
x = prog(cdr(x));
for (f.cnt = 0, y = Pop(c1); isCell(y); ++f.cnt, y = cdr(y)) {
cdar(y) = val(caar(y));
val(caar(y)) = f.bnd[f.cnt].val;
}
Env.bind = f.link;
return x;
}
void lock_lease_exclusive(Worker *worker, Lease *lease) {
List *cleanup = worker->cleanup;
List *prev = NULL;
worker_attempt_to_acquire(worker, lease->wait_for_update);
/* clean out any regular locks that we hold on this lease */
while (lease->inflight > 0 && !null(cleanup)) {
if (caar(cleanup) == (void *) LOCK_LEASE && cdar(cleanup) == lease) {
lease->inflight--;
if (null(prev))
worker->cleanup = cdr(cleanup);
else
setcdr(prev, cdr(cleanup));
} else {
prev = cleanup;
}
cleanup = cdr(cleanup);
}
/* prevent any new transactions starting and signal our interest */
lease->wait_for_update = worker;
/* want for existing inflight transactions to finish */
if (lease->inflight > 0)
longjmp(worker->jmp, WORKER_BLOCKED);
/* only add to the cleanup list once we've succeeded */
worker_cleanup_add(worker, LOCK_LEASE_EXCLUSIVE, lease);
}
static void putSrc(any s, any k) {
if (!isNil(val(Dbg)) && !isExt(s) && InFile && InFile->name) {
any x, y;
cell c1;
Push(c1, boxCnt(InFile->src));
data(c1) = cons(data(c1), mkStr(InFile->name));
x = get(s, Dbg);
if (!k) {
if (isNil(x))
put(s, Dbg, cons(data(c1), Nil));
else
car(x) = data(c1);
}
else if (isNil(x))
put(s, Dbg, cons(Nil, cons(data(c1), Nil)));
else {
for (y = cdr(x); isCell(y); y = cdr(y))
if (caar(y) == k) {
cdar(y) = data(c1);
drop(c1);
return;
}
cdr(x) = cons(cons(k, data(c1)), cdr(x));
}
drop(c1);
}
}
/*
* Transform
*
* (case-lambda
* ((<form1> <body1>)
* (<form2> <body2>)
* ...)
*
* to
*
* (lambda args
* (cond
* (((if (variadic? <form1>) >= =) (length args) <form1-min-args>)
* (apply (lambda (<form1>) <body1>) args))
* ...))
*/
cons_t* proc_case_lambda(cons_t* p, environment_t* e)
{
cons_t *cond_cases = list();
cons_t *cases = p;
for ( cons_t* c = cases; !nullp(c); c = cdr(c) ) {
cons_t *formals = caar(c);
cons_t *body = cdar(c);
// ((if (variadic? <form1>) >= =) argc <form1-min-args>)
cons_t* cond_if =
cons(symbol(variadicp(formals)? ">=" : "="),
cons(cons(symbol("length"), cons(symbol("args"))),
cons(integer(min_args(formals)))));
// (apply (lambda (<form1>) <body1>) args)
cons_t *cond_then =
cons(symbol("apply"),
cons(cons(symbol("lambda"),
cons(formals, body)),
cons(symbol("args"))));
cond_cases = append(cond_cases, list(list(cond_if, cond_then)));
}
cond_cases = splice(cons(symbol("cond")), cond_cases);
return make_closure(symbol("args"), cons(cond_cases), e);
}
/* Return the second element of a pair */
static exp_t *
prim_cdr(exp_t *args)
{
chkargs("cdr", args, 1);
if (!ispair(car(args)))
everr("cdr: the argument isn't a pair", car(args));
return cdar(args);
}
// (nond ('any1 . prg1) ('any2 . prg2) ..) -> any
any doNond(any x) {
any a;
while (isCell(x = cdr(x))) {
if (isNil(a = EVAL(caar(x))))
return prog(cdar(x));
val(At) = a;
}
return Nil;
}
// (cond ('any1 . prg1) ('any2 . prg2) ..) -> any
any doCond(any x) {
any a;
while (isCell(x = cdr(x))) {
if (!isNil(a = EVAL(caar(x)))) {
val(At) = a;
return prog(cdar(x));
}
}
return Nil;
}
// (dm sym . fun|cls2) -> sym
// (dm (sym . cls) . fun|cls2) -> sym
// (dm (sym sym2 [. cls]) . fun|cls2) -> sym
any doDm(any ex) {
any x, y, msg, cls;
x = cdr(ex);
if (!isCell(car(x)))
msg = car(x), cls = val(Class);
else {
msg = caar(x);
cls = !isCell(cdar(x))? cdar(x) :
get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x));
}
if (msg != T)
redefine(ex, msg, val(Meth));
if (isSym(cdr(x))) {
y = val(cdr(x));
for (;;) {
if (!isCell(y) || !isCell(car(y)))
err(ex, msg, "Bad message");
if (caar(y) == msg) {
x = car(y);
break;
}
y = cdr(y);
}
}
for (y = val(cls); isCell(y) && isCell(car(y)); y = cdr(y))
if (caar(y) == msg) {
if (!equal(cdr(x), cdar(y)))
redefMsg(msg, cls);
cdar(y) = cdr(x);
putSrc(cls, msg);
return msg;
}
if (!isCell(car(x)))
val(cls) = cons(x, val(cls));
else
val(cls) = cons(cons(msg, cdr(x)), val(cls));
putSrc(cls, msg);
return msg;
}
END_TEST
START_TEST (test_pair_ops)
{
make_singletons();
object *o1 = cons (make_string ("testing"), make_boolean (true));
object *o2 = cons (make_character ('a'), make_fixnum (5));
object *o3 = cons (o1, o2);
ck_assert (o3->type == PAIR);
ck_assert (car(o3)->type == PAIR);
ck_assert_str_eq (caar(o3)->data.string.value, "testing");
ck_assert ((cdar(o3))->type == BOOLEAN);
}
/*-------Environment-------*/
pointer environment_make2(VM, pointer rib, pointer env) {
pointer t;
save(vm, rib);
save(vm, env);
t = table_alloc(vm);
while (!AR_ISNIL(rib)) {
table_insert(vm, t, caar(rib), cdar(rib));
rib = cdr(rib);
}
unsave(vm, 2);
return tagged_alloc(vm, vm->s_environment, cons(t,AR_ISNIL(env)?vm->nil:rep(env)));
}
// (bind 'sym|lst . prg) -> any
any doBind(any ex) {
any x, y;
x = cdr(ex);
if (isNum(y = EVAL(car(x))))
argError(ex, y);
if (isNil(y))
return prog(cdr(x));
if (isSym(y)) {
bindFrame f;
Bind(y,f);
x = prog(cdr(x));
Unbind(f);
return x;
}
{
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[length(y)];
} f;
f.link = Env.bind, Env.bind = (bindFrame*)&f;
f.i = f.cnt = 0;
do {
if (isNum(car(y)))
argError(ex, car(y));
if (isSym(car(y))) {
f.bnd[f.cnt].sym = car(y);
f.bnd[f.cnt].val = val(car(y));
}
else {
f.bnd[f.cnt].sym = caar(y);
f.bnd[f.cnt].val = val(caar(y));
val(caar(y)) = cdar(y);
}
++f.cnt;
} while (isCell(y = cdr(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;
}
}
void worker_cleanup(Worker *worker) {
while (!null(worker->cleanup)) {
enum lock_types type = (enum lock_types) caar(worker->cleanup);
void *obj = cdar(worker->cleanup);
worker->cleanup = cdr(worker->cleanup);
switch (type) {
case LOCK_DIRECTORY:
cleanup(struct objectdir);
break;
case LOCK_OPENFILE:
cleanup(struct openfile);
break;
case LOCK_FID:
cleanup(Fid);
break;
case LOCK_WALK:
cleanup(Walk);
break;
case LOCK_CLAIM:
cleanup(Claim);
claim_release((Claim *) obj);
break;
case LOCK_LEASE:
unlock_lease_cleanup(worker, (Lease *) obj);
break;
case LOCK_LEASE_EXCLUSIVE:
((Lease *) obj)->wait_for_update = NULL;
break;
case LOCK_REMOTE_FID:
if (vector_get(fid_remote_vector, (u32) obj) ==
(void *) 0xdeadbeef)
{
fid_release_remote((u32) obj);
}
break;
case LOCK_RAW:
raw_delete((u8 *) obj);
break;
default:
assert(0);
}
}
}
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);
}
void worker_cleanup_remove(Worker *worker, enum lock_types type, void *object) {
List *prev = NULL;
List *cur = worker->cleanup;
while (!null(cur)) {
if (caar(cur) == (void *) type && cdar(cur) == object) {
if (prev == NULL)
worker->cleanup = cdr(cur);
else
setcdr(prev, cdr(cur));
return;
}
prev = cur;
cur = cdr(cur);
}
/* fail if we didn't find the requested entry */
assert(0);
}
static pointer apply(pointer expr)
{
pointer tmp_op, result, farg, expanded;
int flags;
tmp_op = eval(sexpr_get_op(expr));
switch (op_type(tmp_op)) {
case T_BUILT_IN_REGULAR_PROC:
save_continuation(cont_env | cont_arg | cont_op);
op = tmp_op;
arg = eval_arg_list(sexpr_get_arg(expr));
result = (op_get_bltin_proc_code(op))();
restore_continuation(cont_env | cont_arg | cont_op);
break;
case T_BUILT_IN_SPECIAL_PROC:
if (strcmp("set!", op_get_bltin_proc_name(tmp_op)) == 0 ||
strcmp("defmacro", op_get_bltin_proc_name(tmp_op)) == 0)
flags = cont_arg | cont_op;
else
flags = cont_env | cont_arg | cont_op;
save_continuation(flags);
op = tmp_op;
arg = sexpr_get_arg(expr);
result = (op_get_bltin_proc_code(op))();
restore_continuation(flags);
break;
case T_EXTEND_PROC:
save_continuation(cont_env | cont_arg | cont_op);
op = tmp_op;
arg = eval_arg_list(sexpr_get_arg(expr));
env = op_get_ext_proc_env(op);
farg = op_get_ext_proc_farg(op);
while (farg != NULL) {
if (ispair(car(farg))) {
add_new_binding(car(cdar(farg)), arg);
break;
}
add_new_binding(car(farg), car(arg));
farg = cdr(farg);
arg = cdr(arg);
}
result = eval(op_get_ext_proc_body(op));
restore_continuation(cont_env | cont_arg | cont_op);
break;
case T_MACRO:
save_continuation(cont_env | cont_arg | cont_op);
op = tmp_op;
arg = sexpr_get_arg(expr);
env = op_get_macro_env(op);
farg = op_get_macro_farg(op);
while (farg != NULL) {
if (ispair(car(farg))) {
add_new_binding(car(cdar(farg)), arg);
break;
}
add_new_binding(car(farg), car(arg));
farg = cdr(farg);
arg = cdr(arg);
}
expanded = eval(op_get_macro_body(op));
restore_continuation(cont_env | cont_arg | cont_op);
result = eval(expanded);
break;
}
return result;
}
/*
* 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;
}
// (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doFor(any x) {
any y, body, cond, a;
cell c1;
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[2];
} f;
f.link = Env.bind, Env.bind = (bindFrame*)&f;
f.i = 0;
if (!isCell(y = car(x = cdr(x))) || !isCell(cdr(y))) {
if (!isCell(y)) {
f.cnt = 1;
f.bnd[0].sym = y;
f.bnd[0].val = val(y);
}
else {
f.cnt = 2;
f.bnd[0].sym = cdr(y);
f.bnd[0].val = val(cdr(y));
f.bnd[1].sym = car(y);
f.bnd[1].val = val(car(y));
val(f.bnd[1].sym) = Zero;
}
y = Nil;
x = cdr(x), Push(c1, EVAL(car(x)));
if (isNum(data(c1)))
val(f.bnd[0].sym) = Zero;
body = x = cdr(x);
for (;;) {
if (isNum(data(c1))) {
val(f.bnd[0].sym) = bigCopy(val(f.bnd[0].sym));
digAdd(val(f.bnd[0].sym), 2);
if (bigCompare(val(f.bnd[0].sym), data(c1)) > 0)
break;
}
else {
if (!isCell(data(c1)))
break;
val(f.bnd[0].sym) = car(data(c1));
if (!isCell(data(c1) = cdr(data(c1))))
data(c1) = Nil;
}
if (f.cnt == 2) {
val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
digAdd(val(f.bnd[1].sym), 2);
}
do {
if (!isNum(y = car(x))) {
if (isSym(y))
y = val(y);
else if (isNil(car(y))) {
y = cdr(y);
if (isNil(a = EVAL(car(y)))) {
y = prog(cdr(y));
goto for1;
}
val(At) = a;
y = Nil;
}
else if (car(y) == T) {
y = cdr(y);
if (!isNil(a = EVAL(car(y)))) {
val(At) = a;
y = prog(cdr(y));
goto for1;
}
y = Nil;
}
else
y = evList(y);
}
} while (isCell(x = cdr(x)));
x = body;
}
for1:
drop(c1);
if (f.cnt == 2)
val(f.bnd[1].sym) = f.bnd[1].val;
val(f.bnd[0].sym) = f.bnd[0].val;
Env.bind = f.link;
return y;
}
if (!isCell(car(y))) {
f.cnt = 1;
f.bnd[0].sym = car(y);
f.bnd[0].val = val(car(y));
}
else {
f.cnt = 2;
f.bnd[0].sym = cdar(y);
f.bnd[0].val = val(cdar(y));
f.bnd[1].sym = caar(y);
f.bnd[1].val = val(caar(y));
val(f.bnd[1].sym) = Zero;
}
y = cdr(y);
val(f.bnd[0].sym) = EVAL(car(y));
y = cdr(y), cond = car(y), y = cdr(y);
Push(c1,Nil);
body = x = cdr(x);
while (!isNil(a = EVAL(cond))) {
val(At) = a;
if (f.cnt == 2) {
val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
digAdd(val(f.bnd[1].sym), 2);
}
do {
if (!isNum(data(c1) = car(x))) {
if (isSym(data(c1)))
data(c1) = val(data(c1));
else if (isNil(car(data(c1)))) {
data(c1) = cdr(data(c1));
if (isNil(a = EVAL(car(data(c1))))) {
data(c1) = prog(cdr(data(c1)));
goto for2;
}
val(At) = a;
data(c1) = Nil;
}
else if (car(data(c1)) == T) {
data(c1) = cdr(data(c1));
if (!isNil(a = EVAL(car(data(c1))))) {
val(At) = a;
data(c1) = prog(cdr(data(c1)));
goto for2;
}
data(c1) = Nil;
}
else
data(c1) = evList(data(c1));
}
} while (isCell(x = cdr(x)));
if (isCell(y))
val(f.bnd[0].sym) = prog(y);
x = body;
}
for2:
if (f.cnt == 2)
val(f.bnd[1].sym) = f.bnd[1].val;
val(f.bnd[0].sym) = f.bnd[0].val;
Env.bind = f.link;
return Pop(c1);
}
void load_library_index()
{
if ( library_map != NULL )
return;
std::string filename = library_file(library_index_file);
environment_t *env = null_environment();
program_t *p = parse(slurp(open_file(filename)), env);
cons_t *index = p->root;
if ( !pairp(index) || !symbolp(caar(index)) )
invalid_index_format(filename + ": no list with symbols");
for ( ; !nullp(index); index = cdr(index) ) {
if ( symbol_name(caar(index)) == "define-library-index" ) {
if ( library_map != NULL )
invalid_index_format(filename + ": only one define-library-index allowed");
if ( !listp(cdar(index)) ) {
invalid_index_format(filename
+ ": define-library-index is not a list");
}
size_t len = length(cdar(index));
library_map = (library_map_t*) malloc((1+len)*sizeof(library_map_t));
size_t i = 0;
for ( cons_t *lib = cdar(index); !nullp(lib); lib = cdr(lib), ++i ) {
cons_t *name = caar(lib);
cons_t *file = cadar(lib);
if ( !listp(name) || !stringp(file) )
invalid_index_format(filename + ": not list/string pair");
library_map[i].library_name = strdup(sprint(name).c_str());
library_map[i].source_file = strdup(file->string);
}
// important to signal end of list:
library_map[i].library_name = NULL;
library_map[i].source_file = NULL;
continue;
} else if ( symbol_name(caar(index)) == "define-repl-imports" ) {
if ( repl_libraries != NULL )
invalid_index_format(filename + ": only one define-repl-imports allowed");
if ( !listp(cdar(index)) ) {
invalid_index_format(filename
+ ": define-repl-imports is not a list");
}
size_t len = length(cdar(index));
repl_libraries = (const char**) malloc((1+len)*sizeof(char*));
const char **s = repl_libraries;
for ( cons_t *lib = cdar(index); !nullp(lib); lib = cdr(lib), ++s ) {
cons_t *name = car(lib);
*s = strdup(sprint(name).c_str());
}
*s = NULL;
continue;
} else
invalid_index_format(filename + ": unknown label "
+ sprint(caar(index)));
}
}
object *cdr_proc(object *arguments) {
return cdar(arguments);
}
VCSI_OBJECT cddar(VCSI_CONTEXT vc,
VCSI_OBJECT x) {
return cdr(vc,cdar(vc,x));
}
