home *** CD-ROM | disk | FTP | other *** search
/ The C Users' Group Library 1994 August / wc-cdrom-cusersgrouplibrary-1994-08.iso / vol_100 / 176_01 / xlcont.c < prev    next >
Text File  |  1985-12-27  |  19KB  |  878 lines
  1. /* xlcont - xlisp control built-in functions */
  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 NODE ***xlstack,*xlenv,*xlvalue;
  10. extern NODE *s_unbound;
  11. extern NODE *s_evalhook,*s_applyhook;
  12. extern NODE *true;
  13.  
  14. /* external routines */
  15. extern NODE *xlxeval();
  16.  
  17. /* forward declarations */
  18. FORWARD NODE *let();
  19. FORWARD NODE *prog();
  20. FORWARD NODE *progx();
  21. FORWARD NODE *doloop();
  22.  
  23. /* xcond - built-in function 'cond' */
  24. NODE *xcond(args)
  25.   NODE *args;
  26. {
  27.     NODE ***oldstk,*arg,*list,*val;
  28.  
  29.     /* create a new stack frame */
  30.     oldstk = xlsave(&arg,&list,NULL);
  31.  
  32.     /* initialize */
  33.     arg = args;
  34.  
  35.     /* initialize the return value */
  36.     val = NIL;
  37.  
  38.     /* find a predicate that is true */
  39.     while (arg) {
  40.  
  41.     /* get the next conditional */
  42.     list = xlmatch(LIST,&arg);
  43.  
  44.     /* evaluate the predicate part */
  45.     if (val = xlevarg(&list)) {
  46.  
  47.         /* evaluate each expression */
  48.         while (list)
  49.         val = xlevarg(&list);
  50.  
  51.         /* exit the loop */
  52.         break;
  53.     }
  54.     }
  55.  
  56.     /* restore the previous stack frame */
  57.     xlstack = oldstk;
  58.  
  59.     /* return the value */
  60.     return (val);
  61. }
  62.  
  63. /* xcase - built-in function 'case' */
  64. NODE *xcase(args)
  65.   NODE *args;
  66. {
  67.     NODE ***oldstk,*key,*arg,*clause,*list,*val;
  68.  
  69.     /* create a new stack frame */
  70.     oldstk = xlsave(&key,&arg,&clause,NULL);
  71.  
  72.     /* initialize */
  73.     arg = args;
  74.  
  75.     /* get the key expression */
  76.     key = xlevarg(&arg);
  77.  
  78.     /* initialize the return value */
  79.     val = NIL;
  80.  
  81.     /* find a case that matches */
  82.     while (arg) {
  83.  
  84.     /* get the next case clause */
  85.     clause = xlmatch(LIST,&arg);
  86.  
  87.     /* compare the key list against the key */
  88.     if ((list = xlarg(&clause)) == true ||
  89.             (listp(list) && keypresent(key,list)) ||
  90.             eql(key,list)) {
  91.  
  92.         /* evaluate each expression */
  93.         while (clause)
  94.         val = xlevarg(&clause);
  95.  
  96.         /* exit the loop */
  97.         break;
  98.     }
  99.     }
  100.  
  101.     /* restore the previous stack frame */
  102.     xlstack = oldstk;
  103.  
  104.     /* return the value */
  105.     return (val);
  106. }
  107.  
  108. /* keypresent - check for the presence of a key in a list */
  109. LOCAL int keypresent(key,list)
  110.   NODE *key,*list;
  111. {
  112.     for (; consp(list); list = cdr(list))
  113.     if (eql(car(list),key))
  114.         return (TRUE);
  115.     return (FALSE);
  116. }
  117.  
  118. /* xand - built-in function 'and' */
  119. NODE *xand(args)
  120.   NODE *args;
  121. {
  122.     NODE ***oldstk,*arg,*val;
  123.  
  124.     /* create a new stack frame */
  125.     oldstk = xlsave(&arg,NULL);
  126.  
  127.     /* initialize */
  128.     arg = args;
  129.     val = true;
  130.  
  131.     /* evaluate each argument */
  132.     while (arg)
  133.  
  134.     /* get the next argument */
  135.     if ((val = xlevarg(&arg)) == NIL)
  136.         break;
  137.  
  138.     /* restore the previous stack frame */
  139.     xlstack = oldstk;
  140.  
  141.     /* return the result value */
  142.     return (val);
  143. }
  144.  
  145. /* xor - built-in function 'or' */
  146. NODE *xor(args)
  147.   NODE *args;
  148. {
  149.     NODE ***oldstk,*arg,*val;
  150.  
  151.     /* create a new stack frame */
  152.     oldstk = xlsave(&arg,NULL);
  153.  
  154.     /* initialize */
  155.     arg = args;
  156.     val = NIL;
  157.  
  158.     /* evaluate each argument */
  159.     while (arg)
  160.     if ((val = xlevarg(&arg)))
  161.         break;
  162.  
  163.     /* restore the previous stack frame */
  164.     xlstack = oldstk;
  165.  
  166.     /* return the result value */
  167.     return (val);
  168. }
  169.  
  170. /* xif - built-in function 'if' */
  171. NODE *xif(args)
  172.   NODE *args;
  173. {
  174.     NODE ***oldstk,*testexpr,*thenexpr,*elseexpr,*val;
  175.  
  176.     /* create a new stack frame */
  177.     oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
  178.  
  179.     /* get the test expression, then clause and else clause */
  180.     testexpr = xlarg(&args);
  181.     thenexpr = xlarg(&args);
  182.     elseexpr = (args ? xlarg(&args) : NIL);
  183.     xllastarg(args);
  184.  
  185.     /* evaluate the appropriate clause */
  186.     val = xleval(xleval(testexpr) ? thenexpr : elseexpr);
  187.  
  188.     /* restore the previous stack frame */
  189.     xlstack = oldstk;
  190.  
  191.     /* return the last value */
  192.     return (val);
  193. }
  194.  
  195. /* xlet - built-in function 'let' */
  196. NODE *xlet(args)
  197.   NODE *args;
  198. {
  199.     return (let(args,TRUE));
  200. }
  201.  
  202. /* xletstar - built-in function 'let*' */
  203. NODE *xletstar(args)
  204.   NODE *args;
  205. {
  206.     return (let(args,FALSE));
  207. }
  208.  
  209. /* let - common let routine */
  210. LOCAL NODE *let(args,pflag)
  211.   NODE *args; int pflag;
  212. {
  213.     NODE ***oldstk,*newenv,*arg,*val;
  214.  
  215.     /* create a new stack frame */
  216.     oldstk = xlsave(&newenv,&arg,NULL);
  217.  
  218.     /* initialize */
  219.     arg = args;
  220.  
  221.     /* create a new environment frame */
  222.     newenv = xlframe(xlenv);
  223.  
  224.     /* get the list of bindings and bind the symbols */
  225.     if (!pflag) xlenv = newenv;
  226.     dobindings(xlmatch(LIST,&arg),newenv);
  227.     if (pflag) xlenv = newenv;
  228.  
  229.     /* execute the code */
  230.     for (val = NIL; arg; )
  231.     val = xlevarg(&arg);
  232.  
  233.     /* unbind the arguments */
  234.     xlenv = cdr(xlenv);
  235.  
  236.     /* restore the previous stack frame */
  237.     xlstack = oldstk;
  238.  
  239.     /* return the result */
  240.     return (val);
  241. }
  242.  
  243. /* xprog - built-in function 'prog' */
  244. NODE *xprog(args)
  245.   NODE *args;
  246. {
  247.     return (prog(args,TRUE));
  248. }
  249.  
  250. /* xprogstar - built-in function 'prog*' */
  251. NODE *xprogstar(args)
  252.   NODE *args;
  253. {
  254.     return (prog(args,FALSE));
  255. }
  256.  
  257. /* prog - common prog routine */
  258. LOCAL NODE *prog(args,pflag)
  259.   NODE *args; int pflag;
  260. {
  261.     NODE ***oldstk,*newenv,*arg,*val;
  262.  
  263.     /* create a new stack frame */
  264.     oldstk = xlsave(&newenv,&arg,NULL);
  265.  
  266.     /* initialize */
  267.     arg = args;
  268.  
  269.     /* create a new environment frame */
  270.     newenv = xlframe(xlenv);
  271.  
  272.     /* get the list of bindings and bind the symbols */
  273.     if (!pflag) xlenv = newenv;
  274.     dobindings(xlmatch(LIST,&arg),newenv);
  275.     if (pflag) xlenv = newenv;
  276.  
  277.     /* execute the code */
  278.     tagblock(arg,&val);
  279.  
  280.     /* unbind the arguments */
  281.     xlenv = cdr(xlenv);
  282.  
  283.     /* restore the previous stack frame */
  284.     xlstack = oldstk;
  285.  
  286.     /* return the result */
  287.     return (val);
  288. }
  289.  
  290. /* xgo - built-in function 'go' */
  291. NODE *xgo(args)
  292.   NODE *args;
  293. {
  294.     NODE *label;
  295.  
  296.     /* get the target label */
  297.     label = xlarg(&args);
  298.     xllastarg(args);
  299.  
  300.     /* transfer to the label */
  301.     xlgo(label);
  302. }
  303.  
  304. /* xreturn - built-in function 'return' */
  305. NODE *xreturn(args)
  306.   NODE *args;
  307. {
  308.     NODE *val;
  309.  
  310.     /* get the return value */
  311.     val = (args ? xlarg(&args) : NIL);
  312.     xllastarg(args);
  313.  
  314.     /* return from the inner most block */
  315.     xlreturn(val);
  316. }
  317.  
  318. /* xprog1 - built-in function 'prog1' */
  319. NODE *xprog1(args)
  320.   NODE *args;
  321. {
  322.     return (progx(args,1));
  323. }
  324.  
  325. /* xprog2 - built-in function 'prog2' */
  326. NODE *xprog2(args)
  327.   NODE *args;
  328. {
  329.     return (progx(args,2));
  330. }
  331.  
  332. /* progx - common progx code */
  333. LOCAL NODE *progx(args,n)
  334.   NODE *args; int n;
  335. {
  336.     NODE ***oldstk,*arg,*val;
  337.  
  338.     /* create a new stack frame */
  339.     oldstk = xlsave(&arg,&val,NULL);
  340.  
  341.     /* initialize */
  342.     arg = args;
  343.  
  344.     /* evaluate the first n expressions */
  345.     while (n--)
  346.     val = xlevarg(&arg);
  347.  
  348.     /* evaluate each remaining argument */
  349.     while (arg)
  350.     xlevarg(&arg);
  351.  
  352.     /* restore the previous stack frame */
  353.     xlstack = oldstk;
  354.  
  355.     /* return the last test expression value */
  356.     return (val);
  357. }
  358.  
  359. /* xprogn - built-in function 'progn' */
  360. NODE *xprogn(args)
  361.   NODE *args;
  362. {
  363.     NODE ***oldstk,*arg,*val;
  364.  
  365.     /* create a new stack frame */
  366.     oldstk = xlsave(&arg,NULL);
  367.  
  368.     /* initialize */
  369.     arg = args;
  370.  
  371.     /* evaluate each remaining argument */
  372.     for (val = NIL; arg; )
  373.     val = xlevarg(&arg);
  374.  
  375.     /* restore the previous stack frame */
  376.     xlstack = oldstk;
  377.  
  378.     /* return the last test expression value */
  379.     return (val);
  380. }
  381.  
  382. /* xdo - built-in function 'do' */
  383. NODE *xdo(args)
  384.   NODE *args;
  385. {
  386.     return (doloop(args,TRUE));
  387. }
  388.  
  389. /* xdostar - built-in function 'do*' */
  390. NODE *xdostar(args)
  391.   NODE *args;
  392. {
  393.     return (doloop(args,FALSE));
  394. }
  395.  
  396. /* doloop - common do routine */
  397. LOCAL NODE *doloop(args,pflag)
  398.   NODE *args; int pflag;
  399. {
  400.     NODE ***oldstk,*newenv,*arg,*blist,*clist,*test,*rval;
  401.     int rbreak;
  402.  
  403.     /* create a new stack frame */
  404.     oldstk = xlsave(&newenv,&arg,&blist,&clist,&test,NULL);
  405.  
  406.     /* initialize */
  407.     arg = args;
  408.  
  409.     /* get the list of bindings */
  410.     blist = xlmatch(LIST,&arg);
  411.  
  412.     /* create a new environment frame */
  413.     newenv = xlframe(xlenv);
  414.  
  415.     /* bind the symbols */
  416.     if (!pflag) xlenv = newenv;
  417.     dobindings(blist,newenv);
  418.     if (pflag) xlenv = newenv;
  419.  
  420.     /* get the exit test and result forms */
  421.     clist = xlmatch(LIST,&arg);
  422.     test = xlarg(&clist);
  423.  
  424.     /* execute the loop as long as the test is false */
  425.     rbreak = FALSE;
  426.     while (xleval(test) == NIL) {
  427.  
  428.     /* execute the body of the loop */
  429.     if (tagblock(arg,&rval)) {
  430.         rbreak = TRUE;
  431.         break;
  432.     }
  433.  
  434.     /* update the looping variables */
  435.     doupdates(blist,pflag);
  436.     }
  437.  
  438.     /* evaluate the result expression */
  439.     if (!rbreak)
  440.     for (rval = NIL; consp(clist); )
  441.         rval = xlevarg(&clist);
  442.  
  443.     /* unbind the arguments */
  444.     xlenv = cdr(xlenv);
  445.  
  446.     /* restore the previous stack frame */
  447.     xlstack = oldstk;
  448.  
  449.     /* return the result */
  450.     return (rval);
  451. }
  452.  
  453. /* xdolist - built-in function 'dolist' */
  454. NODE *xdolist(args)
  455.   NODE *args;
  456. {
  457.     NODE ***oldstk,*arg,*clist,*sym,*list,*val,*rval;
  458.     int rbreak;
  459.  
  460.     /* create a new stack frame */
  461.     oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
  462.  
  463.     /* initialize */
  464.     arg = args;
  465.  
  466.     /* get the control list (sym list result-expr) */
  467.     clist = xlmatch(LIST,&arg);
  468.     sym = xlmatch(SYM,&clist);
  469.     list = xlevmatch(LIST,&clist);
  470.     val = (clist ? xlarg(&clist) : NIL);
  471.  
  472.     /* initialize the local environment */
  473.     xlenv = xlframe(xlenv);
  474.     xlbind(sym,NIL,xlenv);
  475.  
  476.     /* loop through the list */
  477.     rbreak = FALSE;
  478.     for (; consp(list); list = cdr(list)) {
  479.  
  480.     /* bind the symbol to the next list element */
  481.     xlsetvalue(sym,car(list));
  482.  
  483.     /* execute the loop body */
  484.     if (tagblock(arg,&rval)) {
  485.         rbreak = TRUE;
  486.         break;
  487.     }
  488.     }
  489.  
  490.     /* evaluate the result expression */
  491.     if (!rbreak) {
  492.     xlsetvalue(sym,NIL);
  493.     rval = xleval(val);
  494.     }
  495.  
  496.     /* unbind the arguments */
  497.     xlenv = cdr(xlenv);
  498.  
  499.     /* restore the previous stack frame */
  500.     xlstack = oldstk;
  501.  
  502.     /* return the result */
  503.     return (rval);
  504. }
  505.  
  506. /* xdotimes - built-in function 'dotimes' */
  507. NODE *xdotimes(args)
  508.   NODE *args;
  509. {
  510.     NODE ***oldstk,*arg,*clist,*sym,*val,*rval;
  511.     int rbreak,cnt,i;
  512.  
  513.     /* create a new stack frame */
  514.     oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
  515.  
  516.     /* initialize */
  517.     arg = args;
  518.  
  519.     /* get the control list (sym list result-expr) */
  520.     clist = xlmatch(LIST,&arg);
  521.     sym = xlmatch(SYM,&clist);
  522.     cnt = getfixnum(xlevmatch(INT,&clist));
  523.     val = (clist ? xlarg(&clist) : NIL);
  524.  
  525.     /* initialize the local environment */
  526.     xlenv = xlframe(xlenv);
  527.     xlbind(sym,NIL,xlenv);
  528.  
  529.     /* loop through for each value from zero to cnt-1 */
  530.     rbreak = FALSE;
  531.     for (i = 0; i < cnt; i++) {
  532.  
  533.     /* bind the symbol to the next list element */
  534.     xlsetvalue(sym,cvfixnum((FIXNUM)i));
  535.  
  536.     /* execute the loop body */
  537.     if (tagblock(arg,&rval)) {
  538.         rbreak = TRUE;
  539.         break;
  540.     }
  541.     }
  542.  
  543.     /* evaluate the result expression */
  544.     if (!rbreak) {
  545.     xlsetvalue(sym,cvfixnum((FIXNUM)cnt));
  546.     rval = xleval(val);
  547.     }
  548.  
  549.     /* unbind the arguments */
  550.     xlenv = cdr(xlenv);
  551.  
  552.     /* restore the previous stack frame */
  553.     xlstack = oldstk;
  554.  
  555.     /* return the result */
  556.     return (rval);
  557. }
  558.  
  559. /* xcatch - built-in function 'catch' */
  560. NODE *xcatch(args)
  561.   NODE *args;
  562. {
  563.     NODE ***oldstk,*tag,*arg,*val;
  564.     CONTEXT cntxt;
  565.  
  566.     /* create a new stack frame */
  567.     oldstk = xlsave(&tag,&arg,NULL);
  568.  
  569.     /* initialize */
  570.     tag = xlevarg(&args);
  571.     arg = args;
  572.     val = NIL;
  573.  
  574.     /* establish an execution context */
  575.     xlbegin(&cntxt,CF_THROW,tag);
  576.  
  577.     /* check for 'throw' */
  578.     if (setjmp(cntxt.c_jmpbuf))
  579.     val = xlvalue;
  580.  
  581.     /* otherwise, evaluate the remainder of the arguments */
  582.     else {
  583.     while (arg)
  584.         val = xlevarg(&arg);
  585.     }
  586.     xlend(&cntxt);
  587.  
  588.     /* restore the previous stack frame */
  589.     xlstack = oldstk;
  590.  
  591.     /* return the result */
  592.     return (val);
  593. }
  594.  
  595. /* xthrow - built-in function 'throw' */
  596. NODE *xthrow(args)
  597.   NODE *args;
  598. {
  599.     NODE *tag,*val;
  600.  
  601.     /* get the tag and value */
  602.     tag = xlarg(&args);
  603.     val = (args ? xlarg(&args) : NIL);
  604.     xllastarg(args);
  605.  
  606.     /* throw the tag */
  607.     xlthrow(tag,val);
  608. }
  609.  
  610. /* xerror - built-in function 'error' */
  611. NODE *xerror(args)
  612.   NODE *args;
  613. {
  614.     char *emsg; NODE *arg;
  615.  
  616.     /* get the error message and the argument */
  617.     emsg = getstring(xlmatch(STR,&args));
  618.     arg = (args ? xlarg(&args) : s_unbound);
  619.     xllastarg(args);
  620.  
  621.     /* signal the error */
  622.     xlerror(emsg,arg);
  623. }
  624.  
  625. /* xcerror - built-in function 'cerror' */
  626. NODE *xcerror(args)
  627.   NODE *args;
  628. {
  629.     char *cmsg,*emsg; NODE *arg;
  630.  
  631.     /* get the correction message, the error message, and the argument */
  632.     cmsg = getstring(xlmatch(STR,&args));
  633.     emsg = getstring(xlmatch(STR,&args));
  634.     arg = (args ? xlarg(&args) : s_unbound);
  635.     xllastarg(args);
  636.  
  637.     /* signal the error */
  638.     xlcerror(cmsg,emsg,arg);
  639.  
  640.     /* return nil */
  641.     return (NIL);
  642. }
  643.  
  644. /* xbreak - built-in function 'break' */
  645. NODE *xbreak(args)
  646.   NODE *args;
  647. {
  648.     char *emsg; NODE *arg;
  649.  
  650.     /* get the error message */
  651.     emsg = (args ? getstring(xlmatch(STR,&args)) : "**BREAK**");
  652.     arg = (args ? xlarg(&args) : s_unbound);
  653.     xllastarg(args);
  654.  
  655.     /* enter the break loop */
  656.     xlbreak(emsg,arg);
  657.  
  658.     /* return nil */
  659.     return (NIL);
  660. }
  661.  
  662. /* xcleanup - built-in function 'clean-up' */
  663. NODE *xcleanup(args)
  664.   NODE *args;
  665. {
  666.     xllastarg(args);
  667.     xlcleanup();
  668. }
  669.  
  670. /* xcontinue - built-in function 'continue' */
  671. NODE *xcontinue(args)
  672.   NODE *args;
  673. {
  674.     xllastarg(args);
  675.     xlcontinue();
  676. }
  677.  
  678. /* xerrset - built-in function 'errset' */
  679. NODE *xerrset(args)
  680.   NODE *args;
  681. {
  682.     NODE ***oldstk,*expr,*flag,*val;
  683.     CONTEXT cntxt;
  684.  
  685.     /* create a new stack frame */
  686.     oldstk = xlsave(&expr,&flag,NULL);
  687.  
  688.     /* get the expression and the print flag */
  689.     expr = xlarg(&args);
  690.     flag = (args ? xlarg(&args) : true);
  691.     xllastarg(args);
  692.  
  693.     /* establish an execution context */
  694.     xlbegin(&cntxt,CF_ERROR,flag);
  695.  
  696.     /* check for error */
  697.     if (setjmp(cntxt.c_jmpbuf))
  698.     val = NIL;
  699.  
  700.     /* otherwise, evaluate the expression */
  701.     else {
  702.     expr = xleval(expr);
  703.     val = consa(expr);
  704.     }
  705.     xlend(&cntxt);
  706.  
  707.     /* restore the previous stack frame */
  708.     xlstack = oldstk;
  709.  
  710.     /* return the result */
  711.     return (val);
  712. }
  713.  
  714. /* xevalhook - eval hook function */
  715. NODE *xevalhook(args)
  716.   NODE *args;
  717. {
  718.     NODE ***oldstk,*expr,*ehook,*ahook,*env,*newehook,*newahook,*newenv,*val;
  719.  
  720.     /* create a new stack frame */
  721.     oldstk = xlsave(&expr,&ehook,&ahook,&env,&newehook,&newahook,&newenv,NULL);
  722.  
  723.     /* get the expression, the new hook functions and the environment */
  724.     expr = xlarg(&args);
  725.     newehook = xlarg(&args);
  726.     newahook = xlarg(&args);
  727.     newenv = (args ? xlarg(&args) : xlenv);
  728.     xllastarg(args);
  729.  
  730.     /* bind *evalhook* and *applyhook* to the hook functions */
  731.     ehook = getvalue(s_evalhook);
  732.     setvalue(s_evalhook,newehook);
  733.     ahook = getvalue(s_applyhook);
  734.     setvalue(s_applyhook,newahook);
  735.     env = xlenv;
  736.     xlenv = newenv;
  737.  
  738.     /* evaluate the expression (bypassing *evalhook*) */
  739.     val = xlxeval(expr);
  740.  
  741.     /* unbind the hook variables */
  742.     setvalue(s_evalhook,ehook);
  743.     setvalue(s_applyhook,ahook);
  744.     xlenv = env;
  745.  
  746.     /* restore the previous stack frame */
  747.     xlstack = oldstk;
  748.  
  749.     /* return the result */
  750.     return (val);
  751. }
  752.  
  753. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  754. LOCAL dobindings(blist,env)
  755.   NODE *blist,*env;
  756. {
  757.     NODE ***oldstk,*list,*bnd,*sym,*val;
  758.  
  759.     /* create a new stack frame */
  760.     oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
  761.  
  762.     /* bind each symbol in the list of bindings */
  763.     for (list = blist; consp(list); list = cdr(list)) {
  764.  
  765.     /* get the next binding */
  766.     bnd = car(list);
  767.  
  768.     /* handle a symbol */
  769.     if (symbolp(bnd)) {
  770.         sym = bnd;
  771.         val = NIL;
  772.     }
  773.  
  774.     /* handle a list of the form (symbol expr) */
  775.     else if (consp(bnd)) {
  776.         sym = xlmatch(SYM,&bnd);
  777.         val = xlevarg(&bnd);
  778.     }
  779.     else
  780.         xlfail("bad binding");
  781.  
  782.     /* bind the value to the symbol */
  783.     xlbind(sym,val,env);
  784.     }
  785.  
  786.     /* restore the previous stack frame */
  787.     xlstack = oldstk;
  788. }
  789.  
  790. /* doupdates - handle updates for do/do* */
  791. doupdates(blist,pflag)
  792.   NODE *blist; int pflag;
  793. {
  794.     NODE ***oldstk,*plist,*list,*bnd,*sym,*val;
  795.  
  796.     /* create a new stack frame */
  797.     oldstk = xlsave(&plist,&list,&bnd,&sym,&val,NULL);
  798.  
  799.     /* bind each symbol in the list of bindings */
  800.     for (list = blist; consp(list); list = cdr(list)) {
  801.  
  802.     /* get the next binding */
  803.     bnd = car(list);
  804.  
  805.     /* handle a list of the form (symbol expr) */
  806.     if (consp(bnd)) {
  807.         sym = xlmatch(SYM,&bnd);
  808.         bnd = cdr(bnd);
  809.         if (bnd) {
  810.         val = xlevarg(&bnd);
  811.         if (pflag) {
  812.             plist = consd(plist);
  813.             rplaca(plist,cons(sym,val));
  814.         }
  815.         else
  816.             xlsetvalue(sym,val);
  817.         }
  818.     }
  819.     }
  820.  
  821.     /* set the values for parallel updates */
  822.     for (; plist; plist = cdr(plist))
  823.     xlsetvalue(car(car(plist)),cdr(car(plist)));
  824.  
  825.     /* restore the previous stack frame */
  826.     xlstack = oldstk;
  827. }
  828.  
  829. /* tagblock - execute code within a block and tagbody */
  830. int tagblock(code,pval)
  831.   NODE *code,**pval;
  832. {
  833.     NODE ***oldstk,*arg;
  834.     CONTEXT cntxt;
  835.     int type,sts;
  836.  
  837.     /* create a new stack frame */
  838.     oldstk = xlsave(&arg,NULL);
  839.  
  840.     /* initialize */
  841.     arg = code;
  842.  
  843.     /* establish an execution context */
  844.     xlbegin(&cntxt,CF_GO|CF_RETURN,arg);
  845.  
  846.     /* check for a 'return' */
  847.     if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
  848.     *pval = xlvalue;
  849.     sts = TRUE;
  850.     }
  851.  
  852.     /* otherwise, enter the body */
  853.     else {
  854.  
  855.     /* check for a 'go' */
  856.     if (type == CF_GO)
  857.         arg = xlvalue;
  858.  
  859.     /* evaluate each expression in the body */
  860.     while (consp(arg))
  861.         if (consp(car(arg)))
  862.         xlevarg(&arg);
  863.         else
  864.         arg = cdr(arg);
  865.  
  866.     /* fell out the bottom of the loop */
  867.     *pval = NIL;
  868.     sts = FALSE;
  869.     }
  870.     xlend(&cntxt);
  871.  
  872.     /* restore the previous stack frame */
  873.     xlstack = oldstk;
  874.  
  875.     /* return status */
  876.     return (sts);
  877. }
  878.