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