/* xleval - xlisp evaluator */

#ifdef AZTEC
#include "stdio.h"
#include "setjmp.h"
#else
#include <stdio.h>
#include <setjmp.h>
#endif

#include "xlisp.h"

/* global variables */
struct node *xlstack;

/* trace stack */
static struct node *trace_stack[TDEPTH];
static int trace_pointer;

/* external variables */
extern jmp_buf *xljmpbuf;
extern struct node *xlenv;
extern struct node *s_lambda,*s_nlambda;
extern struct node *s_unbound;
extern struct node *s_stdout;
extern struct node *s_tracenable;
extern struct node *k_rest;
extern struct node *k_aux;

/* forward declarations */
FORWARD struct node *evform();
FORWARD struct node *evsym();
FORWARD struct node *evfun();

/* xleval - evaluate an xlisp expression */
struct node *xleval(expr)
  struct node *expr;
{
    /* evaluate null to itself */
    if (expr == NULL)
	return (NULL);

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

    /* check type of value */
    switch (expr->n_type) {
    case LIST:
	    expr = evform(expr);
	    break;
    case SYM:
	    expr = evsym(expr);
	    break;
    case INT:
    case STR:
    case SUBR:
    case FSUBR:
	    break;
    default:
	    xlfail("can't evaluate expression");
    }

    /* remove trace entry */
    tpop();

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

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

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

    /* evaluate the function */
    switch (fun->n_type) {
    case SUBR:
	    val = (*fun->n_subr)(args);
	    break;
    case LIST:
	    if (fun->n_listvalue != s_lambda)
		xlfail("bad function type");
	    val = evfun(fun,args);
	    break;
    default:
	    xlfail("bad function");
    }

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

/* evform - evaluate a form */
LOCAL struct node *evform(nptr)
  struct node *nptr;
{
    struct 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 = nptr->n_listvalue;
    args.n_ptr = nptr->n_listnext;

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

    /* evaluate the function */
    switch (fun.n_ptr->n_type) {
    case SUBR:
	    args.n_ptr = xlevlist(args.n_ptr);
    case FSUBR:
	    val = (*fun.n_ptr->n_subr)(args.n_ptr);
	    break;
    case LIST:
	    if ((type = fun.n_ptr->n_listvalue) == s_lambda)
		args.n_ptr = xlevlist(args.n_ptr);
	    else if (type != s_nlambda)
		xlfail("bad function type");
	    val = evfun(fun.n_ptr,args.n_ptr);
	    break;
    case OBJ:
	    val = xlsend(fun.n_ptr,args.n_ptr);
	    break;
    default:
	    xlfail("bad function");
    }

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

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

/* xlevlist - evaluate a list of arguments */
struct node *xlevlist(args)
  struct node *args;
{
    struct 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 = NULL; src.n_ptr; src.n_ptr = src.n_ptr->n_listnext) {

	/* check this entry */
	if (src.n_ptr->n_type != LIST)
	    xlfail("bad argument list");

	/* allocate a new list entry */
	new = newnode(LIST);
	if (val)
	    last->n_listnext = new;
	else
	    val = dst.n_ptr = new;
	new->n_listvalue = xleval(src.n_ptr->n_listvalue);
	last = new;
    }

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

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

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

    /* check for a current object */
    if ((p = xlobsym(sym)) != NULL)
	return (p->n_listvalue);
    else if ((p = sym->n_symvalue) == s_unbound)
	xlfail("unbound variable");
    else
	return (p);
}

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

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

    /* skip the function type */
    if ((fun = fun->n_listnext) == NULL)
	xlfail("bad function definition");

    /* get the formal argument list */
    if ((fargs = fun->n_listvalue) != NULL && fargs->n_type != LIST)
	xlfail("bad formal argument list");

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

    /* execute the code */
    for (cptr.n_ptr = fun->n_listnext; cptr.n_ptr != NULL; )
	val = xlevarg(&cptr.n_ptr);

    /* restore the environment */
    xlunbind(oldenv);

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

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

/* xlabind - bind the arguments for a function */
xlabind(fargs,aargs)
  struct node *fargs,*aargs;
{
    struct node *oldstk,farg,aarg,*arg;

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

    /* initialize the pointers */
    farg.n_ptr = fargs;
    aarg.n_ptr = aargs;

    /* evaluate and bind each argument */
    while (farg.n_ptr != NULL && aarg.n_ptr != NULL) {

	/* check for a keyword */
	if (iskeyword(arg = farg.n_ptr->n_listvalue))
	    break;

	/* bind the formal variable to the argument value */
	xlbind(arg,aarg.n_ptr->n_listvalue);

	/* move the argument list pointers ahead */
	farg.n_ptr = farg.n_ptr->n_listnext;
	aarg.n_ptr = aarg.n_ptr->n_listnext;
    }

    /* check for the '&rest' keyword */
    if (farg.n_ptr && farg.n_ptr->n_listvalue == k_rest) {
	farg.n_ptr = farg.n_ptr->n_listnext;
	if (farg.n_ptr && (arg = farg.n_ptr->n_listvalue) && !iskeyword(arg))
	    xlbind(arg,aarg.n_ptr);
	else
	    xlfail("symbol missing after &rest");
	farg.n_ptr = farg.n_ptr->n_listnext;
	aarg.n_ptr = NULL;
    }

    /* check for the '&aux' keyword */
    if (farg.n_ptr && farg.n_ptr->n_listvalue == k_aux)
	while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL)
	    xlbind(farg.n_ptr->n_listvalue,NULL);

    /* make sure the correct number of arguments were supplied */
    if (farg.n_ptr != aarg.n_ptr)
	xlfail("incorrect number of arguments to a function");

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

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

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

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

    /* save each node */
    for (nptr = &n; *nptr != NULL; nptr++) {
	(*nptr)->n_type = LIST;
	(*nptr)->n_listvalue = NULL;
	(*nptr)->n_listnext = xlstack;
	xlstack = *nptr;
    }

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

/* xlfail - error handling routine */
xlfail(err)
  char *err;
{
    /* print the error message */
    printf("error: %s\n",err);

    /* flush the terminal input buffer */
    xlflush();

    /* unbind bound symbols */
    xlunbind(NULL);

    /* do the back trace */
    if (s_tracenable->n_symvalue)
	baktrace();
    trace_pointer = -1;

    /* restart */
    longjmp(xljmpbuf,1);
}

/* tpush - add an entry to the trace stack */
LOCAL tpush(nptr)
    struct node *nptr;
{
    if (++trace_pointer < TDEPTH)
	trace_stack[trace_pointer] = nptr;
}

/* tpop - pop an entry from the trace stack */
LOCAL tpop()
{
    trace_pointer--;
}

/* baktrace - do a back trace */
LOCAL baktrace()
{
    for (; trace_pointer >= 0; trace_pointer--)
	if (trace_pointer < TDEPTH)
	    stdprint(trace_stack[trace_pointer]);
}

/* stdprint - print to standard output */
stdprint(expr)
  struct node *expr;
{
    xlprint(s_stdout->n_symvalue,expr,TRUE);
    xlterpri(s_stdout->n_symvalue);
}

/* xleinit - initialize the evaluator */
xleinit()
{
    /* initialize debugging stuff */
    trace_pointer = -1;
}