/* xleval - xlisp evaluator */
/*        Copyright (c) 1985, by David Michael Betz
          All Rights Reserved
          Permission is granted for unrestricted non-commercial use   */

#include "flp1_xlisp_h"

/* macro to check for lambda list keywords */
#define iskeyword(s) ((s) == k_optional || (s) == k_rest || (s) == k_aux)

/* external variables */
extern NODE *xlenv;
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 int xlsample;

/* trace variables */
extern NODE **trace_stack;
extern int xltrace;

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

/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
NODE *xleval(expr)
  NODE *expr;
{
    /* check for control codes */
    if (--xlsample <= 0) {
          xlsample = SAMPLE;
          oscheck();
    }

    /* check for *evalhook* */
    if (getvalue(s_evalhook))
          return (evalhook(expr));

    /* evaluate the expression */
    if (consp(expr))
          return (evform(expr));
    else if (symbolp(expr))
          return (xlgetvalue(expr));
    else
          return (expr);
}

/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
NODE *xlxeval(expr)
  NODE *expr;
{
    if (consp(expr))
          return (evform(expr));
    else if (symbolp(expr))
          return (xlgetvalue(expr));
    else
          return (expr);
}

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

    /* handle built-in functions */
    if (subrp(fun))
          return ((*getsubr(fun))(args));

    /* handle user defined functions */
    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");
          return (evfun(fun,args,env));
    }
    else
          xlfail("bad function");
}

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

    /* create a stack frame */
    oldstk = xlstack;
    xlstkcheck(2);
    xlsave(fun);
    xlsave(args);

    /* add trace entry */
    if (++xltrace < TDEPTH)
          trace_stack[xltrace] = expr;

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

    /* evaluate the first expression */
    fun = xleval(fun);

    /* handle built-in functions */
    if (subrp(fun)) {
          args = xlevlist(args);
          val = (*getsubr(fun))(args);
    }

    /* handle special forms */
    else if (fsubrp(fun))
          val = (*getsubr(fun))(args);

    /* handle user defined functions and macros */
    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");
    }

    /* handle messages sent to objects */
    else if (objectp(fun))
          val = xlsend(fun,args);
    else
          xlfail("bad function");

    /* remove trace entry */
    --xltrace;

    /* 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,*ehook,*ahook,*args,*val;

    /* create a new stack frame */
    oldstk = xlstack;
    xlstkcheck(3);
    xlsave(ehook);
    xlsave(ahook);
    xlsave(args);

    /* make an argument list */
    args = cons(expr,cons(xlenv,NIL));

    /* rebind the hook functions to nil */
    ehook = getvalue(s_evalhook);
    setvalue(s_evalhook,NIL);
    ahook = getvalue(s_applyhook);
    setvalue(s_applyhook,NIL);

    /* call the hook function */
    val = xlapply(ehook,args);

    /* unbind the symbols */
    setvalue(s_evalhook,ehook);
    setvalue(s_applyhook,ahook);

    /* 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;

    /* create a stack frame */
    oldstk = xlstack;
    xlstkcheck(2);
    xlsave(src);
    xlsave(dst);

    /* evaluate each argument */
    for (src = args, dst = NIL; consp(src); src = cdr(src)) {

          /* allocate a new list entry */
          new = cons(xleval(car(src)),NIL);
          if (dst)
              rplacd(last,new);
          else
              dst = new;
          last = new;
    }

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

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

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

/* xlstkoverflow - signal a stack overflow error */
xlstkoverflow()
{
    xlabort("evaulation stack overflow");
}

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

    /* create a stack frame */
    oldstk = xlstack;
    xlstkcheck(3);
    xlsave(oldenv);
    xlsave(newenv);
    xlsave(cptr);

    /* 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");

    /* create a new environment frame */
    newenv = xlframe(env);
    oldenv = xlenv;

    /* bind the formal parameters */
    xlabind(fargs,args,newenv);
    xlenv = newenv;

    /* execute the code */
    for (cptr = cdr(fun); consp(cptr); cptr = cdr(cptr))
          val = xleval(car(cptr));

    /* restore the environment */
    xlenv = oldenv;

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

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

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

    /* evaluate and bind each required argument */
    while (consp(fargs) && consp(aargs)) {

          /* get the next formal argument */
          arg = car(fargs);

          /* check for a keyword */
          if (iskeyword(arg))
              break;

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

          /* 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) && consp(aargs)) {

              /* get the next formal argument */
              arg = car(fargs);

              /* check for a keyword */
              if (iskeyword(arg))
                    break;

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

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

          /* bind the rest to nil */
          while (consp(fargs)) {

              /* get the next formal argument */
              arg = car(fargs);

              /* check for a keyword */
              if (iskeyword(arg))
                    break;

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

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

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

          /* bind the following symbol to the rest of the argument list */
          if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
              xlbind(arg,aargs,env);
          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,env);

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