home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / xlispsrc / xleval.c < prev    next >
C/C++ Source or Header  |  1988-02-11  |  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.