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