NODE *lload(NODE *arg)
{
FILE *tmp;
NODE *tmp_line, *exec_list;
NODE *st = valnode__caseobj(Startup);
int sv_val_status = val_status;
tmp = loadstream;
tmp_line = vref(current_line);
loadstream = open_file(car(arg), "r");
if (loadstream != NULL) {
while (!feof(loadstream) && NOT_THROWING) {
current_line = reref(current_line, reader(loadstream, ""));
exec_list = parser(current_line, TRUE);
val_status = 0;
if (exec_list != NIL) eval_driver(exec_list);
}
fclose(loadstream);
runstartup(st);
val_status = sv_val_status;
} else
err_logo(FILE_ERROR, make_static_strnode("Could not open file"));
loadstream = tmp;
deref(current_line);
current_line = tmp_line;
return(UNBOUND);
}
NODE *cnv_node_to_strnode(NODE *nd)
{
char s[MAX_NUMBER];
if (nd == UNBOUND || aggregate(nd))
{
return (UNBOUND);
}
switch (nodetype(nd))
{
case STRING:
case BACKSLASH_STRING:
case VBAR_STRING:
return (nd);
case CASEOBJ:
return strnode__caseobj(nd);
case QUOTE:
nd = valref(cnv_node_to_strnode(node__quote(nd)));
nd = reref(nd, make_strnode(getstrptr(nd),
(char *) NULL, getstrlen(nd) + 1,
nodetype(nd), quote_strnzcpy));
unref(nd);
return (nd);
case COLON:
nd = valref(cnv_node_to_strnode(node__colon(nd)));
nd = reref(nd, make_strnode(getstrptr(nd),
(char *) NULL, getstrlen(nd) + 1,
nodetype(nd), colon_strnzcpy));
unref(nd);
return (nd);
case INT:
sprintf(s, "%ld", getint(nd));
return (make_strnode(s, (char *) NULL, (int) strlen(s),
STRING, strnzcpy));
case FLOAT:
sprintf(s, "%0.15g", getfloat(nd));
return (make_strnode(s, (char *) NULL, (int) strlen(s),
STRING, strnzcpy));
}
/*NOTREACHED*/
return (NIL);
}
void Signal::free_samples(void)
{
if (ref) {
const_cast<Signal*>(ref)->ref_dec(this);
} else {
if (refed.size())
reref();
else if (sample) {
delete [] sample;
sample = NULL;
}
}
}
FILE *open_file(NODE *arg, char *access)
{
char *fnstr;
FILE *tstrm;
ref(arg);
arg = reref(arg, cnv_node_to_strnode(arg));
if (arg == UNBOUND) return(NULL);
fnstr = (char *) malloc((size_t)getstrlen(arg) + 1);
strnzcpy(fnstr, getstrptr(arg), getstrlen(arg));
tstrm = fopen(fnstr, access);
deref(arg);
free(fnstr);
return(tstrm);
}
void silent_load(NODE *arg, char *prefix)
{
FILE *tmp_stream;
NODE *tmp_line, *exec_list;
char load_path[200];
NODE *st = valnode__caseobj(Startup);
int sv_val_status = val_status;
/* This procedure is called three ways:
* silent_load(NIL,*argv) loads *argv
* silent_load(proc,logolib) loads logolib/proc
* silent_load(proc,NULL) loads proc.lg
* The "/" or ".lg" is supplied by this procedure as needed.
*/
if (prefix == NULL && arg == NIL) return;
strcpy(load_path, (prefix == NULL ? "" : prefix));
if (arg != NIL) {
arg = cnv_node_to_strnode(arg);
if (arg == UNBOUND) return;
#ifdef unix
if (prefix != NULL) strcat(load_path, "/");
#endif
noparitylow_strnzcpy(load_path + (int)strlen(load_path),
getstrptr(arg), getstrlen(arg));
if (prefix == NULL) strcat(load_path, ".lg");
gcref(arg);
}
tmp_stream = loadstream;
tmp_line = vref(current_line);
loadstream = fopen(load_path, "r");
if (loadstream != NULL) {
while (!feof(loadstream) && NOT_THROWING) {
current_line = reref(current_line, reader(loadstream, ""));
exec_list =parser(current_line, TRUE);
val_status = 0;
if (exec_list != NIL) eval_driver(exec_list);
}
fclose(loadstream);
runstartup(st);
val_status = sv_val_status;
} else if (arg == NIL) ndprintf(stdout,"File not found: %t\n", prefix);
loadstream = tmp_stream;
deref(current_line);
current_line = tmp_line;
}
NODE *lsetread(NODE *arg)
{
FILE *tmp;
if (car(arg) == NIL) {
readstream = stdin;
deref(reader_name);
reader_name = NIL;
}
else if ((tmp = find_file(car(arg), FALSE)) != NULL) {
readstream = tmp;
reader_name = reref(reader_name, car(arg));
}
else
err_logo(FILE_ERROR, make_static_strnode("File not open"));
return(UNBOUND);
}
void fileload(char *temp)
{
FILE *tmp;
NODE *tmp_line, *exec_list, *arg;
NODE *st = valnode__caseobj(Startup);
int sv_val_status = val_status;
int IsDirtySave;
int save_yield_flag;
arg = make_strnode(temp, NULL, strlen(temp), STRING, strnzcpy);
IsDirtySave = IsDirty;
tmp = loadstream;
tmp_line = vref(current_line);
loadstream = open_file(arg, "r");
if (loadstream != NULL)
{
save_yield_flag = yield_flag;
yield_flag = 0;
lsetcursorwait();
while (!feof(loadstream) && NOT_THROWING)
{
current_line = reref(current_line, reader(loadstream, ""));
exec_list = parser(current_line, TRUE);
val_status = 0;
if (exec_list != NIL) eval_driver(exec_list);
}
fclose(loadstream);
lsetcursorarrow();
yield_flag = save_yield_flag;
runstartup(st);
val_status = sv_val_status;
}
else
err_logo(FILE_ERROR, make_static_strnode("Could not open file"));
loadstream = tmp;
deref(current_line);
current_line = tmp_line;
IsDirty = IsDirtySave;
}
FILE *find_file(NODE *arg, BOOLEAN remove)
{
NODE *t, *prev = NIL;
FILE *fp = NULL;
t = file_list;
while (t != NIL) {
if (compare_node(arg, car(t), FALSE) == 0) {
fp = (FILE *)t->n_obj;
if (remove) {
t->n_obj = NIL;
if (prev == NIL)
file_list = reref(file_list, cdr(t));
else
setcdr(prev, cdr(t));
}
break;
}
prev = t;
t = cdr(t);
}
return fp;
}
/* 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);
}
void init()
{
// extern long time();
int i /* = 0 */;
NODE *proc = NIL, *pname = NIL, *cnd = NIL;
fill_reserve_tank();
Unbound = newnode(PUNBOUND);
#ifdef bsd
srandom((int) time((long *) NULL));
#else
// srand((int)time((long *)NULL));
// srand((int)12345);
#endif
#ifdef ecma
for (i = 0; i < 128; i++)
ecma_array[i] = i;
for (i = 0; i < ecma_size; i++)
ecma_array[special_chars[i]] = ecma_begin+i;
#endif
// logolib = getenv("LOGOLIB");
// if (logolib == NULL) logolib = libloc;
// editor = getenv("EDITOR");
// if (editor == NULL) editor = "jove";
editor = "jove";
editorname = strrchr(editor, (int) '/');
editorname = (editorname ? editorname + 1 : editor);
i = 0;
while (prims[i].name)
{
if (prims[i].priority == MACRO_PRIORITY)
proc = reref(proc, newnode(MACRO));
else if (prims[i].priority == TAIL_PRIORITY)
proc = reref(proc, newnode(TAILFORM));
else if ((prims[i].priority & ~4) == PREFIX_PRIORITY)
proc = reref(proc, newnode(PRIM));/* incl. -- */
else
proc = reref(proc, newnode(INFIX));
if (prims[i].priority < PREFIX_PRIORITY)
setprimpri(proc, PREFIX_PRIORITY);
else
setprimpri(proc, prims[i].priority);
setprimfun(proc, (lexzer) prims[i].prim);
setprimdflt(proc, prims[i].defargs);
setprimmax(proc, prims[i].maxargs);
setprimmin(proc, prims[i].minargs);
pname = reref(pname, make_static_strnode(prims[i].name));
cnd = reref(cnd, make_instance(pname, pname));
setprocnode__caseobj(cnd, proc);
if (nodetype(proc) == MACRO)
setflag__caseobj(cnd, PROC_MACRO);
i++;
}
deref(proc);
deref(cnd);
deref(pname);
Truex = intern(make_static_strnode("true"));
Falsex = intern(make_static_strnode("false"));
Left_Paren = intern(make_static_strnode("("));
Right_Paren = intern(make_static_strnode(")"));
Minus_Sign = intern(make_static_strnode("-"));
Minus_Tight = intern(make_static_strnode("--"));
Query = intern(make_static_strnode("?"));
Null_Word = intern(make_static_strnode("\0"));
To = intern(make_static_strnode("to"));
Macro = intern(make_static_strnode(".macro"));
Toplevel = intern(make_static_strnode("toplevel"));
System = intern(make_static_strnode("system"));
Error = intern(make_static_strnode("error"));
End = intern(make_static_strnode("end"));
If = intern(make_static_strnode("if"));
Ifelse = intern(make_static_strnode("ifelse"));
Redefp = intern(make_static_strnode("redefp"));
Caseignoredp = intern(make_static_strnode("caseignoredp"));
setvalnode__caseobj(Caseignoredp, Truex);
setflag__caseobj(Caseignoredp, VAL_BURIED);
Erract = intern(make_static_strnode("erract"));
Printdepthlimit = intern(make_static_strnode("printdepthlimit"));
Printwidthlimit = intern(make_static_strnode("printwidthlimit"));
Pause = intern(make_static_strnode("pause"));
Startup = intern(make_static_strnode("startup"));
Output = intern(make_static_strnode("output"));
Op = intern(make_static_strnode("op"));
Stop = intern(make_static_strnode("stop"));
Goto = intern(make_static_strnode("goto"));
Tag = intern(make_static_strnode("Tag"));
the_generation = valref(cons(NIL, NIL));
Not_Enough_Node = valref(cons(NIL, NIL));
}
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);
}
