NODE *lrunparse(NODE *args) {
NODE *arg;
arg = car(args);
while (nodetype(arg) == ARRAY && NOT_THROWING) {
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
}
if (NOT_THROWING && !aggregate(arg))
arg = parser(arg, TRUE);
if (NOT_THROWING)
return runparse(arg);
return UNBOUND;
}
NODE *lseteditor(NODE *args) {
NODE *arg;
arg = cnv_node_to_strnode(car(args));
if (arg == UNBOUND) err_logo(BAD_DATA_UNREC, arg);
else {
editor = asciiz(arg);
editorname = strrchr(editor, (int)'/');
if (editorname == NULL) editorname = strrchr(editor, (int)'\\');
if (editorname == NULL) editorname = strrchr(editor, (int)':');
editorname = (editorname ? editorname+1 : editor);
}
return UNBOUND;
}
NODE *lsetread(NODE *arg) {
FILE *tmp;
if (car(arg) == NIL) {
readstream = stdin;
reader_name = NIL;
}
else if ((tmp = find_file(car(arg), FALSE)) != NULL) {
readstream = tmp;
reader_name = car(arg);
}
else
err_logo(NOT_OPEN_ERROR, car(arg));
return(UNBOUND);
}
NODE *lerasefile(NODE *arg) {
char *fnstr;
arg = cnv_node_to_strnode(car(arg));
if (arg == UNBOUND) return(UNBOUND);
fnstr = malloc((size_t)getstrlen(arg) + 1);
if (fnstr == NULL) {
err_logo(FILE_ERROR, make_static_strnode(message_texts[MEM_LOW]));
return UNBOUND;
}
strnzcpy(fnstr, getstrptr(arg), getstrlen(arg));
unlink(fnstr);
free(fnstr);
return(UNBOUND);
}
NODE *lsave(NODE *arg)
{
FILE *tmp;
tmp = writestream;
writestream = open_file(car(arg), "w+");
if (writestream != NULL) {
setcar(arg, cons(lcontents(), NIL));
lpo(car(arg));
fclose(writestream);
}
else
err_logo(FILE_ERROR, make_static_strnode("Could not open file"));
writestream = tmp;
return(UNBOUND);
}
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);
}
NODE *make_array(int len)
{
NODE *node;
NODE **data;
node = newnode(ARRAY);
setarrorg(node, 1);
setarrdim(node, len);
data = (NODE * *) malloc((size_t) len * sizeof(NODE *));
if (data == NULL)
{
err_logo(OUT_OF_MEM, NIL);
return UNBOUND;
}
setarrptr(node, data);
while (--len >= 0) *data++ = NIL;
return (node);
}
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;
}
NODE *litem(NODE *args) {
int i;
NODE *obj, *val;
val = integer_arg(args);
obj = cadr(args);
while ((obj == NIL || obj == Null_Word) && NOT_THROWING) {
setcar(cdr(args), err_logo(BAD_DATA, obj));
obj = cadr(args);
}
if (NOT_THROWING) {
i = getint(val);
if (is_list(obj)) {
if (i <= 0) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
while (--i > 0) {
obj = cdr(obj);
if (obj == NIL) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
}
return car(obj);
}
else if (nodetype(obj) == ARRAY) {
i -= getarrorg(obj);
if (i < 0 || i >= getarrdim(obj)) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
return (getarrptr(obj))[i];
}
else {
if (i <= 0) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
setcar (cdr(args), cnv_node_to_strnode(obj));
obj = cadr(args);
if (i > getstrlen(obj)) {
err_logo(BAD_DATA_UNREC, val);
return UNBOUND;
}
return make_strnode(getstrptr(obj) + i - 1, getstrhead(obj),
1, nodetype(obj), strnzcpy);
}
}
return(UNBOUND);
}
/* Looks up value in dynamic bindings and then in Object Hierarchy. If the
* value is found in one place but not the other, then the value is
* returned. Otherwise, an error is signalled.
* @params - name
*/
NODE *varValue(NODE *name) {
NODE *val;
name = intern(name);
val = valnode__caseobj(name);
if ((val != UNBOUND) && flag__caseobj(name, IS_LOCAL_VALUE)) {
if (varInObjectHierarchy(name, FALSE) != (NODE *)(-1)) {
err_logo(LOCAL_AND_OBJ, name);
return UNBOUND;
}
else {
return val; /* local binding */
}
}
val = varInObjectHierarchy(name, TRUE);
return((val == (NODE *)(-1)) ? UNBOUND : val);
}
RETSIGTYPE logo_stop()
#endif
{
if (inside_gc || in_eval_save) {
int_during_gc = 1;
} else {
charmode_off();
to_pending = 0;
if (!stop_quietly_flag)
err_logo(STOP_ERROR,NIL);
stop_quietly_flag = 0;
#ifdef __RZTC__
if (!input_blocking)
#endif
signal(SIGINT, logo_stop);
unblock_input();
}
SIGRET
}
NODE *newnode(NODETYPES type)
{
NODE *newnd;
if ((newnd = free_list) == NIL) {
addseg();
if ((newnd = free_list) == NIL)
err_logo(OUT_OF_MEM, NIL);
}
free_list = cdr(newnd);
settype(newnd, type);
setrefcnt(newnd, 0);
newnd->n_car = NIL;
newnd->n_cdr = NIL;
newnd->n_obj = NIL;
#ifdef MEM_DEBUG
mem_allocated++;
#endif
return(newnd);
}
NODE *lreadchar()
{
char c;
charmode_on();
input_blocking++;
#ifndef TIOCSTI
if (!setjmp(iblk_buf))
#endif
#ifdef mac
csetmode(C_RAW, stdin);
while ((c = (char)getc(readstream)) == EOF && readstream == stdin);
csetmode(C_ECHO, stdin);
#else
#ifdef ibm
if (interactive && readstream==stdin)
c = (char)getch();
else
c = (char)getc(readstream);
if (c == 17) { /* control-q */
to_pending = 0;
err_logo(STOP_ERROR,NIL);
}
if (c == 23) { /* control-w */
logo_pause();
return(lreadchar());
}
#else
c = (char)getc(readstream);
#endif
#endif
input_blocking = 0;
if (feof(readstream)) {
return(NIL);
}
return(make_strnode(&c, (char *)NULL, 1,
(getparity(c) ? STRING : BACKSLASH_STRING), strnzcpy));
}
/* Creates the object variable named Symbol, or the object variables named ,
* SymbolList within the current object.
* @params - Symbol or SymbolList
*/
NODE *lhave(NODE *args) {
if (is_list(car(args))) {
if (cdr(args) != NIL) {
err_logo(TOO_MUCH, NIL); /* too many inputs */
}
args = car(args);
}
/* now args is always a list of symbols. args should not equal to NIL
because that is checked for before. */
while (args != NIL && NOT_THROWING) {
NODE *sym = intern(car(args));
NODE *binding = assoc(sym, getvars(current_object));
if (binding == NIL) {
setvars(current_object, cons(sym, getvars(current_object)));
setobject(getvars(current_object), UNBOUND);
}
args = cdr(args);
}
return UNBOUND;
}
NODE *lload(NODE *arg) {
FILE *tmp;
NODE *tmp_line, *exec_list;
NODE *st = valnode__caseobj(Startup);
tmp = loadstream;
tmp_line = current_line;
loadstream = open_file(car(arg), "r");
if (loadstream != NULL) {
while (!(feof(loadstream)) && NOT_THROWING) {
current_line = reader(loadstream, "");
exec_list = parser(current_line, TRUE);
if (exec_list != NIL) eval_driver(exec_list);
}
fclose(loadstream);
save_name = car(arg);
runstartup(st);
} else
err_logo(CANT_OPEN_ERROR, car(arg));
loadstream = tmp;
current_line = tmp_line;
return(UNBOUND);
}
NODE *runparse(NODE *ndlist) {
NODE *curnd = NIL, *outline = NIL, *tnode = NIL, *lastnode = NIL;
char *str;
if (nodetype(ndlist) == RUN_PARSE)
return parsed__runparse(ndlist);
if (!is_list(ndlist)) {
err_logo(BAD_DATA_UNREC, ndlist);
return(NIL);
}
if (ndlist != NIL && is_word(curnd=car(ndlist)) && getstrlen(curnd) >= 2 &&
(str=getstrptr(curnd)) && *str++ == '#' && *str == '!')
return NIL; /* shell-script #! treated as comment line */
while (ndlist != NIL) {
curnd = car(ndlist);
ndlist = cdr(ndlist);
if (!is_word(curnd))
tnode = cons(curnd, NIL);
else {
if (!numberp(curnd))
tnode = runparse_node(curnd, &ndlist);
else
tnode = cons(cnv_node_to_numnode(curnd), NIL);
}
if (tnode != NIL) {
if (outline == NIL) outline = tnode;
else setcdr(lastnode, tnode);
lastnode = tnode;
while (cdr(lastnode) != NIL) {
lastnode = cdr(lastnode);
if (check_throwing) break;
}
}
if (check_throwing) break;
}
return(outline);
}
NODE *integer_arg(NODE *args) {
NODE *arg = car(args), *val;
FIXNUM i;
FLONUM f;
val = cnv_node_to_numnode(arg);
while ((nodetype(val) != INT) && NOT_THROWING) {
if (nodetype(val) == FLOATT &&
fmod((f = getfloat(val)), 1.0) == 0.0 &&
f >= -(FLONUM)MAXLOGOINT && f < (FLONUM)MAXLOGOINT) {
i = (FIXNUM)f;
val = make_intnode(i);
break;
}
setcar(args, err_logo(BAD_DATA, arg));
arg = car(args);
val = cnv_node_to_numnode(arg);
}
setcar(args,val);
if (nodetype(val) == INT) return(val);
return UNBOUND;
}
void gr_mode(void) {
int errorcode;
if (!in_graphics_mode) {
msm_hidecursor();
x_coord = x_margin;
y_coord = y_margin;
errorcode = fg_init();
if (have_been_in_graphics_mode) {
in_graphics_mode = TRUE;
if (turtle_shown && !refresh_p) draw_turtle();
redraw_graphics();
}
else {
if (errorcode == 0)
err_logo(BAD_GRAPH_INIT, NIL);
else {
in_graphics_mode = have_been_in_graphics_mode = TRUE;
if (can_do_color = (fg.nsimulcolor > 16 /* != fg.ncolormap */ )) {
rgb_init();
dull = fg.nsimulcolor-1;
bright = 7;
} else {
turtle_color = FG_HIGHLIGHT;
dull = FG_WHITE;
bright = FG_HIGHLIGHT;
}
bg_color = FG_BLACK;
ztc_set_penc(7);
if (ztc_textcolor == FG_WHITE) ztc_textcolor = dull;
back_ground = 0;
ztc_box[FG_X1] = ztc_textbox[FG_X1]
= text_scroll_box[FG_X1]
= text_last_line_box[FG_X1]
= clear_box[FG_X1]
= fg.displaybox[FG_X1];
ztc_textbox[FG_Y1] = fg.displaybox[FG_Y1];
ztc_box[FG_X2] = ztc_textbox[FG_X2]
= text_scroll_box[FG_X2]
= text_last_line_box[FG_X2]
= clear_box[FG_X2]
= MaxX = fg.displaybox[FG_X2];
ztc_box[FG_Y2] = MaxY
= clear_box[FG_Y2]
= fg.displaybox[FG_Y2];
y_scale = (double)fg.pixelx/(double)fg.pixely;
{
FILE *fp = fopen("scrunch.dat","r");
if (fp != NULL) {
scrunching = TRUE;
if (filelength(fileno(fp)) > 0) {
fread(&x_scale, sizeof(FLONUM), 1, fp);
fread(&y_scale, sizeof(FLONUM), 1, fp);
}
fclose(fp);
}
}
if (MaxY == 479)
texth = 16;
else
texth = (MaxY+1)/25;
ztc_box[FG_Y1] = 4*texth+1;
clear_box[FG_Y1] = 4*texth;
ibm_screen_bottom = MaxY - (ztc_box[FG_Y1]);
ztc_textbox[FG_Y2] = 4*texth-1;
text_scroll_box[FG_Y2] = 3*texth-1;
text_scroll_box[FG_Y1] = 0;
text_last_line_box[FG_Y2] = texth-1;
lclearscreen(NIL);
lcleartext(NIL);
in_splitscreen = TRUE;
}
}
msm_showcursor();
}
}
/* 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);
}
/* Warn the user if a local variable shadows a global one. */
void tell_shadow(NODE *arg) {
if (flag__caseobj(arg, VAL_STEPPED))
err_logo(SHADOW_WARN, arg);
}
int start (int argc,char ** argv) {
#else
int main(int argc, char *argv[]) {
#endif
NODE *exec_list = NIL;
NODE *cl_tail = NIL;
int argc2;
char **argv2;
#ifdef SYMANTEC_C
extern void (*openproc)(void);
extern void __open_std(void);
openproc = &__open_std;
#endif
#ifdef mac
init_mac_memory();
#endif
bottom_stack = &exec_list; /*GC*/
#ifndef HAVE_WX
#ifdef x_window
x_window_init(argc, argv);
#endif
#endif
(void)addseg();
term_init();
init();
math_init();
#ifdef ibm
signal(SIGINT, SIG_IGN);
#if defined(__RZTC__) && !defined(WIN32) /* sowings */
_controlc_handler = do_ctrl_c;
controlc_open();
#endif
#else /* !ibm */
signal(SIGINT, logo_stop);
#endif /* ibm */
#ifdef mac
signal(SIGQUIT, SIG_IGN);
#else /* !mac */
//signal(SIGQUIT, logo_pause);
#endif
/* SIGQUITs never happen on the IBM */
if (argc < 2) {
#ifndef WIN32
if (1 || isatty(1)) // fix this. for interactive from menu bar.
#endif
{
#ifdef HAVE_WX
extern char *SVN;
#endif
char version[20];
lcleartext(NIL);
#ifdef HAVE_WX
strcpy(version,"6.0");
strcat(version,SVN);
#else
strcpy(version,"5.6");
#endif
ndprintf(stdout, message_texts[WELCOME_TO], version);
new_line(stdout);
}
}
#ifdef HAVE_WX
setvalnode__caseobj(LogoVersion, make_floatnode(6.0));
#else
setvalnode__caseobj(LogoVersion, make_floatnode(5.6));
#endif
setflag__caseobj(LogoVersion, VAL_BURIED);
argv2 = argv; argc2 = argc;
if (!strcmp(*argv+strlen(*argv)-4, "logo")) {
argv++;
while (--argc > 0 && strcmp(*argv, "-") && NOT_THROWING) {
argv++;
}
}
argv++;
while (--argc > 0) {
if (command_line == NIL)
cl_tail = command_line = cons(make_static_strnode(*argv++), NIL);
else {
setcdr(cl_tail, cons(make_static_strnode(*argv++), NIL));
cl_tail = cdr(cl_tail);
}
}
setvalnode__caseobj(CommandLine, command_line);
silent_load(Startuplg, logolib);
silent_load(Startup, NULL); /* load startup.lg */
if (!strcmp(*argv2+strlen(*argv2)-4, "logo")) {
argv2++;
while (--argc2 > 0 && strcmp(*argv2, "-") && NOT_THROWING) {
silent_load(NIL,*argv2++);
}
}
for (;;) {
if (NOT_THROWING) {
check_reserve_tank();
current_line = reader(stdin,"? ");
#ifdef __RZTC__
(void)feof(stdin);
if (!in_graphics_mode)
printf(" \b");
fflush(stdout);
#endif
#ifndef WIN32
if (feof(stdin) && !isatty(0)) lbye(NIL);
#endif
#ifdef __RZTC__
if (feof(stdin)) clearerr(stdin);
#endif
if (NOT_THROWING) {
exec_list = parser(current_line, TRUE);
if (exec_list != NIL) eval_driver(exec_list);
}
}
#ifdef HAVE_WX
if (wx_leave_mainloop) {
break;
}
#endif
if (stopping_flag == THROWING) {
if (isName(throw_node, Name_error)) {
err_print(NULL);
} else if (isName(throw_node, Name_system))
break;
else if (!isName(throw_node, Name_toplevel)) {
err_logo(NO_CATCH_TAG, throw_node);
err_print(NULL);
}
stopping_flag = RUN;
}
if (stopping_flag == STOP || stopping_flag == OUTPUT) {
/* ndprintf(stdout, "%t\n", message_texts[CANT_STOP]); */
stopping_flag = RUN;
}
}
//prepare_to_exit(TRUE);
exit(0);
return 0;
}
NODE *reader(FILE *strm, char *prompt) {
int c = 0, dribbling, vbar = 0, paren = 0;
int bracket = 0, brace = 0, p_pos, contin=1, insemi=0, raw=0;
char *phys_line, *lookfor = ender;
NODETYPES this_type = STRING;
NODE *ret;
char *old_stringptr = print_stringptr;
int old_stringlen = print_stringlen;
fix_turtle_shownness();
//readingInstruction = !strcmp(prompt, "? ");
readingInstruction = (strm == stdin);
#ifdef HAVE_WX
wx_refresh();
if(readingInstruction) {
wx_enable_scrolling();
}
#endif
print_stringptr = ender;
print_stringlen = 99;
ndprintf(NULL, "\n%p\n", theName(Name_end));
*print_stringptr = '\0';
print_stringptr = old_stringptr;
print_stringlen = old_stringlen;
if (!strcmp(prompt, "RW")) { /* called by readword */
prompt = "";
contin = 0;
}
if (!strcmp(prompt, "RAW")) { /* called by readrawline */
prompt = "";
contin = 0;
raw = 1;
}
charmode_off();
#ifdef WIN32
dribbling = 0;
#else
dribbling = (dribblestream != NULL && strm == stdin);
#endif
if (p_line == 0) {
p_line = malloc(MAX_PHYS_LINE);
if (p_line == NULL) {
err_logo(OUT_OF_MEM, NIL);
return UNBOUND;
}
p_end = &p_line[MAX_PHYS_LINE-1];
}
phys_line = p_line;
if (strm == stdin && *prompt) {
if (interactive) {
rd_print_prompt(prompt);
#ifdef WIN32
win32_update_text();
#endif
}
}
if (strm == stdin) {
input_blocking++;
erract_errtype = FATAL;
}
#ifndef TIOCSTI
if (!setjmp(iblk_buf)) {
#endif
c = rd_getc(strm);
/* if ((c=='\b' || c=='\127') && strm==stdin && interactive) {
silent_load(LogoLogo, logolib);
c = rd_getc(strm);
} */ /* 6.0 */
#ifdef mac
if (c == '\r') c = '\n'; /* seen in raw mode by keyp, never read */
#endif
while (c != EOF && (vbar || paren || bracket || brace || c != '\n')
&& NOT_THROWING) {
if (dribbling) rd_putc(c, dribblestream);
if (!raw && c == '\\' && (c = rd_getc(strm)) != EOF) {
if (dribbling) rd_putc(c, dribblestream);
c = setparity(c);
this_type = BACKSLASH_STRING;
if (c == setparity('\n') && strm == stdin) {
if (interactive) zrd_print_prompt("\\ ");
}
}
if (c != EOF) into_line(c);
if (raw) {
c = rd_getc(strm);
continue;
}
if (*prompt && (c&0137) == ((*lookfor)&0137)) {
lookfor++;
if (*lookfor == 0) {
if (deepend_proc_name != NIL)
err_logo(DEEPEND, deepend_proc_name);
else
err_logo(DEEPEND_NONAME, NIL);
break;
}
} else lookfor = ender;
if (c == '|' && !insemi) {
vbar = !vbar;
this_type = VBAR_STRING;
} else if (contin && !vbar && !insemi) {
if (c == '(') paren++;
else if (paren && c == ')') paren--;
else if (c == '[') bracket++;
else if (bracket && c == ']') bracket--;
else if (c == '{') brace++;
else if (brace && c == '}') brace--;
else if (c == ';') insemi++;
}
if (this_type == STRING && strchr(special_chars, c))
this_type = VBAR_STRING;
if (/* (vbar || paren ...) && */ c == '\n') {
insemi = 0;
if (strm == stdin) {
if (interactive) zrd_print_prompt(vbar ? "| " : "~ ");
}
}
while (!vbar && c == '~' && (c = rd_getc(strm)) != EOF) {
int gotspc = 0;
while (c == ' ' || c == '\t') {
gotspc = 1;
c = rd_getc(strm);
}
if (dribbling) rd_putc(c, dribblestream);
if (c != '\n' && gotspc) into_line(' ');
into_line(c);
if (c == '\n') {
insemi = 0;
if (interactive && strm == stdin) zrd_print_prompt("~ ");
}
else if (c == '(') paren++;
else if (paren && c == ')') paren--;
else if (c == '[') bracket++;
else if (bracket && c == ']') bracket--;
else if (c == '{') brace++;
else if (brace && c == '}') brace--;
else if (c == ';') insemi++;
}
if (c != EOF) c = rd_getc(strm);
}
#ifndef TIOCSTI
}
#endif
*phys_line = '\0';
input_blocking = 0;
#if defined(__RZTC__) && !defined(WIN32) /* sowings */
fix_cursor();
if (interactive && strm == stdin) newline_bugfix();
#endif
if (dribbling)
rd_putc('\n', dribblestream);
if (c == EOF && strm == stdin) {
if (interactive) clearerr(stdin);
rd_print_prompt("\n");
}
if (phys_line == p_line) return(Null_Word); /* so emptyp works */
ret = make_strnode(p_line, (struct string_block *)NULL, (int)strlen(p_line),
this_type, strnzcpy);
#if 0
if (strm == stdin && !strcmp(prompt, "? ")){
char *histline = malloc(1+strlen(p_line));
strcpy(histline, p_line);
*hist_inptr++ = histline;
if (hist_inptr >= &cmdHistory[HIST_MAX]) {
hist_inptr = cmdHistory;
}
if (*hist_inptr) {
free(*hist_inptr);
*hist_inptr = 0;
}
hist_outptr = hist_inptr;
}
#endif
//added (evan)
readingInstruction = 0;
return(ret);
}
NODE *parser_iterate(char **inln, char *inlimit, struct string_block *inhead,
BOOLEAN semi, int endchar) {
char ch, *wptr = NULL;
static char terminate = '\0'; /* KLUDGE */
NODE *outline = NIL, *lastnode = NIL, *tnode = NIL;
int windex = 0, vbar = 0;
NODETYPES this_type = STRING;
BOOLEAN broken = FALSE;
do {
/* get the current character and increase pointer */
ch = **inln;
if (!vbar && windex == 0) wptr = *inln;
if (++(*inln) >= inlimit) *inln = &terminate;
/* skip through comments and line continuations */
while (!vbar && ((semi && ch == ';') ||
#ifdef WIN32
(ch == '~' && (**inln == 012 || **inln == 015)))) {
while (ch == '~' && (**inln == 012 || **inln == 015)) {
#else
(ch == '~' && **inln == '\n'))) {
while (ch == '~' && **inln == '\n') {
#endif
if (++(*inln) >= inlimit) *inln = &terminate;
ch = **inln;
if (windex == 0) wptr = *inln;
else {
if (**inln == ']' || **inln == '[' ||
**inln == '{' || **inln == '}') {
ch = ' ';
break;
} else {
broken = TRUE;
}
}
if (++(*inln) >= inlimit) *inln = &terminate;
}
if (semi && ch == ';') {
#ifdef WIN32
if (**inln != 012 && **inln != 015)
#else
if (**inln != '\n')
#endif
do {
ch = **inln;
if (windex == 0) wptr = *inln;
else broken = TRUE;
if (++(*inln) >= inlimit) *inln = &terminate;
}
#ifdef WIN32
while (ch != '\0' && ch != '~' && **inln != 012 && **inln != 015);
#else /* !Win32 */
while (ch != '\0' && ch != '~' && **inln != '\n');
#endif
if (ch != '\0' && ch != '~') ch = '\n';
}
}
/* flag that this word will be of BACKSLASH_STRING type */
if (getparity(ch)) this_type = BACKSLASH_STRING;
if (ch == '|') {
vbar = !vbar;
this_type = VBAR_STRING;
broken = TRUE; /* so we'll copy the chars */
}
else if (vbar || (!white_space(ch) && ch != ']' &&
ch != '{' && ch != '}' && ch != '['))
windex++;
if (vbar) continue;
else if (ch == endchar) break;
else if (ch == ']') err_logo(UNEXPECTED_BRACKET, NIL);
else if (ch == '}') err_logo(UNEXPECTED_BRACE, NIL);
/* if this is a '[', parse a new list */
else if (ch == '[') {
tnode = cons(parser_iterate(inln,inlimit,inhead,semi,']'), NIL);
if (**inln == '\0') ch = '\0';
}
else if (ch == '{') {
tnode = cons(list_to_array
(parser_iterate(inln,inlimit,inhead,semi,'}')), NIL);
if (**inln == '@') {
int i = 0, sign = 1;
(*inln)++;
if (**inln == '-') {
sign = -1;
(*inln)++;
}
while ((ch = **inln) >= '0' && ch <= '9') {
i = (i*10) + ch - '0';
(*inln)++;
}
setarrorg(car(tnode),sign*i);
}
if (**inln == '\0') ch = '\0';
}
/* if this character or the next one will terminate string, make the word */
else if (white_space(ch) || **inln == ']' || **inln == '[' ||
**inln == '{' || **inln == '}') {
if (windex > 0 || this_type == VBAR_STRING) {
if (broken == FALSE)
tnode = cons(make_strnode(wptr, inhead, windex,
this_type, strnzcpy),
NIL);
else {
tnode = cons(make_strnode(wptr,
(struct string_block *)NULL, windex,
this_type, (semi ? mend_strnzcpy : mend_nosemi)),
NIL);
broken = FALSE;
}
this_type = STRING;
windex = 0;
}
}
/* put the word onto the end of the return list */
if (tnode != NIL) {
if (outline == NIL) outline = tnode;
else setcdr(lastnode, tnode);
lastnode = tnode;
tnode = NIL;
}
} while (ch);
return(outline);
}
NODE *parser(NODE *nd, BOOLEAN semi) {
NODE *rtn;
int slen;
char *lnsav;
rtn = cnv_node_to_strnode(nd);
slen = getstrlen(rtn);
lnsav = getstrptr(rtn);
rtn = parser_iterate(&lnsav,lnsav + slen,getstrhead(rtn),semi,-1);
return(rtn);
}
NODE *lparse(NODE *args) {
NODE *arg, *val = UNBOUND;
arg = string_arg(args);
if (NOT_THROWING) {
val = parser(arg, FALSE);
}
return(val);
}
int main(int argc, char *argv[]) {
NODE *exec_list = NIL;
NODE *cl_tail = NIL;
int argc2;
char **argv2;
bottom_stack = &exec_list; /*GC*/
(void) addseg();
term_init();
init();
math_init();
my_init();
signal(SIGINT, logo_stop);
if (argc < 2) {
if (1 || isatty(1)) // fix this. for interactive from menu bar.
{
char version[20];
lcleartext(NIL);
strcpy(version, "5.6");
ndprintf(stdout, message_texts[WELCOME_TO], version);
new_line(stdout);
}
}
setvalnode__caseobj(LogoVersion, make_floatnode(5.6));
setflag__caseobj(LogoVersion, VAL_BURIED);
argv2 = argv;
argc2 = argc;
if (!strcmp(*argv + strlen(*argv) - 4, "logo")) {
argv++;
while (--argc > 0 && strcmp(*argv, "-") && NOT_THROWING) {
argv++;
}
}
argv++;
while (--argc > 0) {
if (command_line == NIL)
cl_tail = command_line = cons(make_static_strnode(*argv++), NIL);
else {
setcdr(cl_tail, cons(make_static_strnode(*argv++), NIL));
cl_tail = cdr(cl_tail);
}
}
setvalnode__caseobj(CommandLine, command_line);
silent_load(Startuplg, logolib);
silent_load(Startup, NULL); /* load startup.lg */
if (!strcmp(*argv2 + strlen(*argv2) - 4, "logo")) {
argv2++;
while (--argc2 > 0 && strcmp(*argv2, "-") && NOT_THROWING) {
silent_load(NIL, *argv2++);
}
}
for (;;) {
if (NOT_THROWING) {
check_reserve_tank();
current_line = reader(stdin, "? ");
if (feof(stdin) && !isatty(0))
lbye(NIL);
if (NOT_THROWING) {
exec_list = parser(current_line, TRUE);
if (exec_list != NIL)
eval_driver(exec_list);
}
}
if (stopping_flag == THROWING) {
if (isName(throw_node, Name_error)) {
err_print(NULL);
} else if (isName(throw_node, Name_system))
break;
else if (!isName(throw_node, Name_toplevel)) {
err_logo(NO_CATCH_TAG, throw_node);
err_print(NULL);
}
stopping_flag = RUN;
}
if (stopping_flag == STOP || stopping_flag == OUTPUT) {
/* ndprintf(stdout, "%t\n", message_texts[CANT_STOP]); */
stopping_flag = RUN;
}
}
//prepare_to_exit(TRUE);
my_finish();
exit(0);
return 0;
}
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);
}
/* Parenthesize an expression. Set expr to the node after the first full
* expression.
*/
NODE *paren_expr(NODE **expr, BOOLEAN inparen) {
NODE *first = NIL, *tree = NIL, *pproc, *retval;
NODE **ifnode = (NODE **)NIL;
if (*expr == NIL) {
if (inparen) err_logo(PAREN_MISMATCH, NIL);
return *expr;
}
first = car(*expr);
pop(*expr);
if (nodetype(first) == CASEOBJ && !numberp(first)) {
if (first == Left_Paren) {
tree = paren_expr(expr, TRUE);
tree = paren_infix(tree, expr, -1, TRUE);
if (*expr == NIL)
err_logo(PAREN_MISMATCH, NIL);
else if (car(*expr) != Right_Paren) { /* throw the rest away */
int parens;
for (parens = 0; *expr; pop(*expr)) {
if (car(*expr) == Left_Paren)
parens++;
else if (car(*expr) == Right_Paren)
if (parens-- == 0) {
pop(*expr);
break;
}
}
first = tree /* car(tree) */ ; /* 6.0 */
tree = cons(Not_Enough_Node, NIL); /* tell eval */
tree_dk_how=UNBOUND;
if (is_list(first))
first = car(first);
if (nodetype(first) != CASEOBJ ||
procnode__caseobj(first) == UNDEFINED)
err_logo(DK_HOW, first);
else
err_logo(TOO_MUCH, first);
}
else
pop(*expr);
retval = tree;
} else if (first == Right_Paren) {
err_logo(UNEXPECTED_PAREN, NIL);
if (inparen) push(first, *expr);
retval = NIL;
} else if (first == Minus_Sign) {
push(Minus_Tight, *expr);
retval = paren_infix(make_intnode((FIXNUM) 0), expr, -1, inparen);
} else { /* it must be a procedure */
check_library(first);
pproc = procnode__caseobj(first);
if (pproc == UNDEFINED) {
if (missing_space(first)) {
push(missing_numeric, *expr);
first = missing_alphabetic;
pproc = procnode__caseobj(first);
retval = gather_args(first, pproc, expr, inparen, ifnode);
if (retval != UNBOUND) {
retval = cons(first, retval);
}
} else if (is_setter(first)) {
retval = gather_some_args(0, 1, expr, inparen, ifnode);
if (retval != UNBOUND) {
retval = cons(first, retval);
}
} else {
retval = cons(first, NIL);
tree_dk_how = first;
}
} else if (nodetype(pproc) == INFIX && NOT_THROWING) {
err_logo(NOT_ENOUGH, first);
retval = cons(first, NIL);
} else {
/* Kludge follows to turn IF to IFELSE sometimes. */
if (isName(first, Name_if)) {
ifnode = &first;
}
retval = gather_args(first, pproc, expr, inparen, ifnode);
if (retval != UNBOUND) {
retval = cons(first, retval);
}
}
}
} else if (is_list(first)) { /* quoted list */
retval = make_quote(first);
} else {
return first;
}
return retval;
}
int rd_getc(FILE *strm) {
int c;
#ifdef WIN32
MSG msg;
#endif
#ifndef WIN32 /* skip this section ... */
#ifdef __RZTC__
if (strm == stdin) zflush();
c = ztc_getc(strm);
#else
c = getc(strm);
#endif
if (strm == stdin && c != EOF) update_coords(c);
#ifndef mac
if (c == '\r') return rd_getc(strm);
#endif
#ifdef ibm
if (c == 17 && interactive && strm==stdin) { /* control-q */
to_pending = 0;
err_logo(STOP_ERROR,NIL);
if (input_blocking) {
#ifdef SIG_TAKES_ARG
logo_stop(0);
#else
logo_stop();
#endif
}
}
if (c == 23 && interactive && strm==stdin) { /* control-w */
#ifndef __RZTC__
getc(strm); /* eat up the return */
#endif
#ifdef SIG_TAKES_ARG
logo_pause(0);
#else
logo_pause();
#endif
return(rd_getc(strm));
}
#endif
#else /* WIN32 */
if (strm == stdin) {
if (winPasteText && !line_avail) winDoPaste();
if (!line_avail) {
win32_text_cursor();
while (GetMessage(&msg, NULL, 0, 0)) {
TranslateMessage(&msg);
DispatchMessage(&msg);
if (line_avail)
break;
}
}
c = read_line[read_index++];
if (c == 17 && interactive && strm==stdin) { /* control-q */
to_pending = 0;
err_logo(STOP_ERROR,NIL);
line_avail = 0;
free(read_line);
if (input_blocking) logo_stop(0);
return('\n');
}
if (c == 23 && interactive && strm==stdin) { /* control-w */
line_avail = 0;
free(read_line);
logo_pause(0);
return(rd_getc(strm));
}
if (c == '\n') {
line_avail = 0;
free(read_line);
}
}
else /* reading from a file */
c = getc(strm);
#endif /* WIN32 */
#ifdef ecma
return((c == EOF) ? c : ecma_clear(c));
#else
return(c);
#endif
}
NODE *lshowturtle(NODE *args) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
if (!turtle_shown) {
turtle_shown = TRUE;
draw_turtle();
@@ -545,7 +545,7 @@ NODE *lshowturtle(NODE *args) {
}
NODE *lhideturtle(NODE *args) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
if (turtle_shown) {
draw_turtle();
turtle_shown = FALSE;
@@ -874,7 +874,7 @@ NODE *llabel(NODE *arg) {
*print_stringptr = '\0';
if (NOT_THROWING) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
draw_turtle();
theLength = strlen(textbuf);
#ifdef mac
@@ -983,7 +983,7 @@ NODE *lsetpencolor(NODE *arg) {
NODE *val = pos_int_arg(arg);
if (NOT_THROWING) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
set_pen_color(getint(val));
save_color();
done_drawing;
@@ -995,7 +995,7 @@ NODE *lsetbackground(NODE *arg) {
NODE *val = pos_int_arg(arg);
if (NOT_THROWING) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
set_back_ground(getint(val));
done_drawing;
}
@@ -1008,7 +1008,7 @@ NODE *lsetpalette(NODE *args) {
int slotnum = (int)getint(slot);
if (NOT_THROWING && (slotnum > 7)) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
set_palette(slotnum,
(unsigned int)getint(car(arg)),
(unsigned int)getint(cadr(arg)),
@@ -1057,7 +1057,7 @@ NODE *lsetpensize(NODE *args) {
NODE *arg = pos_int_vector_arg(args);
if (NOT_THROWING) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
set_pen_width((int)getint(car(arg)));
set_pen_height((int)getint(cadr(arg)));
save_size();
@@ -1074,7 +1074,7 @@ NODE *lsetpenpattern(NODE *args) {
arg = err_logo(BAD_DATA, arg);
if (NOT_THROWING) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
set_list_pen_pattern(arg);
save_pattern();
done_drawing;
@@ -1090,7 +1090,7 @@ NODE *lsetscrunch(NODE *args) {
ynode = numeric_arg(cdr(args));
if (NOT_THROWING) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
draw_turtle();
x_scale = (nodetype(xnode) == FLOATT) ? getfloat(xnode) :
(FLONUM)getint(xnode);
@@ -1227,7 +1227,7 @@ NODE *larc(NODE *arg) {
else
radius = getfloat(val2);
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
draw_turtle();
/* save and force turtle state */
@@ -1582,7 +1582,7 @@ NODE *lloadpict(NODE *args) {
lopenread(args);
#endif
if (NOT_THROWING) {
- prepare_to_draw;
+ prepare_to_draw2(UNBOUND);
fp = (FILE *)file_list->n_obj;
restore_palette(fp);
fread(&record_index, sizeof(FIXNUM), 1, fp);
