/* xleval - xlisp evaluator *//*      Copyright (c) 1985, by David Michael Betz        All Rights Reserved        Permission is granted for unrestricted non-commercial use       *//* HISTORY   28 Apr 03  DM   eliminated some compiler warnings  12 Oct 90  RBD  added profiling support  */#include "string.h"#include "xlisp.h"/* macro to check for lambda list keywords */#define iskey(s) ((s) == lk_optional \               || (s) == lk_rest \               || (s) == lk_key \               || (s) == lk_aux \               || (s) == lk_allow_other_keys)/* macros to handle tracing */#define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}#define trexit(sym,val) {if (sym) doexit(sym,val);}/* forward declarations */FORWARD LOCAL LVAL evalhook(LVAL expr);FORWARD LOCAL LVAL evform(LVAL form);FORWARD LOCAL LVAL evfun(LVAL fun, int argc, LVAL *argv);FORWARD LVAL xlclose(LVAL name, LVAL type, LVAL fargs, LVAL body, LVAL env, LVAL fenv);FORWARD LOCAL int member( LVAL x,  LVAL list);FORWARD LOCAL int evpushargs(LVAL fun, LVAL args);FORWARD LOCAL void doenter(LVAL sym, int argc, LVAL *argv);FORWARD LOCAL void doexit(LVAL sym, LVAL val);FORWARD LOCAL void badarglist(void);/* profiling extensions by RBD */extern LVAL s_profile, profile_fixnum;extern FIXTYPE *profile_count_ptr, profile_flag;/* xleval - evaluate an xlisp expression (checking for *evalhook*) */LVAL xleval(LVAL expr){    /* check for control codes */    if (--xlsample <= 0) {        xlsample = SAMPLE;        oscheck();    }    /* check for *evalhook* */    if (getvalue(s_evalhook))        return (evalhook(expr));    /* check for nil */    if (null(expr))        return (NIL);    /* dispatch on the node type */    switch (ntype(expr)) {    case CONS:        return (evform(expr));    case SYMBOL:        return (xlgetvalue(expr));    default:        return (expr);    }}/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */LVAL xlxeval(LVAL expr){    /* check for nil */    if (null(expr))        return (NIL);    /* dispatch on node type */    switch (ntype(expr)) {    case CONS:        return (evform(expr));    case SYMBOL:        return (xlgetvalue(expr));    default:        return (expr);    }}/* xlapply - apply a function to arguments (already on the stack) */LVAL xlapply(int argc){    LVAL *oldargv,fun,val=NULL;    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);}/* evform - evaluate a form */LOCAL LVAL evform(LVAL form){    LVAL fun,args,val=NULL,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);}/* xlexpandmacros - expand macros in a form */LVAL xlexpandmacros(LVAL form){    LVAL fun,args;        /* protect some pointers */    xlstkcheck(3);    xlprotect(form);    xlsave(fun);    xlsave(args);    /* expand until the form isn't a macro call */    while (consp(form)) {        fun = car(form);                /* get the macro name */        args = cdr(form);               /* get the arguments */        if (!symbolp(fun) || !fboundp(fun))            break;        fun = xlgetfunction(fun);       /* get the expansion function */        if (!macroexpand(fun,args,&form))            break;    }    /* restore the stack and return the expansion */    xlpopn(3);    return (form);}/* 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);}/* evalhook - call the evalhook function */LOCAL LVAL evalhook(LVAL expr){    LVAL *newfp,olddenv,val;    /* create the new call frame */    newfp = xlsp;    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));    pusharg(getvalue(s_evalhook));    pusharg(cvfixnum((FIXTYPE)2));    pusharg(expr);    pusharg(cons(xlenv,xlfenv));    xlfp = newfp;    /* rebind the hook functions to nil */    olddenv = xldenv;    xldbind(s_evalhook,NIL);    xldbind(s_applyhook,NIL);    /* call the hook function */    val = xlapply(2);    /* unbind the symbols */    xlunbind(olddenv);    /* return the value */    return (val);}/* evpushargs - evaluate and push a list of arguments */LOCAL int evpushargs(LVAL fun, LVAL args){    LVAL *newfp;    int argc;        /* protect the argument list */    xlprot1(args);    /* build a new argument stack frame */    newfp = xlsp;    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));    pusharg(fun);    pusharg(NIL); /* will be argc */    /* evaluate and push each argument */    for (argc = 0; consp(args); args = cdr(args), ++argc)        pusharg(xleval(car(args)));    /* establish the new stack frame */    newfp[2] = cvfixnum((FIXTYPE)argc);    xlfp = newfp;        /* restore the stack */    xlpop();    /* return the number of arguments */    return (argc);}/* pushargs - push a list of arguments */int pushargs(LVAL fun, LVAL args){    LVAL *newfp;    int argc;        /* build a new argument stack frame */    newfp = xlsp;    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));    pusharg(fun);    pusharg(NIL); /* will be argc */    /* push each argument */    for (argc = 0; consp(args); args = cdr(args), ++argc)        pusharg(car(args));    /* establish the new stack frame */    newfp[2] = cvfixnum((FIXTYPE)argc);    xlfp = newfp;    /* return the number of arguments */    return (argc);}/* makearglist - make a list of the remaining arguments */LVAL makearglist(int argc, LVAL *argv){    LVAL list,this,last;    xlsave1(list);    for (last = NIL; --argc >= 0; last = this) {        this = cons(*argv++,NIL);        if (last) rplacd(last,this);        else list = this;        last = this;    }    xlpop();    return (list);}/* evfun - evaluate a function */LOCAL LVAL evfun(LVAL fun, int argc, LVAL *argv){    LVAL oldenv,oldfenv,cptr,name,val;    XLCONTEXT cntxt;    /* protect some pointers */