コード例 #1
0
ファイル: paren.c プロジェクト: grinner/ucblogo
/* Make a list of the next n expressions, where n is between min and max.
 * Set args to immediately after the last expression.
 */ 
NODE *gather_some_args(int min, int max, NODE **args, BOOLEAN inparen,
		       NODE **ifnode) {
    NODE *paren_infix(NODE *left, NODE **rest, int old_pri, BOOLEAN inparen);

    if (*args == NIL || car(*args) == Right_Paren ||
	    (nodetype(car(*args)) == CASEOBJ &&
	     nodetype(procnode__caseobj(car(*args))) == INFIX)) {
	if (min > 0) return cons(Not_Enough_Node, NIL);
    } else if (max == 0) {
	if (ifnode != (NODE **)NIL && is_list(car(*args))) {
	    /* if -> ifelse kludge */
	    NODE *retval;
	    err_logo(IF_WARNING, NIL);
	    *ifnode = theName(Name_ifelse);
	    retval = paren_expr(args, FALSE);
	    retval = paren_infix(retval, args, -1, inparen);
	    return cons(retval, gather_some_args(min, max, args,
						 inparen, (NODE **)NIL));
	}
    } else {
	if (max < 0) max = 0;   /* negative max means unlimited */
	if (car(*args) != Right_Paren &&
		(nodetype(car(*args)) != CASEOBJ ||
		 nodetype(procnode__caseobj(car(*args))) != INFIX)) {
	    NODE *retval = paren_expr(args, FALSE);
	    retval = paren_infix(retval, args, -1, inparen);
	    return cons(retval, gather_some_args(min - 1, max - 1, args,
						 inparen, ifnode));
	}
    }
    return NIL;
}
コード例 #2
0
ファイル: paren.c プロジェクト: grinner/ucblogo
void check_library(NODE *first) {
    if (procnode__caseobj(first) == UNDEFINED && NOT_THROWING &&
	first != Null_Word)
	    silent_load(first, NULL);    /* try ./<first>.lg */
    if (procnode__caseobj(first) == UNDEFINED && NOT_THROWING &&
	first != Null_Word)
	    silent_load(first, logolib); /* try <logolib>/<first> */
}
コード例 #3
0
ファイル: paren.c プロジェクト: grinner/ucblogo
int missing_space(NODE *name) {
    NODE *str = strnode__caseobj(name);
    char *s = getstrptr(str);
    FIXNUM len = getstrlen(str);
    char *t;
    char ch;
    char alpha[100], numer[100];
    int i;
    NODE *first;

    t = s+len-1;
    ch = *t;
    if (!isdigit(ch)) return 0;
    i = 1;
    while ((t>s) && (isdigit(*--t))) i++;
    if (t<=s) return 0;
    strncpy(numer,t+1,i);
    numer[i] = '\0';
    strncpy(alpha,s,len-i);
    alpha[len-i] = '\0';
    first = intern(make_strnode(alpha, 0, len-i, STRING, strnzcpy));
    check_library(first);
    if (procnode__caseobj(first) == UNDEFINED) return 0;
    missing_alphabetic = first;
    missing_numeric = make_intnode(atoi(numer));
    err_logo(MISSING_SPACE,
	     cons_list(0, cons_list(0, missing_alphabetic, missing_numeric,
				    END_OF_LIST),
		          name, END_OF_LIST));
    return 1;
}
コード例 #4
0
ファイル: paren.c プロジェクト: grinner/ucblogo
/* Calculate the priority of a procedure.
 */ 
int priority(NODE *proc_obj) {

    NODE *pproc;

    if (proc_obj == Minus_Tight) return PREFIX_PRIORITY+4;
    if (nodetype(proc_obj) != CASEOBJ ||
	(pproc = procnode__caseobj(proc_obj)) == UNDEFINED ||
	nodetype(pproc) != INFIX)
	    return 0;
    return getprimpri(pproc);
}
コード例 #5
0
ファイル: obj.c プロジェクト: grinner/ucblogo
/* Returns the procedure associated with name.
 */
NODE *procValue(NODE *name) {
    NODE *result, *parentList;

    result = assoc(name, getprocs(current_object));
    if (result != NIL) return getobject(result);

    for (parentList = parent_list(current_object);
        parentList != NIL && result == NIL;
        parentList = cdr(parentList)) {
    result = assoc(name, getprocs(car(parentList)));
    }
    if (result != NIL) return getobject(result);

    result = intern(name);
    return procnode__caseobj(result);
}
コード例 #6
0
/* 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);
}
コード例 #7
0
ファイル: paren.c プロジェクト: grinner/ucblogo
/* 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;
}