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