home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / xlisp / xlisp12.ark / XLCONT.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-02-20  |  6.1 KB  |  288 lines
  1. /* xlcont - xlisp control builtin functions */
  2.  
  3. #ifdef AZTEC
  4. #include "stdio.h"
  5. #else
  6. #include <stdio.h>
  7. #endif
  8.  
  9. #include "xlisp.h"
  10.  
  11. /* external variables */
  12. extern struct node *xlstack,*xlenv;
  13. extern struct node *true;
  14.  
  15. /* xcond - builtin function cond */
  16. struct node *xcond(args)
  17.   struct node *args;
  18. {
  19.     struct node *oldstk,arg,list,*val;
  20.  
  21.     /* create a new stack frame */
  22.     oldstk = xlsave(&arg,&list,NULL);
  23.  
  24.     /* initialize */
  25.     arg.n_ptr = args;
  26.  
  27.     /* initialize the return value */
  28.     val = NULL;
  29.  
  30.     /* find a predicate that is true */
  31.     while (arg.n_ptr != NULL) {
  32.  
  33.     /* get the next conditional */
  34.     list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  35.  
  36.     /* evaluate the predicate part */
  37.     if (xlevarg(&list.n_ptr) != NULL) {
  38.  
  39.         /* evaluate each expression */
  40.         while (list.n_ptr != NULL)
  41.         val = xlevarg(&list.n_ptr);
  42.  
  43.         /* exit the loop */
  44.         break;
  45.     }
  46.     }
  47.  
  48.     /* restore the previous stack frame */
  49.     xlstack = oldstk;
  50.  
  51.     /* return the value */
  52.     return (val);
  53. }
  54.  
  55. /* xand - builtin function 'and; */
  56. struct node *xand(args)
  57.   struct node *args;
  58. {
  59.     struct node *oldstk,arg,*val;
  60.  
  61.     /* create a new stack frame */
  62.     oldstk = xlsave(&arg,NULL);
  63.  
  64.     /* initialize */
  65.     arg.n_ptr = args;
  66.     val = true;
  67.  
  68.     /* evaluate each argument */
  69.     while (arg.n_ptr != NULL)
  70.  
  71.     /* get the next argument */
  72.     if ((val = xlevarg(&arg.n_ptr)) == NULL)
  73.         break;
  74.  
  75.     /* restore the previous stack frame */
  76.     xlstack = oldstk;
  77.  
  78.     /* return the result value */
  79.     return (val);
  80. }
  81.  
  82. /* xor - builtin function 'or' */
  83. struct node *xor(args)
  84.   struct node *args;
  85. {
  86.     struct node *oldstk,arg,*val;
  87.  
  88.     /* create a new stack frame */
  89.     oldstk = xlsave(&arg,NULL);
  90.  
  91.     /* initialize */
  92.     arg.n_ptr = args;
  93.     val = NULL;
  94.  
  95.     /* evaluate each argument */
  96.     while (arg.n_ptr != NULL)
  97.     if ((val = xlevarg(&arg.n_ptr)) != NULL)
  98.         break;
  99.  
  100.     /* restore the previous stack frame */
  101.     xlstack = oldstk;
  102.  
  103.     /* return the result value */
  104.     return (val);
  105. }
  106.  
  107. /* xlet - establish some local bindings and execute some code */
  108. struct node *xlet(args)
  109.   struct node *args;
  110. {
  111.     struct node *oldstk,*oldenv,arg,bnd,sym,val,*p;
  112.  
  113.     /* create a new stack frame */
  114.     oldstk = xlsave(&arg,&bnd,&sym,&val,NULL);
  115.  
  116.     /* initialize */
  117.     arg.n_ptr = args;
  118.  
  119.     /* get the list of bindings */
  120.     bnd.n_ptr = xlmatch(LIST,&arg.n_ptr);
  121.  
  122.     /* initialize the local environment */
  123.     oldenv = xlenv;
  124.  
  125.     /* bind each symbol in the list of bindings */
  126.     while (bnd.n_ptr && bnd.n_ptr->n_type == LIST) {
  127.  
  128.     /* get the next binding */
  129.     p = bnd.n_ptr->n_listvalue;
  130.  
  131.     /* check its type */
  132.     switch (p->n_type) {
  133.     case SYM:
  134.         sym.n_ptr = p;
  135.         val.n_ptr = NULL;
  136.         break;
  137.     case LIST:
  138.         sym.n_ptr = p->n_listvalue;
  139.         val.n_ptr = p->n_listnext->n_listvalue;
  140.         val.n_ptr = xleval(val.n_ptr);
  141.         break;
  142.     default:
  143.         xlfail("bad binding");
  144.     }
  145.  
  146.     /* bind the value to the symbol */
  147.     xlbind(sym.n_ptr,val.n_ptr);
  148.  
  149.     /* get next binding */
  150.     bnd.n_ptr = bnd.n_ptr->n_listnext;
  151.     }
  152.  
  153.     /* fix the bindings */
  154.     xlfixbindings(oldenv);
  155.  
  156.     /* execute the code */
  157.     for (val.n_ptr = NULL; arg.n_ptr; )
  158.     val.n_ptr = xlevarg(&arg.n_ptr);
  159.  
  160.     /* unbind the arguments */
  161.     xlunbind(oldenv);
  162.  
  163.     /* restore the previous stack frame */
  164.     xlstack = oldstk;
  165.  
  166.     /* return the result */
  167.     return (val.n_ptr);
  168. }
  169.  
  170. /* xwhile - builtin function while */
  171. struct node *xwhile(args)
  172.   struct node *args;
  173. {
  174.     struct node *oldstk,farg,arg,*val;
  175.  
  176.     /* create a new stack frame */
  177.     oldstk = xlsave(&farg,&arg,NULL);
  178.  
  179.     /* initialize */
  180.     farg.n_ptr = arg.n_ptr = args;
  181.  
  182.     /* loop until test fails */
  183.     val = NULL;
  184.     for (; TRUE; arg.n_ptr = farg.n_ptr) {
  185.  
  186.     /* evaluate the test expression */
  187.     if (xlevarg(&arg.n_ptr) == NULL)
  188.         break;
  189.  
  190.     /* evaluate each remaining argument */
  191.     while (arg.n_ptr != NULL)
  192.         val = xlevarg(&arg.n_ptr);
  193.     }
  194.  
  195.     /* restore the previous stack frame */
  196.     xlstack = oldstk;
  197.  
  198.     /* return the last test expression value */
  199.     return (val);
  200. }
  201.  
  202. /* xrepeat - builtin function repeat */
  203. struct node *xrepeat(args)
  204.   struct node *args;
  205. {
  206.     struct node *oldstk,farg,arg,*val;
  207.     int cnt;
  208.  
  209.     /* create a new stack frame */
  210.     oldstk = xlsave(&farg,&arg,NULL);
  211.  
  212.     /* initialize */
  213.     arg.n_ptr = args;
  214.  
  215.     /* evaluate the repeat count */
  216.     cnt = xlevmatch(INT,&arg.n_ptr)->n_int;
  217.  
  218.     /* save the first expression to repeat */
  219.     farg.n_ptr = arg.n_ptr;
  220.  
  221.     /* loop until test fails */
  222.     val = NULL;
  223.     for (; cnt > 0; cnt--) {
  224.  
  225.     /* evaluate each remaining argument */
  226.     while (arg.n_ptr != NULL)
  227.         val = xlevarg(&arg.n_ptr);
  228.  
  229.     /* restore pointer to first expression */
  230.     arg.n_ptr = farg.n_ptr;
  231.     }
  232.  
  233.     /* restore the previous stack frame */
  234.     xlstack = oldstk;
  235.  
  236.     /* return the last test expression value */
  237.     return (val);
  238. }
  239.  
  240. /* xif - builtin function 'if' */
  241. struct node *xif(args)
  242.   struct node *args;
  243. {
  244.     struct node *oldstk,testexpr,thenexpr,elseexpr,*val;
  245.  
  246.     /* create a new stack frame */
  247.     oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
  248.  
  249.     /* get the test expression, then clause and else clause */
  250.     testexpr.n_ptr = xlarg(&args);
  251.     thenexpr.n_ptr = xlarg(&args);
  252.     elseexpr.n_ptr = (args ? xlarg(&args) : NULL);
  253.     xllastarg(args);
  254.  
  255.     /* evaluate the appropriate clause */
  256.     val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
  257.  
  258.     /* restore the previous stack frame */
  259.     xlstack = oldstk;
  260.  
  261.     /* return the last value */
  262.     return (val);
  263. }
  264.  
  265. /* xprogn - builtin function 'progn' */
  266. struct node *xprogn(args)
  267.   struct node *args;
  268. {
  269.     struct node *oldstk,arg,*val;
  270.     int cnt;
  271.  
  272.     /* create a new stack frame */
  273.     oldstk = xlsave(&arg,NULL);
  274.  
  275.     /* initialize */
  276.     arg.n_ptr = args;
  277.  
  278.     /* evaluate each remaining argument */
  279.     for (val = NULL; arg.n_ptr != NULL; )
  280.     val = xlevarg(&arg.n_ptr);
  281.  
  282.     /* restore the previous stack frame */
  283.     xlstack = oldstk;
  284.  
  285.     /* return the last test expression value */
  286.     return (val);
  287. }
  288.