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