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);