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