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