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);
}
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);
}
int main(int argc, char *argv[])
{
void *fdt1, *fdt2;
uint32_t cpuid1, cpuid2;
test_init(argc, argv);
if ((argc != 3)
&& ((argc != 4) || !streq(argv[1], "-n")))
CONFIG("Usage: %s [-n] <dtb file> <dtb file>", argv[0]);
if (argc == 4)
notequal = 1;
fdt1 = load_blob(argv[argc-2]);
fdt2 = load_blob(argv[argc-1]);
compare_mem_rsv(fdt1, fdt2);
compare_node(fdt1, 0, fdt2, 0);
cpuid1 = fdt_boot_cpuid_phys(fdt1);
cpuid2 = fdt_boot_cpuid_phys(fdt2);
if (cpuid1 != cpuid2)
MISMATCH("boot_cpuid_phys mismatch 0x%x != 0x%x",
cpuid1, cpuid2);
MATCH();
}
/* Check if a local variable is already in this frame */
int not_local(NODE *name, NODE *sp) {
for ( ; sp != var; sp = cdr(sp)) {
if (compare_node(car(sp),name,TRUE) == 0) {
return FALSE;
}
}
return TRUE;
}
/* Helper function */
NODE *assoc(NODE *name, NODE *alist) {
while (alist != NIL) {
if (compare_node(name, car(alist), TRUE) == 0)
return alist;
alist = cdr(alist);
}
return(NIL);
}
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);
}
static gboolean
path_test_get_nodes (CallbackData *data)
{
GSList *list, *node;
data->nodes_found = 0;
data->nodes_different = FALSE;
list = clutter_path_get_nodes (data->path);
for (node = list; node; node = node->next)
compare_node (node->data, data);
g_slist_free (list);
return !data->nodes_different && data->nodes_found == data->n_nodes;
}
static gboolean
path_test_get_node (CallbackData *data)
{
int i;
data->nodes_found = 0;
data->nodes_different = FALSE;
for (i = 0; i < data->n_nodes; i++)
{
ClutterPathNode node;
clutter_path_get_node (data->path, i, &node);
compare_node (&node, data);
}
return !data->nodes_different;
}
int main(int argc, char *argv[])
{
void *fdt1, *fdt2;
uint32_t cpuid1, cpuid2;
char **args;
int argsleft;
test_init(argc, argv);
args = &argv[1];
argsleft = argc - 1;
while (argsleft > 2) {
if (streq(args[0], "-n"))
notequal = 1;
else if (streq(args[0], "-m"))
ignore_memrsv = 1;
else
badargs(argv);
args++;
argsleft--;
}
if (argsleft != 2)
badargs(argv);
fdt1 = load_blob(args[0]);
fdt2 = load_blob(args[1]);
if (!ignore_memrsv)
compare_mem_rsv(fdt1, fdt2);
compare_node(fdt1, 0, fdt2, 0);
cpuid1 = fdt_boot_cpuid_phys(fdt1);
cpuid2 = fdt_boot_cpuid_phys(fdt2);
if (cpuid1 != cpuid2)
MISMATCH("boot_cpuid_phys mismatch 0x%x != 0x%x",
cpuid1, cpuid2);
MATCH();
}
FILE *find_file(NODE *arg, BOOLEAN remove) {
NODE *t, *prev = NIL;
FILE *fp = NULL;
t = file_list;
while (t != NIL) {
if ((is_list(arg) && arg == car(t)) ||
(!is_list(arg) && (compare_node(arg, car(t), FALSE) == 0))) {
fp = (FILE *)t->n_obj;
if (remove) {
t->n_obj = NIL;
if (prev == NIL)
file_list = cdr(t);
else
setcdr(prev, cdr(t));
}
break;
}
prev = t;
t = cdr(t);
}
return fp;
}
static void compare_subnodes(const void *fdt1, int offset1,
const void *fdt2, int offset2,
int recurse)
{
int coffset1, coffset2, depth;
for (depth = 0, coffset1 = offset1;
(coffset1 >= 0) && (depth >= 0);
coffset1 = fdt_next_node(fdt1, coffset1, &depth))
if (depth == 1) {
const char *name = fdt_get_name(fdt1, coffset1, NULL);
verbose_printf("Subnode %s\n", name);
coffset2 = fdt_subnode_offset(fdt2, offset2, name);
if (coffset2 == -FDT_ERR_NOTFOUND)
MISMATCH("Subnode %s missing\n", name);
else if (coffset2 < 0)
FAIL("fdt_subnode_offset(): %s\n",
fdt_strerror(coffset2));
if (recurse)
compare_node(fdt1, coffset1, fdt2, coffset2);
}
}
static int test(void)
{
pj_rbtree rb;
node_key *key;
pj_rbtree_node *node;
pj_pool_t *pool;
int err=0;
int count = MIN_COUNT;
int i;
unsigned size;
pj_rbtree_init(&rb, (pj_rbtree_comp*)&compare_node);
size = MAX_COUNT*(sizeof(*key)+PJ_RBTREE_NODE_SIZE) +
PJ_RBTREE_SIZE + PJ_POOL_SIZE;
pool = pj_pool_create( mem, "pool", size, 0, NULL);
if (!pool) {
PJ_LOG(3,("test", "...error: creating pool of %u bytes", size));
return -10;
}
key = (node_key *)pj_pool_alloc(pool, MAX_COUNT*sizeof(*key));
if (!key)
return -20;
node = (pj_rbtree_node*)pj_pool_alloc(pool, MAX_COUNT*sizeof(*node));
if (!node)
return -30;
for (i=0; i<LOOP; ++i) {
int j;
pj_rbtree_node *prev, *it;
pj_timestamp t1, t2, t_setup, t_insert, t_search, t_erase;
pj_assert(rb.size == 0);
t_setup.u32.lo = t_insert.u32.lo = t_search.u32.lo = t_erase.u32.lo = 0;
for (j=0; j<count; j++) {
randomize_string(key[j].str, STRSIZE);
pj_get_timestamp(&t1);
node[j].key = &key[j];
node[j].user_data = key[j].str;
key[j].hash = pj_hash_calc(0, key[j].str, PJ_HASH_KEY_STRING);
pj_get_timestamp(&t2);
t_setup.u32.lo += (t2.u32.lo - t1.u32.lo);
pj_get_timestamp(&t1);
pj_rbtree_insert(&rb, &node[j]);
pj_get_timestamp(&t2);
t_insert.u32.lo += (t2.u32.lo - t1.u32.lo);
}
pj_assert(rb.size == (unsigned)count);
// Iterate key, make sure they're sorted.
prev = NULL;
it = pj_rbtree_first(&rb);
while (it) {
if (prev) {
if (compare_node((node_key*)prev->key,(node_key*)it->key)>=0) {
++err;
PJ_LOG(3, (THIS_FILE, "Error: %s >= %s",
(char*)prev->user_data, (char*)it->user_data));
}
}
prev = it;
it = pj_rbtree_next(&rb, it);
}
// Search.
for (j=0; j<count; j++) {
pj_get_timestamp(&t1);
it = pj_rbtree_find(&rb, &key[j]);
pj_get_timestamp(&t2);
t_search.u32.lo += (t2.u32.lo - t1.u32.lo);
pj_assert(it != NULL);
if (it == NULL)
++err;
}
// Erase node.
for (j=0; j<count; j++) {
pj_get_timestamp(&t1);
it = pj_rbtree_erase(&rb, &node[j]);
pj_get_timestamp(&t2);
t_erase.u32.lo += (t2.u32.lo - t1.u32.lo);
}
PJ_LOG(4, (THIS_FILE,
"...count:%d, setup:%d, insert:%d, search:%d, erase:%d",
count,
t_setup.u32.lo / count, t_insert.u32.lo / count,
t_search.u32.lo / count, t_erase.u32.lo / count));
count = 2 * count;
if (count > MAX_COUNT)
break;
}
pj_pool_release(pool);
return err;
}
/* An explicit control evaluator, taken almost directly from SICP, section
* 5.2. list is a flat list of expressions to evaluate. where is a label to
* begin at. Return value depends on where.
*/
NODE *evaluator(NODE *list, enum labels where) {
/* registers */
NODE *exp = NIL, /* the current expression */
*val = NIL, /* the value of the last expression */
*proc = NIL, /* the procedure definition */
*argl = NIL, /* evaluated argument list */
*unev = NIL, /* list of unevaluated expressions */
*stack = NIL, /* register stack */
*parm = NIL, /* the current formal */
*catch_tag = NIL,
*arg = NIL; /* the current actual */
/* registers that don't get reference counted, so we pretend they're ints */
FIXNUM vsp = 0, /* temp ptr into var_stack */
cont = 0, /* where to go next */
formals = (FIXNUM)NIL; /* list of formal parameters */
int i, nargs;
BOOLEAN tracing; /* are we tracing the current procedure? */
FIXNUM oldtailcall; /* in case of reentrant use of evaluator */
FIXNUM repcount; /* count for repeat */
FIXNUM old_ift_iff;
oldtailcall = tailcall;
old_ift_iff = ift_iff_flag;
save2(var,this_line);
assign(var, var_stack);
save2(fun,ufun);
cont = (FIXNUM)all_done;
numsave((FIXNUM)cont);
newcont(where);
goto fetch_cont;
begin_line:
ref(list);
assign(this_line, list);
newcont(end_line);
begin_seq:
make_tree(list);
if (!is_tree(list)) {
assign(val, UNBOUND);
goto fetch_cont;
}
assign(unev, tree__tree(list));
assign(val, UNBOUND);
goto eval_sequence;
end_line:
if (val != UNBOUND) {
if (NOT_THROWING) err_logo(DK_WHAT, val);
deref(val);
}
val = NIL;
deref(list);
goto fetch_cont;
/* ----------------- EVAL ---------------------------------- */
tail_eval_dispatch:
tailcall = 1;
eval_dispatch:
switch (nodetype(exp)) {
case QUOTE: /* quoted literal */
assign(val, node__quote(exp));
goto fetch_cont;
case COLON: /* variable */
assign(val, valnode__colon(exp));
while (val == UNBOUND && NOT_THROWING)
assign(val, err_logo(NO_VALUE, node__colon(exp)));
goto fetch_cont;
case CONS: /* procedure application */
if (tailcall == 1 && is_macro(car(exp)) &&
is_list(procnode__caseobj(car(exp)))) {
/* tail call to user-defined macro must be treated as non-tail
* because the expression returned by the macro
* remains to be evaluated in the caller's context */
assign(unev, NIL);
goto non_tail_eval;
}
assign(fun, car(exp));
if (cdr(exp) != NIL)
goto ev_application;
else
goto ev_no_args;
default:
assign(val, exp); /* self-evaluating */
goto fetch_cont;
}
ev_no_args:
/* Evaluate an application of a procedure with no arguments. */
assign(argl, NIL);
goto apply_dispatch; /* apply the procedure */
ev_application:
/* Evaluate an application of a procedure with arguments. */
assign(unev, cdr(exp));
assign(argl, NIL);
mixsave(tailcall,var);
num2save(val_status,ift_iff_flag);
save2(didnt_get_output,didnt_output_name);
eval_arg_loop:
if (unev == NIL) goto eval_args_done;
assign(exp, car(unev));
if (exp == Not_Enough_Node) {
if (NOT_THROWING)
err_logo(NOT_ENOUGH, NIL);
goto eval_args_done;
}
save(argl);
save2(unev,fun);
save2(ufun,last_ufun);
save2(this_line,last_line);
assign(var, var_stack);
tailcall = -1;
val_status = 1;
assign(didnt_get_output,
cons_list(0,fun,ufun,this_line,END_OF_LIST));
assign(didnt_output_name, NIL);
newcont(accumulate_arg);
goto eval_dispatch; /* evaluate the current argument */
accumulate_arg:
/* Put the evaluated argument into the argl list. */
reset_args(var);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
assign(last_call, fun);
restore2(unev,fun);
restore(argl);
while (NOT_THROWING && val == UNBOUND) {
assign(val, err_logo(DIDNT_OUTPUT, NIL));
}
push(val, argl);
pop(unev);
goto eval_arg_loop;
eval_args_done:
restore2(didnt_get_output,didnt_output_name);
num2restore(val_status,ift_iff_flag);
mixrestore(tailcall,var);
if (stopping_flag == THROWING) {
assign(val, UNBOUND);
goto fetch_cont;
}
assign(argl, reverse(argl));
/* --------------------- APPLY ---------------------------- */
apply_dispatch:
/* Load in the procedure's definition and decide whether it's a compound
* procedure or a primitive procedure.
*/
proc = procnode__caseobj(fun);
if (is_macro(fun)) {
num2save(val_status,tailcall);
val_status = 1;
newcont(macro_return);
}
if (proc == UNDEFINED) {
if (ufun != NIL) {
untreeify_proc(ufun);
}
if (NOT_THROWING)
assign(val, err_logo(DK_HOW, fun));
else
assign(val, UNBOUND);
goto fetch_cont;
}
if (is_list(proc)) goto compound_apply;
/* primitive_apply */
if (NOT_THROWING)
assign(val, (*getprimfun(proc))(argl));
else
assign(val, UNBOUND);
#define do_case(x) case x: goto x;
fetch_cont:
{
enum labels x = (enum labels)cont;
cont = (FIXNUM)car(stack);
numpop(&stack);
switch (x) {
do_list(do_case)
default: abort();
}
}
compound_apply:
#ifdef mac
check_mac_stop();
#endif
#ifdef ibm
check_ibm_stop();
#endif
if (tracing = flag__caseobj(fun, PROC_TRACED)) {
for (i = 0; i < trace_level; i++) print_space(writestream);
trace_level++;
ndprintf(writestream, "( %s ", fun);
}
/* Bind the actuals to the formals */
vsp = (FIXNUM)var_stack; /* remember where we came in */
for (formals = (FIXNUM)formals__procnode(proc);
formals != (FIXNUM)NIL;
formals = (FIXNUM)cdr((NODE *)formals)) {
parm = car((NODE *)formals);
if (nodetype(parm) == INT) break; /* default # args */
if (argl != NIL) {
arg = car(argl);
if (tracing) {
print_node(writestream, maybe_quote(arg));
print_space(writestream);
}
} else
arg = UNBOUND;
if (nodetype(parm) == CASEOBJ) {
if (not_local(parm,(NODE *)vsp)) {
push(parm, var_stack);
setobject(var_stack, valnode__caseobj(parm));
}
tell_shadow(parm);
setvalnode__caseobj(parm, arg);
} else if (nodetype(parm) == CONS) {
/* parm is optional or rest */
if (not_local(car(parm),(NODE *)vsp)) {
push(car(parm), var_stack);
setobject(var_stack, valnode__caseobj(car(parm)));
}
tell_shadow(car(parm));
if (cdr(parm) == NIL) { /* parm is rest */
setvalnode__caseobj(car(parm), argl);
break;
}
if (arg == UNBOUND) { /* use default */
save2(fun,var);
save2(ufun,last_ufun);
save2(this_line,last_line);
save2(didnt_output_name,didnt_get_output);
num2save(ift_iff_flag,val_status);
assign(var, var_stack);
tailcall = -1;
val_status = 1;
mixsave(formals,argl);
numsave(vsp);
assign(list, cdr(parm));
if (NOT_THROWING)
make_tree(list);
else
assign(list, NIL);
if (!is_tree(list)) {
assign(val, UNBOUND);
goto set_args_continue;
}
assign(unev, tree__tree(list));
assign(val, UNBOUND);
newcont(set_args_continue);
goto eval_sequence;
set_args_continue:
numrestore(vsp);
mixrestore(formals,argl);
parm = car((NODE *)formals);
reset_args(var);
num2restore(ift_iff_flag,val_status);
restore2(didnt_output_name,didnt_get_output);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
restore2(fun,var);
arg = val;
}
setvalnode__caseobj(car(parm), arg);
}
if (argl != NIL) pop(argl);
}
if (check_throwing) {
assign(val, UNBOUND);
goto fetch_cont;
}
vsp = 0;
if (tracing = flag__caseobj(fun, PROC_TRACED)) {
if (NOT_THROWING) print_char(writestream, ')');
new_line(writestream);
save(fun);
newcont(compound_apply_continue);
}
assign(val, UNBOUND);
assign(last_ufun, ufun);
assign(ufun, fun);
assign(last_line, this_line);
assign(this_line, NIL);
proc = procnode__caseobj(fun);
assign(list, bodylist__procnode(proc)); /* get the body ... */
make_tree_from_body(list);
if (!is_tree(list)) {
goto fetch_cont;
}
assign(unev, tree__tree(list));
if (NOT_THROWING) stopping_flag = RUN;
assign(output_node, UNBOUND);
if (val_status == 1) val_status = 2;
else if (val_status == 5) val_status = 3;
else val_status = 0;
eval_sequence:
/* Evaluate each expression in the sequence. Stop as soon as
* val != UNBOUND.
*/
if (!RUNNING || val != UNBOUND) {
goto fetch_cont;
}
if (nodetype(unev) == LINE) {
assign(this_line, unparsed__line(unev));
if (flag__caseobj(ufun, PROC_STEPPED)) {
char junk[20];
if (tracing) {
int i = 1;
while (i++ < trace_level) print_space(stdout);
}
print_node(stdout, this_line);
ndprintf(stdout, " >>> ");
input_blocking++;
#ifndef TIOCSTI
if (!setjmp(iblk_buf))
#endif
#ifdef __ZTC__
ztc_getcr();
#else
fgets(junk, 19, stdin);
#endif
input_blocking = 0;
update_coords('\n');
}
}
assign(exp, car(unev));
pop(unev);
if (is_list(exp) && (is_tailform(procnode__caseobj(car(exp))))) {
if (nameis(car(exp),Output) || nameis(car(exp),Op)) {
assign(didnt_get_output,
cons_list(0,car(exp),ufun,this_line,END_OF_LIST));
assign(didnt_output_name, NIL);
if (val_status == 2 || val_status == 3) {
val_status = 1;
assign(exp, cadr(exp));
goto tail_eval_dispatch;
} else if (ufun == NIL) {
err_logo(AT_TOPLEVEL,car(exp));
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status < 4) {
val_status = 1;
assign(exp, cadr(exp));
assign(unev, NIL);
goto non_tail_eval; /* compute value then give error */
}
} else if (nameis(car(exp),Stop)) {
if (ufun == NIL) {
err_logo(AT_TOPLEVEL,car(exp));
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status == 0 || val_status == 3) {
assign(val, UNBOUND);
goto fetch_cont;
} else if (val_status < 4) {
assign(didnt_output_name, fun);
assign(val, UNBOUND);
goto fetch_cont;
}
} else { /* maybeoutput */
assign(exp, cadr(exp));
val_status = 5;
goto tail_eval_dispatch;
}
}
if (unev == NIL) {
if (val_status == 2 || val_status == 4) {
assign(didnt_output_name, fun);
assign(unev, UNBOUND);
goto non_tail_eval;
} else {
goto tail_eval_dispatch;
}
}
if (is_list(car(unev)) && nameis(car(car(unev)),Stop)) {
if ((val_status == 0 || val_status == 3) && ufun != NIL) {
goto tail_eval_dispatch;
} else if (val_status < 4) {
assign(didnt_output_name, fun);
goto tail_eval_dispatch;
}
}
non_tail_eval:
save2(unev,fun);
num2save(ift_iff_flag,val_status);
save2(ufun,last_ufun);
save2(this_line,last_line);
save(var);
assign(var, var_stack);
tailcall = 0;
newcont(eval_sequence_continue);
goto eval_dispatch;
eval_sequence_continue:
reset_args(var);
restore(var);
restore2(this_line,last_line);
restore2(ufun,last_ufun);
if (dont_fix_ift) {
num2restore(dont_fix_ift,val_status);
dont_fix_ift = 0;
} else
num2restore(ift_iff_flag,val_status);
restore2(unev,fun);
if (stopping_flag == MACRO_RETURN) {
if (unev == UNBOUND) assign(unev, NIL);
assign(unev, append(val, unev));
assign(val, UNBOUND);
stopping_flag = RUN;
if (unev == NIL) goto fetch_cont;
} else if (val_status < 4) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2 && NOT_THROWING) {
assign(didnt_output_name,Output);
err_logo(DIDNT_OUTPUT,Output);
}
if (val == UNBOUND && val_status == 1 && NOT_THROWING) {
assign(didnt_output_name,Stop);
err_logo(DIDNT_OUTPUT,Output);
}
goto fetch_cont;
}
}
if (val != UNBOUND) {
err_logo((unev == NIL ? DK_WHAT_UP : DK_WHAT), val);
assign(val, UNBOUND);
}
if (NOT_THROWING && (unev == NIL || unev == UNBOUND)) {
if (val_status != 4) err_logo(DIDNT_OUTPUT,NIL);
goto fetch_cont;
}
goto eval_sequence;
compound_apply_continue:
/* Only get here if tracing */
restore(fun);
--trace_level;
if (NOT_THROWING) {
for (i = 0; i < trace_level; i++) print_space(writestream);
print_node(writestream, fun);
if (val == UNBOUND)
ndprintf(writestream, " stops\n");
else {
ref(val);
ndprintf(writestream, " outputs %s\n", maybe_quote(val));
deref(val);
}
}
goto fetch_cont;
/* --------------------- MACROS ---------------------------- */
macro_return:
num2restore(val_status,tailcall);
while (!is_list(val) && NOT_THROWING) {
assign(val,err_logo(ERR_MACRO,val));
}
if (NOT_THROWING) {
if (is_cont(val)) {
newcont(cont__cont(val));
val->n_car = NIL;
assign(val, val__cont(val));
goto fetch_cont;
}
macro_reval:
if (tailcall == 0) {
make_tree(val);
stopping_flag = MACRO_RETURN;
if (!is_tree(val)) assign(val, NIL);
else assign(val, tree__tree(val));
goto fetch_cont;
}
assign(list,val);
goto begin_seq;
}
assign(val, UNBOUND);
goto fetch_cont;
runresult_continuation:
assign(list, val);
newcont(runresult_followup);
val_status = 5;
goto begin_seq;
runresult_followup:
if (val == UNBOUND) {
assign(val, NIL);
} else {
assign(val, cons(val, NIL));
}
goto fetch_cont;
repeat_continuation:
assign(list, cdr(val));
repcount = getint(car(val));
repeat_again:
assign(val, UNBOUND);
if (repcount == 0) goto fetch_cont;
mixsave(repcount,list);
num2save(val_status,tailcall);
val_status = 4;
newcont(repeat_followup);
goto begin_seq;
repeat_followup:
if (val != UNBOUND && NOT_THROWING) {
ref(val);
err_logo(DK_WHAT, val);
unref(val);
}
num2restore(val_status,tailcall);
mixrestore(repcount,list);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
goto fetch_cont;
}
}
if (repcount > 0) /* negative means forever */
--repcount;
#ifdef mac
check_mac_stop();
#endif
#ifdef ibm
check_ibm_stop();
#endif
if (RUNNING) goto repeat_again;
assign(val, UNBOUND);
goto fetch_cont;
catch_continuation:
assign(list, cdr(val));
assign(catch_tag, car(val));
if (compare_node(catch_tag,Error,TRUE) == 0) {
push(Erract, var_stack);
setobject(var_stack, valnode__caseobj(Erract));
setvalnode__caseobj(Erract, UNBOUND);
}
save(catch_tag);
save2(didnt_output_name,didnt_get_output);
num2save(val_status,tailcall);
newcont(catch_followup);
val_status = 5;
goto begin_seq;
catch_followup:
num2restore(val_status,tailcall);
restore2(didnt_output_name,didnt_get_output);
restore(catch_tag);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
}
}
if (stopping_flag == THROWING &&
compare_node(throw_node, catch_tag, TRUE) == 0) {
throw_node = reref(throw_node, UNBOUND);
stopping_flag = RUN;
assign(val, output_node);
}
goto fetch_cont;
begin_apply:
/* This is for lapply. */
assign(fun, car(val));
while (nodetype(fun) == ARRAY && NOT_THROWING)
assign(fun, err_logo(APPLY_BAD_DATA, fun));
assign(argl, cadr(val));
assign(val, UNBOUND);
while (!is_list(argl) && NOT_THROWING)
assign(argl, err_logo(APPLY_BAD_DATA, argl));
if (NOT_THROWING && fun != NIL) {
if (is_list(fun)) { /* template */
if (is_list(car(fun)) && cdr(fun) != NIL) {
/* lambda form */
formals = (FIXNUM)car(fun);
numsave(tailcall);
tailcall = 0;
llocal((NODE *)formals); /* bind the formals locally */
numrestore(tailcall);
for ( ;
formals && argl && NOT_THROWING;
formals = (FIXNUM)cdr((NODE *)formals),
assign(argl, cdr(argl)))
setvalnode__caseobj(car((NODE *)formals), car(argl));
assign(val, cdr(fun));
goto macro_reval;
} else { /* question-mark form */
save(qm_list);
assign(qm_list, argl);
assign(list, fun);
make_tree(list);
if (list == NIL || !is_tree(list)) {
goto qm_failed;
}
assign(unev, tree__tree(list));
save2(didnt_output_name,didnt_get_output);
num2save(val_status,tailcall);
newcont(qm_continue);
val_status = 5;
goto eval_sequence;
qm_continue:
num2restore(val_status,tailcall);
restore2(didnt_output_name,didnt_get_output);
if (val_status < 4 && tailcall != 0) {
if (STOPPING || RUNNING) assign(output_node, UNBOUND);
if (stopping_flag == OUTPUT || STOPPING) {
stopping_flag = RUN;
assign(val, output_node);
if (val != UNBOUND && val_status < 2) {
err_logo(DK_WHAT_UP,val);
}
}
}
qm_failed:
restore(qm_list);
goto fetch_cont;
}
} else { /* name of procedure to apply */
int min, max, n;
NODE *arg;
assign(fun, intern(fun));
if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
fun != Null_Word)
silent_load(fun, NULL); /* try ./<fun>.lg */
if (procnode__caseobj(fun) == UNDEFINED && NOT_THROWING &&
fun != Null_Word)
silent_load(fun, logolib); /* try <logolib>/<fun> */
proc = procnode__caseobj(fun);
while (proc == UNDEFINED && NOT_THROWING) {
assign(val, err_logo(DK_HOW_UNREC, fun));
}
if (NOT_THROWING) {
if (nodetype(proc) == CONS) {
min = getint(minargs__procnode(proc));
max = getint(maxargs__procnode(proc));
} else {
if (getprimdflt(proc) < 0) { /* special form */
err_logo(DK_HOW_UNREC, fun); /* can't apply */
goto fetch_cont;
} else {
min = getprimmin(proc);
max = getprimmax(proc);
}
}
for (n = 0, arg = argl; arg != NIL; n++, arg = cdr(arg));
if (n < min) {
err_logo(NOT_ENOUGH, NIL);
} else if (n > max && max >= 0) {
err_logo(TOO_MUCH, NIL);
} else {
goto apply_dispatch;
}
}
}
}
goto fetch_cont;
all_done:
tailcall = oldtailcall;
ift_iff_flag = old_ift_iff;
restore2(fun,ufun);
reset_args(var);
restore2(var,this_line);
deref(argl);deref(unev);deref(stack);deref(catch_tag);deref(exp);
return(val);
}
main(int argc, char *argv[])
{
NODE *exec_list = NIL;
#ifdef MEM_DEBUG
extern long int mem_allocated, mem_freed;
#endif
#ifdef x_window
x_window_init(argc, argv);
#endif
#ifdef mac
init_mac_memory();
#endif
term_init();
if (argc < 2) {
if (isatty(1)) lcleartext();
printf("Welcome to Berkeley Logo version 3.0.1");
new_line(stdout);
}
init();
#ifdef ibm
signal(SIGINT, SIG_IGN);
#ifdef __ZTC__
_controlc_handler = do_ctrl_c;
controlc_open();
#endif
#else
signal(SIGINT, logo_stop);
#endif
signal(SIGQUIT, logo_pause);
/* SIGQUITs never happen on the IBM */
argv++;
while (--argc > 0 && NOT_THROWING) {
silent_load(NIL,*argv++);
}
for (;;) {
if (NOT_THROWING) {
#ifdef MEM_DEBUG
printf("alloc=%d, freed=%d, used=%d\n",
mem_allocated, mem_freed, mem_allocated-mem_freed);
#endif
current_line = reref(current_line, reader(stdin,"? "));
if (feof(stdin) && !isatty(0)) lbye();
exec_list = parser(current_line, TRUE);
val_status = 0;
if (exec_list != NIL) eval_driver(exec_list);
}
if (stopping_flag == THROWING) {
if (compare_node(throw_node, Error, TRUE) == 0) {
err_print();
} else if (compare_node(throw_node, System, TRUE) == 0)
break;
else if (compare_node(throw_node, Toplevel, TRUE) != 0) {
err_logo(NO_CATCH_TAG, throw_node);
err_print();
}
stopping_flag = RUN;
}
if (stopping_flag == STOP || stopping_flag == OUTPUT) {
print_node(stdout, make_static_strnode(
"You must be in a procedure to use OUTPUT or STOP.\n"));
stopping_flag = RUN;
}
}
prepare_to_exit(TRUE);
}
