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