/* xleval - xlisp evaluator */

#include "xlisp.h"

/* external variables */
extern NODE *xlstack,*xlenv,*xlnewenv;
extern NODE *s_lambda,*s_macro;
extern NODE *k_optional,*k_rest,*k_aux;
extern NODE *s_evalhook,*s_applyhook;
extern NODE *s_unbound;
extern NODE *s_stdout;

/* forward declarations */
FORWARD NODE *xlxeval();
FORWARD NODE *evalhook();
FORWARD NODE *evform();
FORWARD NODE *evsym();
FORWARD NODE *evfun();

/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
NODE *xleval(expr)
  NODE *expr;
{
    return (s_evalhook->n_symvalue ? evalhook(expr) : xlxeval(expr));
}

/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
NODE *xlxeval(expr)
  NODE *expr;
{
    /* evaluate nil to itself */
    if (expr == NIL)
	return (NIL);

    /* add trace entry */
    xltpush(expr);

    /* check type of value */
    if (consp(expr))
	expr = evform(expr);
    else if (symbolp(expr))
	expr = evsym(expr);

    /* remove trace entry */
    xltpop();

    /* return the value */
    return (expr);
}

/* xlapply - apply a function to a list of arguments */
NODE *xlapply(fun,args)
  NODE *fun,*args;
{
    NODE *val;

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

    /* evaluate the function */
    if (subrp(fun))
	val = (*fun->n_subr)(args);
    else if (consp(fun)) {
	if (car(fun) != s_lambda)
	    xlfail("bad function type");
	val = evfun(fun,args);
    }
    else
	xlfail("bad function");

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

/* evform - evaluate a form */
LOCAL NODE *evform(expr)
  NODE *expr;
{
    NODE *oldstk,fun,args,*val,*type;

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

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

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

    /* evaluate the function */
    if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
	if (subrp(fun.n_ptr))
	    args.n_ptr = xlevlist(args.n_ptr);
	val = (*fun.n_ptr->n_subr)(args.n_ptr);
    }
    else if (consp(fun.n_ptr)) {
	if ((type = car(fun.n_ptr)) == s_lambda) {
	    args.n_ptr = xlevlist(args.n_ptr);
	    val = evfun(fun.n_ptr,args.n_ptr);
	}
	else if (type == s_macro) {
	    args.n_ptr = evfun(fun.n_ptr,args.n_ptr);
	    val = xleval(args.n_ptr);
	}
	else
	    xlfail("bad function type");
    }
    else if (objectp(fun.n_ptr))
	val = xlsend(fun.n_ptr,args.n_ptr);
    else
	xlfail("bad function");

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

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

/* evalhook - call the evalhook function */
LOCAL NODE *evalhook(expr)
  NODE *expr;
{
    NODE *oldstk,*oldenv,fun,args,*val;

    /* create a new stack frame */
    oldstk = xlsave(&fun,&args,NULL);

    /* get the hook function */
    fun.n_ptr = s_evalhook->n_symvalue;

    /* make an argument list */
    args.n_ptr = newnode(LIST);
    rplaca(args.n_ptr,expr);

    /* rebind the hook functions to nil */
    oldenv = xlenv;
    xlsbind(s_evalhook,NIL);
    xlsbind(s_applyhook,NIL);

    /* call the hook function */
    val = xlapply(fun.n_ptr,args.n_ptr);

    /* unbind the symbols */
    xlunbind(oldenv);

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

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

/* xlevlist - evaluate a list of arguments */
NODE *xlevlist(args)
  NODE *args;
{
    NODE *oldstk,src,dst,*new,*last,*val;

    /* create a stack frame */
    oldstk = xlsave(&src,&dst,NULL);

    /* initialize */
    src.n_ptr = args;

    /* evaluate each argument */
    for (val = NIL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {

	/* check this entry */
	if (!consp(src.n_ptr))
	    xlfail("bad argument list");

	/* allocate a new list entry */
	new = newnode(LIST);
	if (val)
	    rplacd(last,new);
	else
	    val = dst.n_ptr = new;
	rplaca(new,xleval(car(src.n_ptr)));
	last = new;
    }

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

    /* return the new list */
    return (val);
}

/* evsym - evaluate a symbol */
LOCAL NODE *evsym(sym)
  NODE *sym;
{
    NODE *p;

    /* check for a reference to an instance variable */
    if ((p = xlobsym(sym)) != NIL)
	return (car(p));

    /* get the value of the variable */
    while ((p = sym->n_symvalue) == s_unbound)
	xlunbound(sym);

    /* return the value */
    return (p);
}

/* xlunbound - signal an unbound variable error */
xlunbound(sym)
  NODE *sym;
{
    xlcerror("try evaluating symbol again","unbound variable",sym);
}

/* evfun - evaluate a function */
LOCAL NODE *evfun(fun,args)
  NODE *fun,*args;
{
    NODE *oldstk,*oldenv,*oldnewenv,cptr,*fargs,*val;

    /* create a stack frame */
    oldstk = xlsave(&cptr,NULL);

    /* skip the function type */
    if ((fun = cdr(fun)) == NIL || !consp(fun))
	xlfail("bad function definition");

    /* get the formal argument list */
    if ((fargs = car(fun)) && !consp(fargs))
	xlfail("bad formal argument list");

    /* bind the formal parameters */
    oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
    xlabind(fargs,args);
    xlfixbindings();

    /* execute the code */
    for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NIL; )
	val = xlevarg(&cptr.n_ptr);

    /* restore the environment */
    xlunbind(oldenv); xlnewenv = oldnewenv;

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

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

/* xlabind - bind the arguments for a function */
xlabind(fargs,aargs)
  NODE *fargs,*aargs;
{
    NODE *arg;

    /* evaluate and bind each required argument */
    while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {

	/* bind the formal variable to the argument value */
	xlbind(arg,car(aargs));

	/* move the argument list pointers ahead */
	fargs = cdr(fargs);
	aargs = cdr(aargs);
    }

    /* check for the '&optional' keyword */
    if (consp(fargs) && car(fargs) == k_optional) {
	fargs = cdr(fargs);

	/* bind the arguments that were supplied */
	while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {

	    /* bind the formal variable to the argument value */
	    xlbind(arg,car(aargs));

	    /* move the argument list pointers ahead */
	    fargs = cdr(fargs);
	    aargs = cdr(aargs);
	}

	/* bind the rest to nil */
	while (consp(fargs) && !iskeyword(arg = car(fargs))) {

	    /* bind the formal variable to nil */
	    xlbind(arg,NIL);

	    /* move the argument list pointer ahead */
	    fargs = cdr(fargs);
	}
    }

    /* check for the '&rest' keyword */
    if (consp(fargs) && car(fargs) == k_rest) {
	fargs = cdr(fargs);
	if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
	    xlbind(arg,aargs);
	else
	    xlfail("symbol missing after &rest");
	fargs = cdr(fargs);
	aargs = NIL;
    }

    /* check for the '&aux' keyword */
    if (consp(fargs) && car(fargs) == k_aux)
	while ((fargs = cdr(fargs)) != NIL && consp(fargs))
	    xlbind(car(fargs),NIL);

    /* make sure the correct number of arguments were supplied */
    if (fargs != aargs)
	xlfail(fargs ? "too few arguments" : "too many arguments");
}

/* iskeyword - check to see if a symbol is a keyword */
LOCAL int iskeyword(sym)
  NODE *sym;
{
    return (sym == k_optional || sym == k_rest || sym == k_aux);
}

/* xlsave - save nodes on the stack */
NODE *xlsave(n)
  NODE *n;
{
    NODE **nptr,*oldstk;

    /* save the old stack pointer */
    oldstk = xlstack;

    /* save each node */
    for (nptr = &n; *nptr != NULL; nptr++) {
	rplaca(*nptr,NIL);
	rplacd(*nptr,xlstack);
	xlstack = *nptr;
    }

    /* return the old stack pointer */
    return (oldstk);
}