// (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;
}
static environment_t* rename(environment_t* e, cons_t* ids)
{
assert_type(PAIR, ids);
// build a new environment and return it
environment_t *r = null_environment();
// TODO: Below code runs in slow O(n^2) time
for ( dict_t::const_iterator i = e->symbols.begin();
i != e->symbols.end(); ++i )
{
std::string name = (*i).first;
// find new name
for ( cons_t *id = ids; !nullp(id); id = cdr(id) ) {
assert_type(PAIR, car(id));
assert_type(SYMBOL, caar(id));
assert_type(SYMBOL, cadar(id));
if ( symbol_name(caar(id)) == name ) {
name = symbol_name(cadar(id));
break;
}
}
r->symbols[name] = (*i).second;
}
return r;
}
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);
}
NODE *lclose(NODE *arg) {
FILE *tmp;
NODE *margs;
if ((tmp = find_file(car(arg), TRUE)) == NULL)
err_logo(NOT_OPEN_ERROR, car(arg));
else if (is_list (car(arg))) {
margs = cons(caar(arg),
cons(make_strnode((char *)tmp, NULL, strlen((char *)tmp),
STRING, strnzcpy),
NIL));
lmake(margs);
free((char *)tmp);
} else
fclose(tmp);
if ((is_list(car(arg)) && car(arg) == writer_name) ||
(!is_list(car(arg)) &&
(compare_node(car(arg), writer_name, FALSE) == 0))) {
writer_name = NIL;
writestream = stdout;
}
if ((is_list(car(arg)) && car(arg) == reader_name) ||
(!is_list(car(arg)) &&
(compare_node(car(arg), reader_name, FALSE) == 0))) {
reader_name = NIL;
readstream = stdin;
}
return(UNBOUND);
}
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);
}
int assv(int obj, int lis){
while(!nullp(lis))
if(eqvp(obj,caar(lis)))
return(car(lis));
else
lis = cdr(lis);
return(BOOLF);
}
int assoc(int sym, int lis){
if(nullp(lis))
return(0);
else if(eqp(sym, caar(lis)))
return(car(lis));
else
return(assoc(sym,cdr(lis)));
}
// (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;
}
}
/*FUNCTION*/
LVAL c_nthsassoc(tpLspObject pLSP,
LVAL p,
char *s,
int n
){
/*noverbatim
CUT*/
LVAL fp;
if( null(p) || !consp(p) )return NIL;
for( fp = p ; fp ; fp = cdr(fp) )
if( !car(fp) || !consp(car(fp)) || !symbolp(caar(fp)) )
continue;
else
if( symcmp(caar(fp),s) && !--n )return car(fp);
return NIL;
}
/* Return the first element of a pair */
static exp_t *
prim_car(exp_t *args)
{
chkargs("car", args, 1);
if (!ispair(car(args)))
everr("car: the argument isn't a pair", car(args));
return caar(args);
}
// Handy for pretty-printing local variables in an env
char* print_env(cell c) {
if (!buf) {
buf = GC_MALLOC(64);
buf_len = 64;
}
buf_index = 0;
catf("(");
while (IS_PAIR(c)) {
if (!IS_PAIR(car(c))) break;
if (TYPE(caar(c)) != SYMBOL) break;
if (!strcmp(SYM_STR(caar(c)), "GLOBALS")) break;
catf("\n%20s . ", SYM_STR(caar(c)));
print(cadr(c));
c = cdr(c);
}
catf(")");
return buf;
}
pointer lookup_symbol(pointer sym)
{
pointer iter = env;
while (iter != NULL) {
if (sym_eq(sym, caar(iter)))
return car(iter);
iter = cdr(iter);
}
return iter;
}
// (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);
}
int f_oblist(int arglist){
int addr,addr1,res;
checkarg(LEN0_TEST, "oblist", arglist);
res = NIL;
addr = ep;
while(!(nullp(addr))){
addr1 = caar(addr);
res = cons(addr1,res);
addr = cdr(addr);
}
return(res);
}
/*-------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)));
}
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);
}
}
}
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);
}
object *car_proc(object *arguments) {
return caar(arguments);
}
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)));
}
}
/*
* 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;
}
static OBJ analyze_r(const struct analyze_t *arg)
{
OBJ op;
OBJ ret;
struct analyze_t new_arg;
new_arg = *arg;
ret = OBJ_NULL;
if (is_self_evaluating(new_arg.sexp))
ret = new_arg.sexp;
else if (is_variable(new_arg.sexp))
ret = analyze_variable_cell(new_arg.sexp,new_arg.env,new_arg.macro,new_arg.params,new_arg.macro_expand_env);
else if(obj_pairp(new_arg.sexp))
{
if(obj_pairp(car(new_arg.sexp)))
{
new_arg.sexp = car(new_arg.sexp);
op = fake_eval(&new_arg);
new_arg = *arg;
}
else
op = analyze_variable_value(car(new_arg.sexp),new_arg.env,new_arg.macro,new_arg.params,new_arg.macro_expand_env);
if(op == OBJ_NULL) /* error handle---fixme!! */
return OBJ_NULL;
if(obj_corep(op))
{
switch(obj_core_type(op))
{
case DEFINE:
case DEFINE_SYNTAX:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_define(&new_arg);
break;
case SET:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_set(&new_arg);
break;
case IF:
ret = analyze_if(cdr(new_arg.sexp),new_arg.env,new_arg.tail);
break;
case QUOTE:
ret = obj_make_quote(cadr(new_arg.sexp));
break;
case BEGIN:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_begin(&new_arg);
break;
case LAMBDA:
new_arg.sexp = cdr(new_arg.sexp);
ret = analyze_lambda(&new_arg);
break;
case SYNTAX_RULES:
ret = analyze_syntax_rules(cdr(new_arg.sexp),new_arg.env);
break;
default:
fprintf(stderr,"unknown core tag\n");
}
}
else if(obj_syntaxp(op))
{
OBJ params;
OBJ data;
OBJ patten;
OBJ template;
int match;
match = 0;
data = obj_syntax_data(op);
while(obj_pairp(data))
{
patten = caar(data);
VCSI_OBJECT cdaar(VCSI_CONTEXT vc,
VCSI_OBJECT x) {
return cdr(vc,caar(vc,x));
}
//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);
}
forlist (ptr in list) {
if (strequal(key, name(caar(ptr))) is 0) {
return car(ptr);
}
}
static data_t *get_let_var(const data_t *assignment) {
if(assignment == NULL)
return NULL;
return cons(caar(assignment), get_let_var(cdr(assignment)));
}
// (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);
}