home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 254b.lha / AMXLISP_v2.0 / src / xleval.c < prev    next >
C/C++ Source or Header  |  1989-05-09  |  19KB  |  838 lines
  1. /* xleval - xlisp evaluator */
  2. /*   Copyright (c) 1985, by David Michael Betz
  3.    All Rights Reserved
  4.    Permission is granted for unrestricted non-commercial use   */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* macro to check for lambda list keywords */
  9. #define iskey(s) ((s) == lk_optional \
  10.                || (s) == lk_rest \
  11.                || (s) == lk_key \
  12.                || (s) == lk_aux \
  13.                || (s) == lk_allow_other_keys)
  14.  
  15. /* macros to handle tracing */
  16. #define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
  17. #define trexit(sym,val) {if (sym) doexit(sym,val);}
  18.  
  19. /* external variables */
  20. extern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
  21. extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
  22. extern LVAL s_evalhook,s_applyhook,s_tracelist;
  23. extern LVAL s_lambda,s_macro;
  24. extern LVAL s_unbound;
  25. extern int xlsample;
  26. extern char buf[];
  27.  
  28. /* forward declarations */
  29. FORWARD LVAL xlxeval();
  30. FORWARD LVAL evalhook();
  31. FORWARD LVAL evform();
  32. FORWARD LVAL evfun();
  33.  
  34. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  35. LVAL xleval(expr)
  36.   LVAL expr;
  37. {
  38.     /* check for control codes */
  39.     if (--xlsample <= 0) {
  40.    xlsample = SAMPLE;
  41.    oscheck();
  42.     }
  43.  
  44.     /* check for *evalhook* */
  45.     if (getvalue(s_evalhook))
  46.    return (evalhook(expr));
  47.  
  48.     /* check for nil */
  49.     if (null(expr))
  50.    return (NIL);
  51.  
  52.     /* dispatch on the node type */
  53.     switch (ntype(expr)) {
  54.     case CONS:
  55.    return (evform(expr));
  56.     case SYMBOL:
  57.    return (xlgetvalue(expr));
  58.     default:
  59.    return (expr);
  60.     }
  61. }
  62.  
  63. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  64. LVAL xlxeval(expr)
  65.   LVAL expr;
  66. {
  67.     /* check for nil */
  68.     if (null(expr))
  69.    return (NIL);
  70.  
  71.     /* dispatch on node type */
  72.     switch (ntype(expr)) {
  73.     case CONS:
  74.    return (evform(expr));
  75.     case SYMBOL:
  76.    return (xlgetvalue(expr));
  77.     default:
  78.    return (expr);
  79.     }
  80. }
  81.  
  82. /* xlapply - apply a function to arguments (already on the stack) */
  83. LVAL xlapply(argc)
  84.   int argc;
  85. {
  86.     LVAL *oldargv,fun,val;
  87.     int oldargc;
  88.  
  89.     /* get the function */
  90.     fun = xlfp[1];
  91.  
  92.     /* get the functional value of symbols */
  93.     if (symbolp(fun)) {
  94.    while ((val = getfunction(fun)) == s_unbound)
  95.        xlfunbound(fun);
  96.    fun = xlfp[1] = val;
  97.     }
  98.  
  99.     /* check for nil */
  100.     if (null(fun))
  101.    xlerror("bad function",fun);
  102.  
  103.     /* dispatch on node type */
  104.     switch (ntype(fun)) {
  105.     case SUBR:
  106.    oldargc = xlargc;
  107.    oldargv = xlargv;
  108.    xlargc = argc;
  109.    xlargv = xlfp + 3;
  110.    val = (*getsubr(fun))();
  111.    xlargc = oldargc;
  112.    xlargv = oldargv;
  113.    break;
  114.     case CONS:
  115.    if (!consp(cdr(fun)))
  116.        xlerror("bad function",fun);
  117.    if (car(fun) == s_lambda)
  118.        fun = xlclose(NIL,
  119.                      s_lambda,
  120.                      car(cdr(fun)),
  121.                      cdr(cdr(fun)),
  122.                      xlenv,xlfenv);
  123.    else
  124.        xlerror("bad function",fun);
  125.    /**** fall through into the next case ****/
  126.     case CLOSURE:
  127.    if (gettype(fun) != s_lambda)
  128.        xlerror("bad function",fun);
  129.    val = evfun(fun,argc,xlfp+3);
  130.    break;
  131.     default:
  132.    xlerror("bad function",fun);
  133.     }
  134.  
  135.     /* remove the call frame */
  136.     xlsp = xlfp;
  137.     xlfp = xlfp - (int)getfixnum(*xlfp);
  138.  
  139.     /* return the function value */
  140.     return (val);
  141. }
  142.  
  143. /* evform - evaluate a form */
  144. LOCAL LVAL evform(form)
  145.   LVAL form;
  146. {
  147.     LVAL fun,args,val,type;
  148.     LVAL tracing=NIL;
  149.     LVAL *argv;
  150.     int argc;
  151.  
  152.     /* protect some pointers */
  153.     xlstkcheck(2);
  154.     xlsave(fun);
  155.     xlsave(args);
  156.  
  157.     /* get the function and the argument list */
  158.     fun = car(form);
  159.     args = cdr(form);
  160.  
  161.     /* get the functional value of symbols */
  162.     if (symbolp(fun)) {
  163.    if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
  164.        tracing = fun;
  165.    fun = xlgetfunction(fun);
  166.     }
  167.  
  168.     /* check for nil */
  169.     if (null(fun))
  170.    xlerror("bad function",NIL);
  171.  
  172.     /* dispatch on node type */
  173.     switch (ntype(fun)) {
  174.     case SUBR:
  175.    argv = xlargv;
  176.    argc = xlargc;
  177.    xlargc = evpushargs(fun,args);
  178.    xlargv = xlfp + 3;
  179.    trenter(tracing,xlargc,xlargv);
  180.    val = (*getsubr(fun))();
  181.    trexit(tracing,val);
  182.    xlsp = xlfp;
  183.    xlfp = xlfp - (int)getfixnum(*xlfp);
  184.    xlargv = argv;
  185.    xlargc = argc;
  186.    break;
  187.     case FSUBR:
  188.    argv = xlargv;
  189.    argc = xlargc;
  190.    xlargc = pushargs(fun,args);
  191.    xlargv = xlfp + 3;
  192.    val = (*getsubr(fun))();
  193.    xlsp = xlfp;
  194.    xlfp = xlfp - (int)getfixnum(*xlfp);
  195.    xlargv = argv;
  196.    xlargc = argc;
  197.    break;
  198.     case CONS:
  199.    if (!consp(cdr(fun)))
  200.        xlerror("bad function",fun);
  201.    if ((type = car(fun)) == s_lambda)
  202.         fun = xlclose(NIL,
  203.                       s_lambda,
  204.                       car(cdr(fun)),
  205.                       cdr(cdr(fun)),
  206.                       xlenv,xlfenv);
  207.    else
  208.        xlerror("bad function",fun);
  209.    /**** fall through into the next case ****/
  210.     case CLOSURE:
  211.    if (gettype(fun) == s_lambda) {
  212.        argc = evpushargs(fun,args);
  213.        argv = xlfp + 3;
  214.        trenter(tracing,argc,argv);
  215.        val = evfun(fun,argc,argv);
  216.        trexit(tracing,val);
  217.        xlsp = xlfp;
  218.        xlfp = xlfp - (int)getfixnum(*xlfp);
  219.    }
  220.    else {
  221.        macroexpand(fun,args,&fun);
  222.        val = xleval(fun);
  223.    }
  224.    break;
  225.     default:
  226.    xlerror("bad function",fun);
  227.     }
  228.  
  229.     /* restore the stack */
  230.     xlpopn(2);
  231.  
  232.     /* return the result value */
  233.     return (val);
  234. }
  235.  
  236. /* xlexpandmacros - expand macros in a form */
  237. LVAL xlexpandmacros(form)
  238.   LVAL form;
  239. {
  240.     LVAL fun,args;
  241.  
  242.     /* protect some pointers */
  243.     xlstkcheck(3);
  244.     xlprotect(form);
  245.     xlsave(fun);
  246.     xlsave(args);
  247.  
  248.     /* expand until the form isn't a macro call */
  249.     while (consp(form)) {
  250.    fun = car(form);      /* get the macro name */
  251.    args = cdr(form);      /* get the arguments */
  252.    if (!symbolp(fun) || !fboundp(fun))
  253.        break;
  254.    fun = xlgetfunction(fun);   /* get the expansion function */
  255.    if (!macroexpand(fun,args,&form))
  256.        break;
  257.     }
  258.  
  259.     /* restore the stack and return the expansion */
  260.     xlpopn(3);
  261.     return (form);
  262. }
  263.  
  264. /* macroexpand - expand a macro call */
  265. int macroexpand(fun,args,pval)
  266.   LVAL fun,args,*pval;
  267. {
  268.     LVAL *argv;
  269.     int argc;
  270.  
  271.     /* make sure it's really a macro call */
  272.     if (!closurep(fun) || gettype(fun) != s_macro)
  273.    return (FALSE);
  274.  
  275.     /* call the expansion function */
  276.     argc = pushargs(fun,args);
  277.     argv = xlfp + 3;
  278.     *pval = evfun(fun,argc,argv);
  279.     xlsp = xlfp;
  280.     xlfp = xlfp - (int)getfixnum(*xlfp);
  281.     return (TRUE);
  282. }
  283.  
  284. /* evalhook - call the evalhook function */
  285. LOCAL LVAL evalhook(expr)
  286.   LVAL expr;
  287. {
  288.     LVAL *newfp,olddenv,val;
  289.  
  290.     /* create the new call frame */
  291.     newfp = xlsp;
  292.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  293.     pusharg(getvalue(s_evalhook));
  294.     pusharg(cvfixnum((FIXTYPE)2));
  295.     pusharg(expr);
  296.     pusharg(cons(xlenv,xlfenv));
  297.     xlfp = newfp;
  298.  
  299.     /* rebind the hook functions to nil */
  300.     olddenv = xldenv;
  301.     xldbind(s_evalhook,NIL);
  302.     xldbind(s_applyhook,NIL);
  303.  
  304.     /* call the hook function */
  305.     val = xlapply(2);
  306.  
  307.     /* unbind the symbols */
  308.     xlunbind(olddenv);
  309.  
  310.     /* return the value */
  311.     return (val);
  312. }
  313.  
  314. /* evpushargs - evaluate and push a list of arguments */
  315. LOCAL int evpushargs(fun,args)
  316.   LVAL fun,args;
  317. {
  318.     LVAL *newfp;
  319.     int argc;
  320.  
  321.     /* protect the argument list */
  322.     xlprot1(args);
  323.  
  324.     /* build a new argument stack frame */
  325.     newfp = xlsp;
  326.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  327.     pusharg(fun);
  328.     pusharg(NIL); /* will be argc */
  329.  
  330.     /* evaluate and push each argument */
  331.     for (argc = 0; consp(args); args = cdr(args), ++argc)
  332.    pusharg(xleval(car(args)));
  333.  
  334.     /* establish the new stack frame */
  335.     newfp[2] = cvfixnum((FIXTYPE)argc);
  336.     xlfp = newfp;
  337.  
  338.     /* restore the stack */
  339.     xlpop();
  340.  
  341.     /* return the number of arguments */
  342.     return (argc);
  343. }
  344.  
  345. /* pushargs - push a list of arguments */
  346. int pushargs(fun,args)
  347.   LVAL fun,args;
  348. {
  349.     LVAL *newfp;
  350.     int argc;
  351.  
  352.     /* build a new argument stack frame */
  353.     newfp = xlsp;
  354.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  355.     pusharg(fun);
  356.     pusharg(NIL); /* will be argc */
  357.  
  358.     /* push each argument */
  359.     for (argc = 0; consp(args); args = cdr(args), ++argc)
  360.    pusharg(car(args));
  361.  
  362.     /* establish the new stack frame */
  363.     newfp[2] = cvfixnum((FIXTYPE)argc);
  364.     xlfp = newfp;
  365.  
  366.     /* return the number of arguments */
  367.     return (argc);
  368. }
  369.  
  370. /* makearglist - make a list of the remaining arguments */
  371. LVAL makearglist(argc,argv)
  372.   int argc; LVAL *argv;
  373. {
  374.     LVAL list,this,last;
  375.     xlsave1(list);
  376.     for (last = NIL; --argc >= 0; last = this) {
  377.    this = cons(*argv++,NIL);
  378.    if (last) rplacd(last,this);
  379.    else list = this;
  380.    last = this;
  381.     }
  382.     xlpop();
  383.     return (list);
  384. }
  385.  
  386. /* evfun - evaluate a function */
  387. LOCAL LVAL evfun(fun,argc,argv)
  388.   LVAL fun; int argc; LVAL *argv;
  389. {
  390.     LVAL oldenv,oldfenv,cptr,name,val;
  391.     CONTEXT cntxt;
  392.  
  393.     /* protect some pointers */
  394.     xlstkcheck(3);
  395.     xlsave(oldenv);
  396.     xlsave(oldfenv);
  397.     xlsave(cptr);
  398.  
  399.     /* create a new environment frame */
  400.     oldenv = xlenv;
  401.     oldfenv = xlfenv;
  402.     xlenv = xlframe(getenv(fun));
  403.     xlfenv = getfenv(fun);
  404.  
  405.     /* bind the formal parameters */
  406.     xlabind(fun,argc,argv);
  407.  
  408.     /* setup the implicit block */
  409.     if (name = getname(fun))
  410.    xlbegin(&cntxt,CF_RETURN,name);
  411.  
  412.     /* execute the block */
  413.     if (name && setjmp(cntxt.c_jmpbuf))
  414.    val = xlvalue;
  415.     else
  416.    for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
  417.        val = xleval(car(cptr));
  418.  
  419.     /* finish the block context */
  420.     if (name)
  421.    xlend(&cntxt);
  422.  
  423.     /* restore the environment */
  424.     xlenv = oldenv;
  425.     xlfenv = oldfenv;
  426.  
  427.     /* restore the stack */
  428.     xlpopn(3);
  429.  
  430.     /* return the result value */
  431.     return (val);
  432. }
  433.  
  434. /* xlclose - create a function closure */
  435. LVAL xlclose(name,type,fargs,body,env,fenv)
  436.   LVAL name,type,fargs,body,env,fenv;
  437. {
  438.     LVAL closure,key,arg,def,svar,new,last;
  439.     char keyname[STRMAX+2];
  440.  
  441.     /* protect some pointers */
  442.     xlsave1(closure);
  443.  
  444.     /* create the closure object */
  445.     closure = newclosure(name,type,env,fenv);
  446.     setlambda(closure,fargs);
  447.     setbody(closure,body);
  448.  
  449.     /* handle each required argument */
  450.     last = NIL;
  451.     while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
  452.  
  453.    /* make sure the argument is a symbol */
  454.    if (!symbolp(arg))
  455.        badarglist();
  456.  
  457.    /* create a new argument list entry */
  458.    new = cons(arg,NIL);
  459.  
  460.    /* link it into the required argument list */
  461.    if (last)
  462.        rplacd(last,new);
  463.    else
  464.        setargs(closure,new);
  465.    last = new;
  466.  
  467.    /* move the formal argument list pointer ahead */
  468.    fargs = cdr(fargs);
  469.     }
  470.  
  471.     /* check for the '&optional' keyword */
  472.     if (consp(fargs) && car(fargs) == lk_optional) {
  473.    fargs = cdr(fargs);
  474.  
  475.    /* handle each optional argument */
  476.    last = NIL;
  477.    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
  478.  
  479.        /* get the default expression and specified-p variable */
  480.        def = svar = NIL;
  481.        if (consp(arg)) {
  482.       if (def = cdr(arg))
  483.           if (consp(def)) {
  484.          if (svar = cdr(def))
  485.              if (consp(svar)) {
  486.             svar = car(svar);
  487.             if (!symbolp(svar))
  488.                 badarglist();
  489.              }
  490.              else
  491.             badarglist();
  492.          def = car(def);
  493.           }
  494.           else
  495.          badarglist();
  496.       arg = car(arg);
  497.        }
  498.  
  499.        /* make sure the argument is a symbol */
  500.        if (!symbolp(arg))
  501.       badarglist();
  502.  
  503.        /* create a fully expanded optional expression */
  504.        new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);
  505.  
  506.        /* link it into the optional argument list */
  507.        if (last)
  508.       rplacd(last,new);
  509.        else
  510.       setoargs(closure,new);
  511.        last = new;
  512.  
  513.        /* move the formal argument list pointer ahead */
  514.        fargs = cdr(fargs);
  515.    }
  516.     }
  517.  
  518.     /* check for the '&rest' keyword */
  519.     if (consp(fargs) && car(fargs) == lk_rest) {
  520.    fargs = cdr(fargs);
  521.  
  522.    /* get the &rest argument */
  523.    if (consp(fargs) && (arg = car(fargs)) && !iskey(arg) && symbolp(arg))
  524.        setrest(closure,arg);
  525.    else
  526.        badarglist();
  527.  
  528.    /* move the formal argument list pointer ahead */
  529.    fargs = cdr(fargs);
  530.     }
  531.  
  532.     /* check for the '&key' keyword */
  533.     if (consp(fargs) && car(fargs) == lk_key) {
  534.    fargs = cdr(fargs);
  535.  
  536.     /* handle each key argument */
  537.    last = NIL;
  538.    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
  539.  
  540.        /* get the default expression and specified-p variable */
  541.        def = svar = NIL;
  542.        if (consp(arg)) {
  543.       if (def = cdr(arg))
  544.           if (consp(def)) {
  545.          if (svar = cdr(def))
  546.              if (consp(svar)) {
  547.             svar = car(svar);
  548.             if (!symbolp(svar))
  549.                 badarglist();
  550.              }
  551.              else
  552.             badarglist();
  553.          def = car(def);
  554.           }
  555.           else
  556.          badarglist();
  557.       arg = car(arg);
  558.        }
  559.  
  560.        /* get the keyword and the variable */
  561.        if (consp(arg)) {
  562.       key = car(arg);
  563.       if (!symbolp(key))
  564.           badarglist();
  565.       if (arg = cdr(arg))
  566.           if (consp(arg))
  567.          arg = car(arg);
  568.           else
  569.          badarglist();
  570.        }
  571.        else if (symbolp(arg)) {
  572.       strcpy(keyname,":");
  573.       strcat(keyname,getstring(getpname(arg)));
  574.       key = xlenter(keyname);
  575.        }
  576.  
  577.        /* make sure the argument is a symbol */
  578.        if (!symbolp(arg))
  579.       badarglist();
  580.  
  581.        /* create a fully expanded key expression */
  582.        new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);
  583.  
  584.        /* link it into the optional argument list */
  585.        if (last)
  586.       rplacd(last,new);
  587.        else
  588.       setkargs(closure,new);
  589.        last = new;
  590.  
  591.        /* move the formal argument list pointer ahead */
  592.        fargs = cdr(fargs);
  593.    }
  594.     }
  595.  
  596.     /* check for the '&allow-other-keys' keyword */
  597.     if (consp(fargs) && car(fargs) == lk_allow_other_keys)
  598.    fargs = cdr(fargs);   /* this is the default anyway */
  599.  
  600.     /* check for the '&aux' keyword */
  601.     if (consp(fargs) && car(fargs) == lk_aux) {
  602.    fargs = cdr(fargs);
  603.  
  604.    /* handle each aux argument */
  605.    last = NIL;
  606.    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
  607.  
  608.        /* get the initial value */
  609.        def = NIL;
  610.        if (consp(arg)) {
  611.       if (def = cdr(arg))
  612.           if (consp(def))
  613.          def = car(def);
  614.           else
  615.          badarglist();
  616.       arg = car(arg);
  617.        }
  618.  
  619.        /* make sure the argument is a symbol */
  620.        if (!symbolp(arg))
  621.       badarglist();
  622.  
  623.        /* create a fully expanded aux expression */
  624.        new = cons(cons(arg,cons(def,NIL)),NIL);
  625.  
  626.        /* link it into the aux argument list */
  627.        if (last)
  628.       rplacd(last,new);
  629.        else
  630.       setaargs(closure,new);
  631.        last = new;
  632.  
  633.        /* move the formal argument list pointer ahead */
  634.        fargs = cdr(fargs);
  635.    }
  636.     }
  637.  
  638.     /* make sure this is the end of the formal argument list */
  639.     if (fargs)
  640.    badarglist();
  641.  
  642.     /* restore the stack */
  643.     xlpop();
  644.  
  645.     /* return the new closure */
  646.     return (closure);
  647. }
  648.  
  649. /* xlabind - bind the arguments for a function */
  650. xlabind(fun,argc,argv)
  651.   LVAL fun; int argc; LVAL *argv;
  652. {
  653.     LVAL *kargv,fargs,key,arg,def,svar,p;
  654.     int rargc,kargc;
  655.  
  656.     /* protect some pointers */
  657.     xlsave1(def);
  658.  
  659.     /* bind each required argument */
  660.     for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {
  661.  
  662.    /* make sure there is an actual argument */
  663.    if (--argc < 0)
  664.        xlfail("too few arguments");
  665.  
  666.    /* bind the formal variable to the argument value */
  667.    xlbind(car(fargs),*argv++);
  668.     }
  669.  
  670.     /* bind each optional argument */
  671.     for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {
  672.  
  673.    /* get argument, default and specified-p variable */
  674.    p = car(fargs);
  675.    arg = car(p); p = cdr(p);
  676.    def = car(p); p = cdr(p);
  677.    svar = car(p);
  678.  
  679.    /* bind the formal variable to the argument value */
  680.    if (--argc >= 0) {
  681.        xlbind(arg,*argv++);
  682.        if (svar) xlbind(svar,true);
  683.    }
  684.  
  685.    /* bind the formal variable to the default value */
  686.    else {
  687.        if (def) def = xleval(def);
  688.        xlbind(arg,def);
  689.        if (svar) xlbind(svar,NIL);
  690.    }
  691.     }
  692.  
  693.     /* save the count of the &rest of the argument list */
  694.     rargc = argc;
  695.  
  696.     /* handle '&rest' argument */
  697.     if (arg = getrest(fun)) {
  698.    def = makearglist(argc,argv);
  699.    xlbind(arg,def);
  700.    argc = 0;
  701.     }
  702.  
  703.     /* handle '&key' arguments */
  704.     if (fargs = getkargs(fun)) {
  705.    for (; fargs; fargs = cdr(fargs)) {
  706.  
  707.        /* get keyword, argument, default and specified-p variable */
  708.        p = car(fargs);
  709.        key = car(p); p = cdr(p);
  710.        arg = car(p); p = cdr(p);
  711.        def = car(p); p = cdr(p);
  712.        svar = car(p);
  713.  
  714.        /* look for the keyword in the actual argument list */
  715.        for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
  716.       if (*kargv == key)
  717.           break;
  718.  
  719.        /* bind the formal variable to the argument value */
  720.        if (kargc >= 0) {
  721.       xlbind(arg,*++kargv);
  722.       if (svar) xlbind(svar,true);
  723.        }
  724.  
  725.        /* bind the formal variable to the default value */
  726.        else {
  727.       if (def) def = xleval(def);
  728.       xlbind(arg,def);
  729.       if (svar) xlbind(svar,NIL);
  730.        }
  731.    }
  732.    argc = 0;
  733.     }
  734.  
  735.     /* check for the '&aux' keyword */
  736.     for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {
  737.  
  738.    /* get argument and default */
  739.    p = car(fargs);
  740.    arg = car(p); p = cdr(p);
  741.    def = car(p);
  742.  
  743.    /* bind the auxiliary variable to the initial value */
  744.    if (def) def = xleval(def);
  745.    xlbind(arg,def);
  746.     }
  747.  
  748.     /* make sure there aren't too many arguments */
  749.     if (argc > 0)
  750.    xlfail("too many arguments");
  751.  
  752.     /* restore the stack */
  753.     xlpop();
  754. }
  755.  
  756. /* doenter - print trace information on function entry */
  757. LOCAL doenter(sym,argc,argv)
  758.   LVAL sym; int argc; LVAL *argv;
  759. {
  760.     extern int xltrcindent;
  761.     int i;
  762.  
  763.     /* indent to the current trace level */
  764.     for (i = 0; i < xltrcindent; ++i)
  765.    trcputstr(" ");
  766.     ++xltrcindent;
  767.  
  768.     /* display the function call */
  769.     sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym)));
  770.     trcputstr(buf);
  771.     while (--argc >= 0) {
  772.    trcprin1(*argv++);
  773.    if (argc) trcputstr(" ");
  774.     }
  775.     trcputstr(")\n");
  776. }
  777.  
  778. /* doexit - print trace information for function/macro exit */
  779. LOCAL doexit(sym,val)
  780.   LVAL sym,val;
  781. {
  782.     extern int xltrcindent;
  783.     int i;
  784.  
  785.     /* indent to the current trace level */
  786.     --xltrcindent;
  787.     for (i = 0; i < xltrcindent; ++i)
  788.    trcputstr(" ");
  789.  
  790.     /* display the function value */
  791.     sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym)));
  792.     trcputstr(buf);
  793.     trcprin1(val);
  794.     trcputstr("\n");
  795. }
  796.  
  797. /* member - is 'x' a member of 'list'? */
  798. LOCAL int member(x,list)
  799.   LVAL x,list;
  800. {
  801.     for (; consp(list); list = cdr(list))
  802.    if (x == car(list))
  803.        return (TRUE);
  804.     return (FALSE);
  805. }
  806.  
  807. /* xlunbound - signal an unbound variable error */
  808. xlunbound(sym)
  809.   LVAL sym;
  810. {
  811.     xlcerror("try evaluating symbol again","unbound variable",sym);
  812. }
  813.  
  814. /* xlfunbound - signal an unbound function error */
  815. xlfunbound(sym)
  816.   LVAL sym;
  817. {
  818.     xlcerror("try evaluating symbol again","unbound function",sym);
  819. }
  820.  
  821. /* xlstkoverflow - signal a stack overflow error */
  822. xlstkoverflow()
  823. {
  824.     xlabort("evaluation stack overflow");
  825. }
  826.  
  827. /* xlargstkoverflow - signal an argument stack overflow error */
  828. xlargstkoverflow()
  829. {
  830.     xlabort("argument stack overflow");
  831. }
  832.  
  833. /* badarglist - report a bad argument list error */
  834. LOCAL badarglist()
  835. {
  836.     xlfail("bad formal argument list");
  837. }
  838.