Exemple #1
0
/* evform - evaluate a form */
LOCAL NODE *evform(NODE *expr)
{
    NODE ***oldstk,*fun __HEAPIFY,*args __HEAPIFY,*env,*val,*type;
    val = 0; //BUG: uninitialized variable is used if xlfail returns

    /* create a stack frame */
    oldstk = xlsave2(&fun,&args);

    /* get the function and the argument list */
    fun = car(expr);
    args = cdr(expr);

    /* evaluate the first expression */
    if ((fun = xleval(fun)) == NIL)
	xlfail("bad function");

    /* evaluate the function */
    if (subrp(fun) || fsubrp(fun)) {
	if (subrp(fun))
	    args = xlevlist(args);
	val = (*getsubr(fun))(args);
    }
    else if (consp(fun)) {
	if (consp(car(fun))) {
	    env = cdr(fun);
	    fun = car(fun);
	}
	else
	    env = xlenv;
	if ((type = car(fun)) == s_lambda) {
	    args = xlevlist(args);
	    val = evfun(fun,args,env);
	}
	else if (type == s_macro) {
	    args = evfun(fun,args,env);
	    val = xleval(args);
	}
	else
	    xlfail("bad function type");
    }
    else if (objectp(fun))
	val = xlsend(fun,args);
    else
	xlfail("bad function");

    /* restore the previous stack frame */
    xlstack = oldstk;

    /* return the result value */
    return (val);
}
Exemple #2
0
/* xlapply - apply a function to a list of arguments */
NODE *xlapply(NODE *fun,NODE *args)
{
    NODE *env,*val;
    val = 0; //BUG: uninitialized variable is used if xlfail returns

    /* check for a null function */
    if (fun == NIL)
	xlfail("bad function");

    /* evaluate the function */
    if (subrp(fun))
	val = (*getsubr(fun))(args);
    else if (consp(fun)) {
	if (consp(car(fun))) {
	    env = cdr(fun);
	    fun = car(fun);
	}
	else
	    env = xlenv;
	if (car(fun) != s_lambda)
	    xlfail("bad function type");
	val = evfun(fun,args,env);
    }
    else
	xlfail("bad function");

    /* return the result value */
    return (val);
}
Exemple #3
0
/* macroexpand - expand a macro call */
int macroexpand(LVAL fun, LVAL args, LVAL *pval)
{
    LVAL *argv;
    int argc;
    
    /* make sure it's really a macro call */
    if (!closurep(fun) || gettype(fun) != s_macro)
        return (FALSE);
        
    /* call the expansion function */
    argc = pushargs(fun,args);
    argv = xlfp + 3;
    *pval = evfun(fun,argc,argv);
    xlsp = xlfp;
    xlfp = xlfp - (int)getfixnum(*xlfp);
    return (TRUE);
}
Exemple #4
0
/* xlapply - apply a function to arguments (already on the stack) */
LVAL xlapply(int argc)
{
    LVAL *oldargv,fun,val;
    LVAL funname;
    LVAL old_profile_fixnum = profile_fixnum;
    FIXTYPE *old_profile_count_ptr = profile_count_ptr;
    int oldargc;

    /* get the function */
    fun = xlfp[1];

    /* get the functional value of symbols */
    if (symbolp(fun)) {
        funname = fun;  /* save it */
        while ((val = getfunction(fun)) == s_unbound)
            xlfunbound(fun);
        fun = xlfp[1] = val;

        if (profile_flag && atomp(funname)) {
            LVAL profile_prop = findprop(funname, s_profile);
            if (null(profile_prop)) {
                /* make a new fixnum, don't use cvfixnum because
                   it would return shared pointer to zero, but we
                   are going to modify this integer in place --
                   dangerous but efficient.
                 */
                profile_fixnum = newnode(FIXNUM);
                profile_fixnum->n_fixnum = 0;
                setplist(funname, cons(s_profile,
                                       cons(profile_fixnum,
                                            getplist(funname))));
                setvalue(s_profile, cons(funname, getvalue(s_profile)));
            } else profile_fixnum = car(profile_prop);
            profile_count_ptr = &getfixnum(profile_fixnum);
        }
    }

    /* check for nil */
    if (null(fun))
        xlerror("bad function",fun);

    /* dispatch on node type */
    switch (ntype(fun)) {
    case SUBR:
        oldargc = xlargc;
        oldargv = xlargv;
        xlargc = argc;
        xlargv = xlfp + 3;
        val = (*getsubr(fun))();
        xlargc = oldargc;
        xlargv = oldargv;
        break;
    case CONS:
        if (!consp(cdr(fun)))
            xlerror("bad function",fun);
        if (car(fun) == s_lambda) {
            fun = xlclose(NIL,
                          s_lambda,
                          car(cdr(fun)),
                          cdr(cdr(fun)),
                          xlenv,xlfenv);
        } else
            xlerror("bad function",fun);
        /**** fall through into the next case ****/
    case CLOSURE:
        if (gettype(fun) != s_lambda)
            xlerror("bad function",fun);
        val = evfun(fun,argc,xlfp+3);
        break;
    default:
        xlerror("bad function",fun);
    }

    /* restore original profile counting state */
    profile_fixnum = old_profile_fixnum;
    profile_count_ptr = old_profile_count_ptr;

    /* remove the call frame */
    xlsp = xlfp;
    xlfp = xlfp - (int)getfixnum(*xlfp);

    /* return the function value */
    return (val);
}
Exemple #5
0
/* evform - evaluate a form */
LOCAL LVAL evform(LVAL form)
{
    LVAL fun,args,val,type;
    LVAL tracing=NIL;
    LVAL *argv;
    LVAL old_profile_fixnum = profile_fixnum;
    FIXTYPE *old_profile_count_ptr = profile_count_ptr;
    LVAL funname;
    int argc;

    /* protect some pointers */
    xlstkcheck(2);
    xlsave(fun);
    xlsave(args);

    (*profile_count_ptr)++; /* increment profile counter */

    /* get the function and the argument list */
    fun = car(form);
    args = cdr(form);

    funname = fun;

    /* get the functional value of symbols */
    if (symbolp(fun)) {
        if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
            tracing = fun;
        fun = xlgetfunction(fun);
    }

    /* check for nil */
    if (null(fun))
        xlerror("bad function",NIL);

    /* dispatch on node type */
    switch (ntype(fun)) {
    case SUBR:
        argv = xlargv;
        argc = xlargc;
        xlargc = evpushargs(fun,args);
        xlargv = xlfp + 3;
        trenter(tracing,xlargc,xlargv);
        val = (*getsubr(fun))();
        trexit(tracing,val);
        xlsp = xlfp;
        xlfp = xlfp - (int)getfixnum(*xlfp);
        xlargv = argv;
        xlargc = argc;
        break;
    case FSUBR:
        argv = xlargv;
        argc = xlargc;
        xlargc = pushargs(fun,args);
        xlargv = xlfp + 3;
        val = (*getsubr(fun))();
        xlsp = xlfp;
        xlfp = xlfp - (int)getfixnum(*xlfp);
        xlargv = argv;
        xlargc = argc;
        break;
    case CONS:
        if (!consp(cdr(fun)))
            xlerror("bad function",fun);
        if ((type = car(fun)) == s_lambda)
             fun = xlclose(NIL,
                           s_lambda,
                           car(cdr(fun)),
                           cdr(cdr(fun)),
                           xlenv,xlfenv);
        else
            xlerror("bad function",fun);
        /**** fall through into the next case ****/
    case CLOSURE:
        /* do profiling */
        if (profile_flag && atomp(funname)) {
            LVAL profile_prop = findprop(funname, s_profile);
            if (null(profile_prop)) {
                /* make a new fixnum, don't use cvfixnum because
                   it would return shared pointer to zero, but we
                   are going to modify this integer in place --
                   dangerous but efficient.
                 */
                profile_fixnum = newnode(FIXNUM);
                profile_fixnum->n_fixnum = 0;
                setplist(funname, cons(s_profile,
                                       cons(profile_fixnum,
                                            getplist(funname))));
                setvalue(s_profile, cons(funname, getvalue(s_profile)));
            } else profile_fixnum = car(profile_prop);
            profile_count_ptr = &getfixnum(profile_fixnum);
        }

        if (gettype(fun) == s_lambda) {
            argc = evpushargs(fun,args);
            argv = xlfp + 3;
            trenter(tracing,argc,argv);
            val = evfun(fun,argc,argv);
            trexit(tracing,val);
            xlsp = xlfp;
            xlfp = xlfp - (int)getfixnum(*xlfp);
        }
        else {
            macroexpand(fun,args,&fun);
            val = xleval(fun);
        }
        profile_fixnum = old_profile_fixnum;
        profile_count_ptr = old_profile_count_ptr;
        break;
    default:
        xlerror("bad function",fun);
    }

    /* restore the stack */
    xlpopn(2);

    /* return the result value */
    return (val);
}