home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xlcont.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-08  |  36.5 KB  |  1,590 lines
  1. /* xlcont - xlisp special forms */
  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. /* external variables */
  9. extern LVAL xlenv,xlfenv,xldenv,xlvalue;
  10. extern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
  11. extern LVAL s_svalue,s_sfunction,s_splist;
  12. extern LVAL s_lambda,s_macro;
  13. extern LVAL s_comma,s_comat;
  14. extern LVAL s_unbound;
  15. extern LVAL s_tracelist;    /* TAA MOD -- why wasn't this used before? */
  16. extern LVAL true;
  17. extern LVAL s_elt;
  18. #ifdef HASHFCNS
  19. extern LVAL s_gethash;
  20. #endif
  21.  
  22. /* forward declarations */
  23. #ifdef ANSI
  24. LVAL XNEAR evarg(LVAL *pargs);
  25. LVAL XNEAR match(int type, LVAL *pargs);
  26. LVAL XNEAR evmatch(int type, LVAL *pargs);
  27. VOID XNEAR placeform(LVAL place, LVAL value);
  28. VOID XNEAR setffunction(LVAL fun, LVAL place, LVAL value);
  29. VOID XNEAR doupdates(LVAL list, int pflags);
  30. VOID XNEAR tagbody(void);
  31. int  XNEAR keypresent(LVAL key, LVAL list);
  32. VOID XNEAR dobindings(LVAL list, LVAL env, LVAL *denv, int seq);
  33. #else
  34. FORWARD LVAL evarg();
  35. FORWARD LVAL match();
  36. FORWARD LVAL evmatch();
  37. FORWARD VOID placeform();
  38. FORWARD VOID setffunction();
  39. FORWARD VOID dobindings();
  40. FORWARD VOID doupdates();
  41. FORWARD VOID tagbody();
  42. #endif
  43.  
  44. /* dummy node type for a list */
  45. #define LIST    -1
  46.  
  47. /* toofew - too few arguments */
  48. #ifdef ANSI
  49. static void XNEAR toofew(LVAL args)
  50. #else
  51. LOCAL VOID XNEAR toofew(args)
  52.   LVAL args;
  53. #endif
  54. {
  55.     xlerror("too few arguments",args);
  56. }
  57.  
  58. /* toomany - too many arguments */
  59. #ifdef ANSI
  60. static void XNEAR toomany(LVAL args)
  61. #else
  62. LOCAL VOID XNEAR toomany(args)
  63.   LVAL args;
  64. #endif
  65. {
  66.     xlerror("too many arguments",args);
  67. }
  68.  
  69. /* xquote - special form 'quote' */
  70. LVAL xquote()
  71. {
  72.     LVAL val;
  73.     val = xlgetarg();
  74.     xllastarg();
  75.     return (val);
  76. }
  77.  
  78. /* xfunction - special form 'function' */
  79. LVAL xfunction()
  80. {
  81.     LVAL val;
  82.  
  83.     /* get the argument */
  84.     val = xlgetarg();
  85.     xllastarg();
  86.  
  87.     /* create a closure for lambda expressions */
  88.     if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
  89.         val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);
  90.  
  91.     /* otherwise, get the value of a symbol */
  92.     else if (symbolp(val))
  93.         val = xlgetfunction(val);
  94.  
  95.     /* otherwise, its an error */
  96.     else
  97.         xlerror("not a function",val);
  98.  
  99.     /* return the function */
  100.     return (val);
  101. }
  102.  
  103. /* bquote1 - back quote helper function */
  104. #ifdef ANSI
  105. static LVAL XNEAR bquote1(LVAL expr)
  106. #else
  107. LOCAL LVAL XNEAR bquote1(expr)
  108.   LVAL expr;
  109. #endif
  110. {
  111.     LVAL val,list,last,new;
  112.  
  113.     /* handle atoms */
  114.     if (atom(expr))
  115.         val = expr;
  116.  
  117.     /* handle (comma <expr>) */
  118.     else if (car(expr) == s_comma) {
  119.         if (atom(cdr(expr)))
  120.             xlfail("bad comma expression");
  121.         val = xleval(car(cdr(expr)));
  122.     }
  123.  
  124.     /* handle ((comma-at <expr>) ... ) */
  125.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  126.         xlstkcheck(2);
  127.         xlsave(list);
  128.         xlsave(val);
  129.         if (atom(cdr(car(expr))))
  130.             xlfail("bad comma-at expression");
  131.         list = xleval(car(cdr(car(expr))));
  132.         for (last = NIL; consp(list); list = cdr(list)) {
  133.             new = consa(car(list));
  134.             if (!null(last))
  135.                 rplacd(last,new);
  136.             else
  137.                 val = new;
  138.             last = new;
  139.         }
  140.         if (!null(last))
  141.             rplacd(last,bquote1(cdr(expr)));
  142.         else
  143.             val = bquote1(cdr(expr));
  144.         xlpopn(2);
  145.     }
  146.  
  147.     /* handle any other list */
  148.     else {
  149.         xlsave1(val);
  150.         val = consa(NIL);
  151.         rplaca(val,bquote1(car(expr)));
  152.         rplacd(val,bquote1(cdr(expr)));
  153.         xlpop();
  154.     }
  155.  
  156.     /* return the result */
  157.     return (val);
  158. }
  159.  
  160. /* xbquote - back quote special form */
  161. LVAL xbquote()
  162. {
  163.     LVAL expr;
  164.  
  165.     /* get the expression */
  166.     expr = xlgetarg();
  167.     xllastarg();
  168.  
  169.     /* fill in the template */
  170.     return (bquote1(expr));
  171. }
  172.  
  173. /* xlambda - special form 'lambda' */
  174. LVAL xlambda()
  175. {
  176.     LVAL fargs,arglist,val;
  177.  
  178.     /* get the formal argument list and function body */
  179.     xlsave1(arglist);
  180.     fargs = xlgalist();
  181.     arglist = makearglist(xlargc,xlargv);
  182.  
  183.     /* create a new function definition */
  184.     val = xlclose(NIL,s_lambda,fargs,arglist,xlenv,xlfenv);
  185.  
  186.     /* restore the stack and return the closure */
  187.     xlpop();
  188.     return (val);
  189. }
  190.  
  191. /* xgetlambda - get the lambda expression associated with a closure */
  192. LVAL xgetlambda()
  193. {
  194.     LVAL closure;
  195.     closure = xlgaclosure();
  196.     return (cons(gettype(closure),
  197.                  cons(getlambda(closure),getbody(closure))));
  198. }
  199.  
  200. /* xsetq - special form 'setq' */
  201. LVAL xsetq()
  202. {
  203.     LVAL sym,val;
  204.  
  205.     /* handle each pair of arguments */
  206.     for (val = NIL; moreargs(); ) {
  207.         sym = xlgasymbol();
  208.         val = xleval(nextarg());
  209.         xlsetvalue(sym,val);
  210.     }
  211.  
  212.     /* return the result value */
  213.     return (val);
  214. }
  215.  
  216. /* xpsetq - special form 'psetq' */
  217. LVAL xpsetq()
  218. {
  219.     LVAL plist,sym,val;
  220.  
  221.     /* protect some pointers */
  222.     xlsave1(plist);
  223.  
  224.     /* handle each pair of arguments */
  225.     for (val = NIL; moreargs(); ) {
  226.         sym = xlgasymbol();
  227.         val = xleval(nextarg());
  228.         plist = cons(cons(sym,val),plist);
  229.     }
  230.  
  231.     /* do parallel sets */
  232.     for (; !null(plist); plist = cdr(plist))
  233.         xlsetvalue(car(car(plist)),cdr(car(plist)));
  234.  
  235.     /* restore the stack */
  236.     xlpop();
  237.  
  238.     /* return the result value */
  239.     return (val);
  240. }
  241.  
  242. /* xsetf - special form 'setf' */
  243. LVAL xsetf()
  244. {
  245.     LVAL place,value;
  246.  
  247.     /* protect some pointers */
  248.     xlsave1(value);
  249.  
  250.     /* handle each pair of arguments */
  251.     while (moreargs()) {
  252.  
  253.         /* get place and value */
  254.         place = xlgetarg();
  255.         value = xleval(nextarg());
  256.  
  257.         /* expand macros in the place form */
  258.         if (consp(place))
  259.             place = xlexpandmacros(place);
  260.  
  261.         /* check the place form */
  262.         if (symbolp(place))
  263.             xlsetvalue(place,value);
  264.         else if (consp(place))
  265.             placeform(place,value);
  266.         else
  267.             xlfail("bad place form");
  268.     }
  269.  
  270.     /* restore the stack */
  271.     xlpop();
  272.  
  273.     /* return the value */
  274.     return (value);
  275. }
  276.  
  277. /* placeform - handle a place form other than a symbol */
  278. LOCAL VOID XNEAR placeform(place,value)
  279.   LVAL place,value;
  280. {
  281.     LVAL fun,arg1,arg2;
  282.     FIXTYPE i;  /* TAA fix */
  283.  
  284.     /* check the function name */
  285.     if ((fun = match(SYMBOL,&place)) == s_get) {
  286.         xlstkcheck(2);
  287.         xlsave(arg1);
  288.         xlsave(arg2);
  289.         arg1 = evmatch(SYMBOL,&place);
  290.         arg2 = evarg(&place);
  291.         if (!null(place)) toomany(place);
  292.         xlputprop(arg1,value,arg2);
  293.         xlpopn(2);
  294.     }
  295.     else if (fun == s_svalue) {
  296.         arg1 = evmatch(SYMBOL,&place);
  297.         if (!null(place)) toomany(place);
  298.         if (constantp(arg1)) xlnoassign(arg1);
  299.         setvalue(arg1,value);
  300.     }
  301.     else if (fun == s_sfunction) {
  302.         arg1 = evmatch(SYMBOL,&place);
  303.         if (!null(place)) toomany(place);
  304.         setfunction(arg1,value);
  305.     }
  306.     else if (fun == s_splist) {
  307.         arg1 = evmatch(SYMBOL,&place);
  308.         if (!null(place)) toomany(place);
  309.         setplist(arg1,value);
  310.     }
  311.     else if (fun == s_car) {
  312.         arg1 = evmatch(CONS,&place);
  313.         if (!null(place)) toomany(place);
  314.         rplaca(arg1,value);
  315.     }
  316.     else if (fun == s_cdr) {
  317.         arg1 = evmatch(CONS,&place);
  318.         if (!null(place)) toomany(place);
  319.         rplacd(arg1,value);
  320.     }
  321.     else if (fun == s_nth) {
  322.         xlsave1(arg1);
  323.         arg1 = evmatch(FIXNUM,&place);
  324.         arg2 = evmatch(LIST,&place);
  325.         if (!null(place)) toomany(place);
  326.         for (i = /*(int) */getfixnum(arg1); i > 0 && consp(arg2); --i)
  327.             arg2 = cdr(arg2);
  328.         if (consp(arg2))
  329.             rplaca(arg2,value);
  330.         xlpop();
  331.     }
  332.     else if (fun == s_aref) {
  333.         xlsave1(arg1);
  334.         arg1 = evarg(&place);
  335.         arg2 = evmatch(FIXNUM,&place); i = getfixnum(arg2);
  336.         if (!null(place)) toomany(place);
  337.         if (stringp(arg1)) {    /* extension for strings */
  338.             if (i < 0 || i >= getslength(arg1))
  339.                 xlerror("index out of range",arg2);
  340.             if (!charp(value))
  341.                 xlerror("strings only contain characters",value);
  342.             setstringch(arg1,(int)i,getchcode(value));
  343.         }
  344.         else if(vectorp(arg1)) {
  345.         if (i < 0 || i >= getsize(arg1))
  346.             xlerror("index out of range",arg2);
  347.         setelement(arg1,(int)i,value);  /*taa fix -- added cast */
  348.         }
  349.         else xlbadtype(arg1);
  350.         xlpop();
  351.     }
  352.     else if (fun == s_elt) {
  353.         xlsave1(arg1);
  354.         arg1 = evarg(&place);
  355.         arg2 = evmatch(FIXNUM,&place); i = getfixnum(arg2);
  356.         if (!null(place)) toomany(place);
  357.         if (listp(arg1)) {
  358.             for (; i > 0 && consp(arg1); --i)
  359.                 arg1 = cdr(arg1);
  360.             if((!consp(arg1)) || i < 0)
  361.                 xlerror("index out of range",arg2);
  362.             rplaca(arg1,value);
  363.         }
  364.         else if (ntype(arg1) == STRING) {
  365.             if (i < 0 || i >= getslength(arg1))
  366.                 xlerror("index out of range",arg2);
  367.             if (!charp(value))
  368.                 xlerror("strings only contain characters",value);
  369.             setstringch(arg1,(int)i,getchcode(value));
  370.         }
  371.         else if (ntype(arg1) == VECTOR) {
  372.             if (i < 0 || i >= getsize(arg1))
  373.                 xlerror("index out of range",arg2);
  374.             setelement(arg1,(int)i,value);
  375.         }
  376.         else xlbadtype(arg1);
  377.         xlpop();
  378.     }
  379. #ifdef HASHFCNS
  380.     else if (fun == s_gethash) {
  381.         xlstkcheck(2);
  382.         xlsave(arg1);
  383.         xlsave(arg2);
  384.         arg1 = evarg(&place);
  385.         arg2 = evarg(&place);
  386.         if (consp(place)) place = cdr(place);
  387.         if (!null(place)) toomany(place);
  388.         xlsetgethash(arg1,arg2,value);
  389.         xlpopn(2);
  390.         }
  391. #endif
  392.     else if (!null(fun = xlgetprop(fun,s_setf)))
  393.         setffunction(fun,place,value);
  394.     else
  395.         xlfail("bad place form");
  396. }
  397.  
  398. /* setffunction - call a user defined setf function */
  399. LOCAL VOID XNEAR setffunction(fun,place,value)
  400.   LVAL fun,place,value;
  401. {
  402.     FRAMEP newfp;
  403.     int argc;
  404.  
  405.     /* create the new call frame */
  406.     newfp = xlsp;
  407.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  408.     pusharg(fun);
  409.     pusharg(NIL);
  410.  
  411.     /* push the values of all of the place expressions and the new value */
  412.     for (argc = 1; consp(place); place = cdr(place), ++argc)
  413.         pusharg(xleval(car(place)));
  414.     pusharg(value);
  415.  
  416.     /* insert the argument count and establish the call frame */
  417.     newfp[2] = cvfixnum((FIXTYPE)argc);
  418.     xlfp = newfp;
  419.  
  420.     /* apply the function */
  421.     xlapply(argc);
  422. }
  423.  
  424. /* xdefun - special form 'defun' */
  425. LVAL xdefun()
  426. {
  427.     LVAL sym,fargs,arglist;
  428.  
  429.     /* get the function symbol and formal argument list */
  430.     xlsave1(arglist);
  431.     sym = xlgasymbol();
  432.     fargs = xlgalist();
  433.     arglist = makearglist(xlargc,xlargv);
  434.  
  435.     /* make the symbol point to a new function definition */
  436.     xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));
  437.  
  438.     /* restore the stack and return the function symbol */
  439.     xlpop();
  440.     return (sym);
  441. }
  442.  
  443. /* xdefmacro - special form 'defmacro' */
  444. LVAL xdefmacro()
  445. {
  446.     LVAL sym,fargs,arglist;
  447.  
  448.     /* get the function symbol and formal argument list */
  449.     xlsave1(arglist);
  450.     sym = xlgasymbol();
  451.     fargs = xlgalist();
  452.     arglist = makearglist(xlargc,xlargv);
  453.  
  454.     /* make the symbol point to a new function definition */
  455.     xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));
  456.  
  457.     /* restore the stack and return the function symbol */
  458.     xlpop();
  459.     return (sym);
  460. }
  461.  
  462. /* xcond - special form 'cond' */
  463. LVAL xcond()
  464. {
  465.     LVAL list,val;
  466.  
  467.     /* find a predicate that is true */
  468.     for (val = NIL; moreargs(); ) {
  469.  
  470.         /* get the next conditional */
  471.         list = nextarg();
  472.  
  473.         /* evaluate the predicate part */
  474.         if (consp(list) && !null(val = xleval(car(list)))) {
  475.  
  476.             /* evaluate each expression */
  477.             for (list = cdr(list); consp(list); list = cdr(list))
  478.                 val = xleval(car(list));
  479.  
  480.             /* exit the loop */
  481.             break;
  482.         }
  483.     }
  484.  
  485.     /* return the value */
  486.     return (val);
  487. }
  488.  
  489. /* xwhen - special form 'when' */
  490. LVAL xwhen()
  491. {
  492.     LVAL val;
  493.  
  494.     /* check the test expression */
  495.     if (!null(val = xleval(xlgetarg())))
  496.         while (moreargs())
  497.             val = xleval(nextarg());
  498.  
  499.     /* return the value */
  500.     return (val);
  501. }
  502.  
  503. /* xunless - special form 'unless' */
  504. LVAL xunless()
  505. {
  506.     LVAL val=NIL;
  507.  
  508.     /* check the test expression */
  509.     if (null(xleval(xlgetarg())))
  510.         while (moreargs())
  511.             val = xleval(nextarg());
  512.  
  513.     /* return the value */
  514.     return (val);
  515. }
  516.  
  517. /* xcase - special form 'case' */
  518. LVAL xcase()
  519. {
  520.     LVAL key,list,cases,val;
  521.  
  522.     /* protect some pointers */
  523.     xlsave1(key);
  524.  
  525.     /* get the key expression */
  526.     key = xleval(nextarg());
  527.  
  528.     /* find a case that matches */
  529.     for (val = NIL; moreargs(); ) {
  530.  
  531.         /* get the next case clause */
  532.         list = nextarg();
  533.  
  534.         /* make sure this is a valid clause */
  535.         if (consp(list)) {
  536.  
  537.             /* compare the key list against the key */
  538.             if (((cases = car(list)) == true && ! moreargs())||
  539.                 (listp(cases) && keypresent(key,cases)) ||
  540.                 eql(key,cases)) {
  541.  
  542.                 /* evaluate each expression */
  543.                 for (list = cdr(list); consp(list); list = cdr(list))
  544.                     val = xleval(car(list));
  545.  
  546.                 /* exit the loop */
  547.                 break;
  548.             }
  549.         }
  550.         else
  551.             xlerror("bad case clause",list);
  552.     }
  553.  
  554.     /* restore the stack */
  555.     xlpop();
  556.  
  557.     /* return the value */
  558.     return (val);
  559. }
  560.  
  561. /* keypresent - check for the presence of a key in a list */
  562. LOCAL int XNEAR keypresent(key,list)
  563.   LVAL key,list;
  564. {
  565.     for (; consp(list); list = cdr(list))
  566.         if (eql(car(list),key))
  567.             return (TRUE);
  568.     return (FALSE);
  569. }
  570.  
  571. /* xand - special form 'and' */
  572. LVAL xand()
  573. {
  574.     LVAL val;
  575.  
  576.     /* evaluate each argument */
  577.     for (val = true; moreargs(); )
  578.         if (null(val = xleval(nextarg())))
  579.             break;
  580.  
  581.     /* return the result value */
  582.     return (val);
  583. }
  584.  
  585. /* xor - special form 'or' */
  586. LVAL xor()
  587. {
  588.     LVAL val;
  589.  
  590.     /* evaluate each argument */
  591.     for (val = NIL; moreargs(); )
  592.         if (!null(val = xleval(nextarg())))
  593.             break;
  594.  
  595.     /* return the result value */
  596.     return (val);
  597. }
  598.  
  599. /* xif - special form 'if' */
  600. LVAL xif()
  601. {
  602.     LVAL testexpr,thenexpr,elseexpr;
  603.  
  604.     /* get the test expression, then clause and else clause */
  605.     testexpr = xlgetarg();
  606.     thenexpr = xlgetarg();
  607.     elseexpr = (moreargs() ? xlgetarg() : NIL);
  608.     xllastarg();
  609.  
  610.     /* evaluate the appropriate clause */
  611.     return (xleval(null(xleval(testexpr))? elseexpr : thenexpr));
  612. }
  613.  
  614. /* let - common let routine */
  615. #ifdef ANSI
  616. static LVAL XNEAR let(int pflag)
  617. #else
  618. LOCAL LVAL XNEAR let(pflag)
  619.   int pflag;
  620. #endif
  621. {
  622.     LVAL newenv,val;
  623.     LVAL olddenv=xldenv;
  624.  
  625.     /* protect some pointers */
  626.     xlsave1(newenv);
  627.  
  628.     /* create a new environment frame */
  629.     newenv = xlframe(xlenv);
  630.  
  631.     /* get the list of bindings and bind the symbols */
  632.     if (pflag) {    /* bind "simultaneously" */
  633.         LVAL newdenv = xldenv;
  634.         dobindings(xlgalist(), newenv, &newdenv, FALSE);
  635.         xlenv = newenv;
  636.         xldenv = newdenv;
  637.     }
  638.     else {          /* bind "sequentially") */
  639.         xlenv = newenv;
  640.         dobindings(xlgalist(), newenv, &xldenv, TRUE);
  641.     }
  642.  
  643.     /* execute the code */
  644.     for (val = NIL; moreargs(); )
  645.         val = xleval(nextarg());
  646.  
  647.     /* unbind the arguments */
  648.     xlenv = cdr(xlenv);
  649.  
  650.     /* restore the stack */
  651.     xlunbind(olddenv);
  652.     xlpop();
  653.  
  654.     /* return the result */
  655.     return (val);
  656. }
  657.  
  658. /* xlet - special form 'let' */
  659. LVAL xlet()
  660. {
  661.     return (let(TRUE));
  662. }
  663.  
  664. /* xletstar - special form 'let*' */
  665. LVAL xletstar()
  666. {
  667.     return (let(FALSE));
  668. }
  669.  
  670. /* flet - common flet/labels/macrolet routine */
  671. #ifdef ANSI
  672. static LVAL XNEAR flet(LVAL type, int letflag)
  673. #else
  674. LOCAL LVAL XNEAR flet(type,letflag)
  675.   LVAL type; int letflag;
  676. #endif
  677. {
  678.     LVAL list,bnd,sym,fargs,val;
  679.  
  680.     /* create a new environment frame */
  681.     xlfenv = xlframe(xlfenv);
  682.  
  683.     /* bind each symbol in the list of bindings */
  684.     for (list = xlgalist(); consp(list); list = cdr(list)) {
  685.  
  686.         /* get the next binding */
  687.         bnd = car(list);
  688.  
  689.         /* get the symbol and the function definition */
  690.         sym = match(SYMBOL,&bnd);
  691.         fargs = match(LIST,&bnd);
  692.         val = xlclose(sym,type,fargs,bnd,xlenv,(letflag?cdr(xlfenv):xlfenv));
  693.  
  694.         /* bind the value to the symbol */
  695.         xlfbind(sym,val);
  696.     }
  697.  
  698.     /* execute the code */
  699.     for (val = NIL; moreargs(); )
  700.         val = xleval(nextarg());
  701.  
  702.     /* unbind the arguments */
  703.     xlfenv = cdr(xlfenv);
  704.  
  705.     /* return the result */
  706.     return (val);
  707. }
  708.  
  709. /* xflet - built-in function 'flet' */
  710. LVAL xflet()
  711. {
  712.     return (flet(s_lambda,TRUE));
  713. }
  714.  
  715. /* xlabels - built-in function 'labels' */
  716. LVAL xlabels()
  717. {
  718.     return (flet(s_lambda,FALSE));
  719. }
  720.  
  721. /* xmacrolet - built-in function 'macrolet' */
  722. LVAL xmacrolet()
  723. {
  724.     return (flet(s_macro,TRUE));
  725. }
  726.  
  727. /* prog - common prog routine */
  728. #ifdef ANSI
  729. static LVAL XNEAR prog(int pflag)
  730. #else
  731. LOCAL LVAL XNEAR prog(pflag)
  732.   int pflag;
  733. #endif
  734. {
  735.     LVAL newenv,val;
  736.     CONTEXT cntxt;
  737.     LVAL olddenv=xldenv;
  738.  
  739.     /* protect some pointers */
  740.     xlsave1(newenv);
  741.  
  742.     /* create a new environment frame */
  743.     newenv = xlframe(xlenv);
  744.  
  745.     /* establish a new execution context */
  746.     xlbegin(&cntxt,CF_RETURN,NIL);
  747.     if (setjmp(cntxt.c_jmpbuf))
  748.         val = xlvalue;
  749.     else {
  750.  
  751.         /* get the list of bindings and bind the symbols */
  752.         if (pflag) {    /* bind "simultaneously" */
  753.             LVAL newdenv = xldenv;
  754.             dobindings(xlgalist(), newenv, &newdenv, FALSE);
  755.             xlenv = newenv;
  756.             xldenv = newdenv;
  757.         }
  758.         else {          /* bind "sequentially") */
  759.             xlenv = newenv;
  760.             dobindings(xlgalist(), newenv, &xldenv, TRUE);
  761.         }
  762.  
  763.         /* execute the code */
  764.         tagbody();
  765.         val = NIL;
  766.  
  767.         /* unbind the arguments */
  768.         xlenv = cdr(xlenv);
  769.     }
  770.     xlend(&cntxt);
  771.  
  772.     /* restore the stack */
  773.     xlunbind(olddenv);
  774.     xlpop();
  775.  
  776.     /* return the result */
  777.     return (val);
  778. }
  779.  
  780. /* xprog - special form 'prog' */
  781. LVAL xprog()
  782. {
  783.     return (prog(TRUE));
  784. }
  785.  
  786. /* xprogstar - special form 'prog*' */
  787. LVAL xprogstar()
  788. {
  789.     return (prog(FALSE));
  790. }
  791.  
  792. /* xgo - special form 'go' */
  793. LVAL xgo()
  794. {
  795.     LVAL label;
  796.  
  797.     /* get the target label */
  798.     label = xlgetarg();
  799.     xllastarg();
  800.  
  801.     /* transfer to the label */
  802.     xlgo(label);
  803.     return (NIL);
  804. }
  805.  
  806. /* xreturn - special form 'return' */
  807. LVAL xreturn()
  808. {
  809.     LVAL val;
  810.  
  811.     /* get the return value */
  812.     val = (moreargs() ? xleval(nextarg()) : NIL);
  813.     xllastarg();
  814.  
  815.     /* return from the inner most block */
  816.     xlreturn(NIL,val);
  817.     return (NIL);
  818. }
  819.  
  820. /* xrtnfrom - special form 'return-from' */
  821. LVAL xrtnfrom()
  822. {
  823.     LVAL name,val;
  824.  
  825.     /* get the return value */
  826.     name = xlgasymbol();
  827.     val = (moreargs() ? xleval(nextarg()) : NIL);
  828.     xllastarg();
  829.  
  830.     /* return from the inner most block */
  831.     xlreturn(name,val);
  832.     return (NIL);
  833. }
  834.  
  835. /* progx - common progx code */
  836. #ifdef ANSI
  837. static LVAL XNEAR progx(int n)
  838. #else
  839. LOCAL LVAL XNEAR progx(n)
  840.   int n;
  841. #endif
  842. {
  843.     LVAL val;
  844.  
  845.     /* protect some pointers */
  846.     xlsave1(val);
  847.  
  848.     /* evaluate the first n expressions */
  849.     while (moreargs() && --n >= 0)
  850.         val = xleval(nextarg());
  851.  
  852.     /* evaluate each remaining argument */
  853.     while (moreargs())
  854.         xleval(nextarg());
  855.  
  856.     /* restore the stack */
  857.     xlpop();
  858.  
  859.     /* return the last test expression value */
  860.     return (val);
  861. }
  862.  
  863. /* xprog1 - special form 'prog1' */
  864. LVAL xprog1()
  865. {
  866.     return (progx(1));
  867. }
  868.  
  869. /* xprog2 - special form 'prog2' */
  870. LVAL xprog2()
  871. {
  872.     return (progx(2));
  873. }
  874.  
  875. /* xprogn - special form 'progn' */
  876. LVAL xprogn()
  877. {
  878.     LVAL val;
  879.  
  880.     /* evaluate each expression */
  881.     for (val = NIL; moreargs(); )
  882.         val = xleval(nextarg());
  883.  
  884.     /* return the last test expression value */
  885.     return (val);
  886. }
  887.  
  888. /* xprogv - special form 'progv' */
  889. LVAL xprogv()
  890. {
  891.     LVAL olddenv,vars,vals,val;
  892.  
  893.     /* protect some pointers */
  894.     xlstkcheck(2);
  895.     xlsave(vars);
  896.     xlsave(vals);
  897.  
  898.     /* get the list of variables and the list of values */
  899.     vars = xlgalist(); vars = xleval(vars);
  900.     vals = xlgalist(); vals = xleval(vals);
  901.  
  902.     /* bind the values to the variables */
  903.     for (olddenv = xldenv; consp(vars); vars = cdr(vars)) {
  904.         val = car(vars);    /* TAA mod, reducing car(vars) operation */
  905.         if (!symbolp(val))
  906.             xlerror("expecting a symbol",val);
  907.         if (constantp(val))
  908.             xlnoassign(val);
  909.         if (consp(vals)) {
  910.             xldbind(val,car(vals));
  911.             vals = cdr(vals);
  912.         }
  913.         else
  914.             xldbind(val,s_unbound);
  915.     }
  916.  
  917.     /* evaluate each expression */
  918.     for (val = NIL; moreargs(); )
  919.         val = xleval(nextarg());
  920.  
  921.     /* restore the previous environment and the stack */
  922.     xlunbind(olddenv);
  923.     xlpopn(2);
  924.  
  925.     /* return the last test expression value */
  926.     return (val);
  927. }
  928.  
  929. /* xloop - special form 'loop' */
  930. LVAL xloop()
  931. {
  932.     FRAMEP argv;
  933.     LVAL arg,val;
  934.     CONTEXT cntxt;
  935.     int argc;
  936.  
  937.     /* protect some pointers */
  938.     xlsave1(arg);
  939.  
  940.     /* establish a new execution context */
  941.     xlbegin(&cntxt,CF_RETURN,NIL);
  942.     if (setjmp(cntxt.c_jmpbuf))
  943.         val = xlvalue;
  944.     else
  945.         for (argv = xlargv, argc = xlargc; ; xlargv = argv, xlargc = argc)
  946.             while (moreargs()) {
  947.                 arg = nextarg();
  948.                 if (consp(arg))
  949.                     xleval(arg);
  950.             }
  951.     xlend(&cntxt);
  952.  
  953.     /* restore the stack */
  954.     xlpop();
  955.  
  956.     /* return the result */
  957.     return (val);
  958. }
  959.  
  960. /* doloop - common do routine */
  961. #ifdef ANSI
  962. static LVAL XNEAR doloop(int pflag)
  963. #else
  964. LOCAL LVAL XNEAR doloop(pflag)
  965.   int pflag;
  966. #endif
  967. {
  968.     FRAMEP argv;
  969.     LVAL newenv,blist,clist,test,val;
  970.     LVAL olddenv=xldenv;
  971.     CONTEXT cntxt;
  972.     int argc;
  973.  
  974.     /* protect some pointers */
  975.     xlsave1(newenv);
  976.  
  977.     /* get the list of bindings, the exit test and the result forms */
  978.     blist = xlgalist();
  979.     clist = xlgalist();
  980.     test = (consp(clist) ? car(clist) : NIL);
  981.     argv = xlargv;
  982.     argc = xlargc;
  983.  
  984.     /* create a new environment frame */
  985.     newenv = xlframe(xlenv);
  986.  
  987.     /* establish a new execution context */
  988.     xlbegin(&cntxt,CF_RETURN,NIL);
  989.     if (setjmp(cntxt.c_jmpbuf))
  990.         val = xlvalue;
  991.     else {
  992.  
  993.         /* bind the symbols */
  994.         if (pflag) {    /* bind "simultaneously" */
  995.             LVAL newdenv = xldenv;
  996.             dobindings(blist, newenv, &newdenv, FALSE);
  997.             xlenv = newenv;
  998.             xldenv = newdenv;
  999.         }
  1000.         else {          /* bind "sequentially") */
  1001.             xlenv = newenv;
  1002.             dobindings(blist, newenv, &xldenv, TRUE);
  1003.         }
  1004.  
  1005.         /* execute the loop as long as the test is false */
  1006.         for (val = NIL; null(xleval(test)); doupdates(blist,pflag)) {
  1007.             xlargv = argv;
  1008.             xlargc = argc;
  1009.             tagbody();
  1010.         }
  1011.  
  1012.         /* evaluate the result expression */
  1013.         if (consp(clist))
  1014.             for (clist = cdr(clist); consp(clist); clist = cdr(clist))
  1015.                 val = xleval(car(clist));
  1016.  
  1017.         /* unbind the arguments */
  1018.         xlenv = cdr(xlenv);
  1019.     }
  1020.     xlend(&cntxt);
  1021.  
  1022.     /* restore the stack */
  1023.     xlunbind(olddenv);
  1024.     xlpop();
  1025.  
  1026.     /* return the result */
  1027.     return (val);
  1028. }
  1029.  
  1030. /* xdo - special form 'do' */
  1031. LVAL xdo()
  1032. {
  1033.     return (doloop(TRUE));
  1034. }
  1035.  
  1036. /* xdostar - special form 'do*' */
  1037. LVAL xdostar()
  1038. {
  1039.     return (doloop(FALSE));
  1040. }
  1041.  
  1042. /* xdolist - special form 'dolist' */
  1043. LVAL xdolist()
  1044. {
  1045.     FRAMEP argv;
  1046.     LVAL list,clist,sym,val;
  1047.     LVAL olddenv=xldenv;
  1048.     CONTEXT cntxt;
  1049.     int argc;
  1050.  
  1051.     /* protect some pointers */
  1052.     xlsave1(list);
  1053.  
  1054.     /* get the control list (sym list result-expr) */
  1055.     clist = xlgalist();
  1056.     sym = match(SYMBOL,&clist);
  1057.     list = evmatch(LIST,&clist);
  1058.     argv = xlargv;
  1059.     argc = xlargc;
  1060.  
  1061.     /* initialize the local environment */
  1062.     xlenv = xlframe(xlenv);
  1063.     xlbind(sym,NIL);
  1064.  
  1065.     /* establish a new execution context */
  1066.     xlbegin(&cntxt,CF_RETURN,NIL);
  1067.     if (setjmp(cntxt.c_jmpbuf))
  1068.         val = xlvalue;
  1069.     else {
  1070.  
  1071.         /* loop through the list */
  1072.         for (val = NIL; consp(list); list = cdr(list)) {
  1073.  
  1074.             /* bind the symbol to the next list element */
  1075.             xlsetvalue(sym,car(list));
  1076.  
  1077.             /* execute the loop body */
  1078.             xlargv = argv;
  1079.             xlargc = argc;
  1080.             tagbody();
  1081.         }
  1082.  
  1083.         /* evaluate the result expression */
  1084.         xlsetvalue(sym,NIL);
  1085.         val = (consp(clist) ? xleval(car(clist)) : NIL);
  1086.  
  1087.     }
  1088.     /* unbind the arguments */  /* TAA mod -- moved out of above "else" */
  1089.     xlenv = cdr(xlenv);
  1090.  
  1091.     xlend(&cntxt);
  1092.  
  1093.     /* restore the stack */
  1094.     xlunbind(olddenv);
  1095.     xlpop();
  1096.  
  1097.     /* return the result */
  1098.     return (val);
  1099. }
  1100.  
  1101. /* xdotimes - special form 'dotimes' */
  1102. LVAL xdotimes()
  1103. {
  1104.     FRAMEP argv;
  1105.     LVAL clist,sym,cnt,val;
  1106.     LVAL olddenv=xldenv;
  1107.     CONTEXT cntxt;
  1108.     int argc;
  1109.     FIXTYPE n,i; /* TAA MOD (fix) */
  1110.  
  1111.     /* get the control list (sym list result-expr) */
  1112.     clist = xlgalist();
  1113.     sym = match(SYMBOL,&clist);
  1114.     cnt = evmatch(FIXNUM,&clist); n = getfixnum(cnt);
  1115.     argv = xlargv;
  1116.     argc = xlargc;
  1117.  
  1118.     /* initialize the local environment */
  1119.     xlenv = xlframe(xlenv);
  1120.     xlbind(sym,NIL);
  1121.  
  1122.     /* establish a new execution context */
  1123.     xlbegin(&cntxt,CF_RETURN,NIL);
  1124.     if (setjmp(cntxt.c_jmpbuf))
  1125.         val = xlvalue;
  1126.     else {
  1127.  
  1128.         /* loop through for each value from zero to n-1 */
  1129.         for (val = NIL, i = 0; i < n; ++i) {
  1130.  
  1131.             /* bind the symbol to the next list element */
  1132.             xlsetvalue(sym,cvfixnum((FIXTYPE)i));
  1133.  
  1134.             /* execute the loop body */
  1135.             xlargv = argv;
  1136.             xlargc = argc;
  1137.             tagbody();
  1138.         }
  1139.  
  1140.         /* evaluate the result expression */
  1141.         xlsetvalue(sym,cnt);
  1142.         val = (consp(clist) ? xleval(car(clist)) : NIL);
  1143.  
  1144.     }
  1145.  
  1146.     /* unbind the arguments */  /* TAA mod -- moved out of above "else" */
  1147.     xlenv = cdr(xlenv);
  1148.  
  1149.     xlend(&cntxt);
  1150.  
  1151.     /* unbind dynamic arguments */
  1152.     xlunbind(olddenv);
  1153.  
  1154.     /* return the result */
  1155.     return (val);
  1156. }
  1157.  
  1158. /* xblock - special form 'block' */
  1159. LVAL xblock()
  1160. {
  1161.     LVAL name,val;
  1162.     CONTEXT cntxt;
  1163.  
  1164.     /* get the block name */
  1165.     name = xlgetarg();
  1166.     if (!null(name) && !symbolp(name))
  1167.         xlbadtype(name);
  1168.  
  1169.     /* execute the block */
  1170.     xlbegin(&cntxt,CF_RETURN,name);
  1171.     if (setjmp(cntxt.c_jmpbuf))
  1172.         val = xlvalue;
  1173.     else
  1174.         for (val = NIL; moreargs(); )
  1175.             val = xleval(nextarg());
  1176.     xlend(&cntxt);
  1177.  
  1178.     /* return the value of the last expression */
  1179.     return (val);
  1180. }
  1181.  
  1182. /* xtagbody - special form 'tagbody' */
  1183. LVAL xtagbody()
  1184. {
  1185.     tagbody();
  1186.     return (NIL);
  1187. }
  1188.  
  1189. /* xcatch - special form 'catch' */
  1190. LVAL xcatch()
  1191. {
  1192.     CONTEXT cntxt;
  1193.     LVAL tag,val;
  1194.  
  1195.     /* protect some pointers */
  1196.     xlsave1(tag);
  1197.  
  1198.     /* get the tag */
  1199.     tag = xleval(nextarg());
  1200.  
  1201.     /* establish an execution context */
  1202.     xlbegin(&cntxt,CF_THROW,tag);
  1203.  
  1204.     /* check for 'throw' */
  1205.     if (setjmp(cntxt.c_jmpbuf))
  1206.         val = xlvalue;
  1207.  
  1208.     /* otherwise, evaluate the remainder of the arguments */
  1209.     else {
  1210.         for (val = NIL; moreargs(); )
  1211.             val = xleval(nextarg());
  1212.     }
  1213.     xlend(&cntxt);
  1214.  
  1215.     /* restore the stack */
  1216.     xlpop();
  1217.  
  1218.     /* return the result */
  1219.     return (val);
  1220. }
  1221.  
  1222. /* xthrow - special form 'throw' */
  1223. LVAL xthrow()
  1224. {
  1225.     LVAL tag,val;
  1226.  
  1227.     /* get the tag and value */
  1228.     tag = xleval(nextarg());
  1229.     val = (moreargs() ? xleval(nextarg()) : NIL);
  1230.     xllastarg();
  1231.  
  1232.     /* throw the tag */
  1233.     xlthrow(tag,val);
  1234.     return (NIL);
  1235. }
  1236.  
  1237. /* xunwindprotect - special form 'unwind-protect' */
  1238. LVAL xunwindprotect()
  1239. {
  1240.     extern CONTEXT *xltarget;
  1241.     extern int xlmask;
  1242.     CONTEXT cntxt,*target;
  1243.     int mask,sts;
  1244.     LVAL val;
  1245.  
  1246.     /* protect some pointers */
  1247.     xlsave1(val);
  1248.  
  1249.     /* get the expression to protect */
  1250.     val = xlgetarg();
  1251.  
  1252.     /* evaluate the protected expression */
  1253.     xlbegin(&cntxt,CF_UNWIND,NIL);
  1254.     if ((sts = setjmp(cntxt.c_jmpbuf)) != 0) {
  1255.         target = xltarget;
  1256.         mask = xlmask;
  1257.         val = xlvalue;
  1258.     }
  1259.     else
  1260.         val = xleval(val);
  1261.     xlend(&cntxt);
  1262.  
  1263.     /* evaluate the cleanup expressions */
  1264.     while (moreargs())
  1265.         xleval(nextarg());
  1266.  
  1267.     /* if unwinding, continue unwinding */
  1268.     if (sts)
  1269.         xljump(target,mask,val);
  1270.  
  1271.     /* restore the stack */
  1272.     xlpop();
  1273.  
  1274.     /* return the value of the protected expression */
  1275.     return (val);
  1276. }
  1277.  
  1278. /* xerrset - special form 'errset' */
  1279. LVAL xerrset()
  1280. {
  1281.     LVAL expr,flag,val;
  1282.     CONTEXT cntxt;
  1283.  
  1284.     /* get the expression and the print flag */
  1285.     expr = xlgetarg();
  1286.     flag = (moreargs() ? xlgetarg() : true);
  1287.     xllastarg();
  1288.  
  1289.     /* establish an execution context */
  1290.     xlbegin(&cntxt,CF_ERROR,flag);
  1291.  
  1292.     /* check for error */
  1293.     if (setjmp(cntxt.c_jmpbuf))
  1294.         val = NIL;
  1295.  
  1296.     /* otherwise, evaluate the expression */
  1297.     else {
  1298.         expr = xleval(expr);
  1299.         val = consa(expr);
  1300.     }
  1301.     xlend(&cntxt);
  1302.  
  1303.     /* return the result */
  1304.     return (val);
  1305. }
  1306.  
  1307. /* xtrace - special form 'trace' */
  1308. LVAL xtrace()
  1309. {
  1310. /* TAA MOD -- changed to use s_tracelist rather than looking it up */
  1311.     LVAL fun,this;
  1312.  
  1313.     /* loop through all of the arguments */
  1314.     while (moreargs()) {
  1315.         fun = xlgasymbol();
  1316.  
  1317.         /* check for the function name already being in the list */
  1318.         for (this = getvalue(s_tracelist); consp(this); this = cdr(this))
  1319.             if (car(this) == fun)
  1320.                 break;
  1321.  
  1322.         /* add the function name to the list */
  1323.         if (null(this))
  1324.             setvalue(s_tracelist,cons(fun,getvalue(s_tracelist)));
  1325.     }
  1326.     return (getvalue(s_tracelist));
  1327. }
  1328.  
  1329. /* xuntrace - special form 'untrace' */
  1330. LVAL xuntrace()
  1331. {
  1332. /* TAA MOD -- changed to use s_tracelist rather than looking it up */
  1333.     LVAL fun,this,last;
  1334.  
  1335.     /* loop through all of the arguments */
  1336.  
  1337.     if (!moreargs()) {  /* list empty -- then untrace all functions */
  1338.         setvalue(s_tracelist,NIL);
  1339.         return (NIL);
  1340.     }
  1341.     while (moreargs()) {
  1342.         fun = xlgasymbol();
  1343.  
  1344.         /* remove the function name from the list */
  1345.         last = NIL;
  1346.         for (this = getvalue(s_tracelist); consp(this); this = cdr(this)) {
  1347.             if (car(this) == fun) {
  1348.                 if (!null(last))
  1349.                     rplacd(last,cdr(this));
  1350.                 else
  1351.                     setvalue(s_tracelist,cdr(this));
  1352.                 break;
  1353.             }
  1354.             last = this;
  1355.         }
  1356.     }
  1357.     return (getvalue(s_tracelist));
  1358. }
  1359.  
  1360. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  1361.  
  1362. LOCAL VOID XNEAR dobindings(list,env,denv,seq)
  1363.   LVAL list,env,*denv;
  1364.   int seq;
  1365. {
  1366.     LVAL bnd,sym,val;
  1367.     LVAL plist;
  1368.  
  1369.     /* protect some pointers */
  1370.     xlstkcheck(2);
  1371.     xlsave(val);
  1372.     xlsave(plist);
  1373.  
  1374.     /* bind each symbol in the list of bindings */
  1375.     for (; consp(list); list = cdr(list)) {
  1376.  
  1377.         /* get the next binding */
  1378.         bnd = car(list);
  1379.  
  1380.         /* handle a symbol */
  1381.         if (symbolp(bnd)) {
  1382.             sym = bnd;
  1383.             val = NIL;
  1384.         }
  1385.  
  1386.         /* handle a list of the form (symbol expr) */
  1387.         else if (consp(bnd)) {
  1388.             sym = match(SYMBOL,&bnd);
  1389.             val = evarg(&bnd);
  1390.         }
  1391.         else
  1392.             xlfail("bad binding");
  1393.  
  1394.         /* bind the value to the symbol */
  1395.         if (constantp(sym)) xlnoassign(sym);
  1396.         if (specialp(sym)) { /* For parallel binding, defer binding of
  1397.                                 specials until end, by creating temporary
  1398.                                 binding list */
  1399.             if (seq) {
  1400.                 xlpdbind(sym, val, *denv);
  1401.             }
  1402.             else {
  1403.                 plist = cons(cons(sym,val), plist);
  1404.             }
  1405.         }
  1406.         else {xlpbind(sym,val,env);}
  1407.     }
  1408.  
  1409.     /* now do the binding of the specials, since all vals have been
  1410.         evaluated. */
  1411.     while (!null(plist)) {
  1412.         bnd = car(plist);
  1413.         xlpdbind(car(bnd),cdr(bnd),*denv);
  1414.         plist = cdr(plist);
  1415.     }
  1416.  
  1417.     /* restore the stack */
  1418.     xlpopn(2);
  1419.  
  1420. }
  1421.  
  1422. /* doupdates - handle updates for do/do* */
  1423. LOCAL VOID XNEAR doupdates(list,pflag)
  1424.   LVAL list; int pflag;
  1425. {
  1426.     LVAL plist,bnd,sym,val;
  1427.  
  1428.     /* protect some pointers */
  1429.     xlstkcheck(2);
  1430.     xlsave(plist);
  1431.     xlsave(val);
  1432.  
  1433.     /* bind each symbol in the list of bindings */
  1434.     for (; consp(list); list = cdr(list)) {
  1435.  
  1436.         /* get the next binding */
  1437.         bnd = car(list);
  1438.  
  1439.         /* handle a list of the form (symbol expr) */
  1440.         if (consp(bnd)) {
  1441.             sym = match(SYMBOL,&bnd);
  1442.             bnd = cdr(bnd);
  1443.             if (!null(bnd)) {
  1444.                 val = evarg(&bnd);
  1445.                 if (pflag)
  1446.                     plist = cons(cons(sym,val),plist);
  1447.                 else
  1448.                     xlsetvalue(sym,val);
  1449.             }
  1450.         }
  1451.     }
  1452.  
  1453.     /* set the values for parallel updates */
  1454.     for (; !null(plist); plist = cdr(plist)) {  /* TAA MOD for efficiency */
  1455.         bnd = car(plist);
  1456.         xlsetvalue(car(bnd),cdr(bnd));
  1457.     }
  1458.  
  1459.     /* restore the stack */
  1460.     xlpopn(2);
  1461. }
  1462.  
  1463. /* tagbody - execute code within a block and tagbody */
  1464. LOCAL VOID XNEAR tagbody()
  1465. {
  1466.     FRAMEP argv;
  1467.     LVAL arg;
  1468.     CONTEXT cntxt;
  1469.     int argc;
  1470.  
  1471.     /* establish an execution context */
  1472.     xlbegin(&cntxt,CF_GO,NIL);
  1473.     argc = xlargc;
  1474.     argv = xlargv;
  1475.  
  1476.     /* check for a 'go' */
  1477.     if (setjmp(cntxt.c_jmpbuf)) {
  1478.         cntxt.c_xlargc = argc;
  1479.         cntxt.c_xlargv = argv;
  1480.     }
  1481.  
  1482.     /* execute the body */
  1483.     while (moreargs()) {
  1484.         arg = nextarg();
  1485.         if (consp(arg))
  1486.             xleval(arg);
  1487.     }
  1488.     xlend(&cntxt);
  1489. }
  1490.  
  1491.  
  1492. /* match - get an argument and match its type */
  1493. LOCAL LVAL XNEAR match(type,pargs)
  1494.   int type; LVAL *pargs;
  1495. {
  1496.     LVAL arg;
  1497.  
  1498.     /* make sure the argument exists */
  1499.     if (!consp(*pargs))
  1500.         toofew(*pargs);
  1501.  
  1502.     /* get the argument value */
  1503.     arg = car(*pargs);
  1504.  
  1505.     /* move the argument pointer ahead */
  1506.     *pargs = cdr(*pargs);
  1507.  
  1508.     /* check its type */
  1509.     if (type == LIST) {
  1510.         if (!null(arg) && ntype(arg) != CONS)
  1511.             xlbadtype(arg);
  1512.     }
  1513.     else {
  1514.         if (null(arg) || ntype(arg) != type)
  1515.             xlbadtype(arg);
  1516.     }
  1517.  
  1518.     /* return the argument */
  1519.     return (arg);
  1520. }
  1521.  
  1522. /* evarg - get the next argument and evaluate it */
  1523. LOCAL LVAL XNEAR evarg(pargs)
  1524.   LVAL *pargs;
  1525. {
  1526.     LVAL arg;
  1527.  
  1528.     /* protect some pointers */
  1529.     xlsave1(arg);
  1530.  
  1531.     /* make sure the argument exists */
  1532.     if (!consp(*pargs))
  1533.         toofew(*pargs);
  1534.  
  1535.     /* get the argument value */
  1536.     arg = car(*pargs);
  1537.  
  1538.     /* move the argument pointer ahead */
  1539.     *pargs = cdr(*pargs);
  1540.  
  1541.     /* evaluate the argument */
  1542.     arg = xleval(arg);
  1543.  
  1544.     /* restore the stack */
  1545.     xlpop();
  1546.  
  1547.     /* return the argument */
  1548.     return (arg);
  1549. }
  1550.  
  1551. /* evmatch - get an evaluated argument and match its type */
  1552. LOCAL LVAL XNEAR evmatch(type,pargs)
  1553.   int type; LVAL *pargs;
  1554. {
  1555.     LVAL arg;
  1556.  
  1557.     /* protect some pointers */
  1558.     xlsave1(arg);
  1559.  
  1560.     /* make sure the argument exists */
  1561.     if (!consp(*pargs))
  1562.         toofew(*pargs);
  1563.  
  1564.     /* get the argument value */
  1565.     arg = car(*pargs);
  1566.  
  1567.     /* move the argument pointer ahead */
  1568.     *pargs = cdr(*pargs);
  1569.  
  1570.     /* evaluate the argument */
  1571.     arg = xleval(arg);
  1572.  
  1573.     /* check its type */
  1574.     if (type == LIST) {
  1575.         if (!null(arg) && ntype(arg) != CONS)
  1576.             xlbadtype(arg);
  1577.     }
  1578.     else {
  1579.         if (null(arg) || ntype(arg) != type)
  1580.             xlbadtype(arg);
  1581.     }
  1582.  
  1583.     /* restore the stack */
  1584.     xlpop();
  1585.  
  1586.     /* return the argument */
  1587.     return (arg);
  1588. }
  1589.  
  1590.