home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / xlisp / xlisp12.ark / XLEVAL.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-02-20  |  8.3 KB  |  368 lines
  1. /* xleval - xlisp evaluator */
  2.  
  3. #ifdef AZTEC
  4. #include "stdio.h"
  5. #include "setjmp.h"
  6. #else
  7. #include <stdio.h>
  8. #include <setjmp.h>
  9. #endif
  10.  
  11. #include "xlisp.h"
  12.  
  13. /* global variables */
  14. struct node *xlstack;
  15.  
  16. /* trace stack */
  17. static struct node *trace_stack[TDEPTH];
  18. static int trace_pointer;
  19.  
  20. /* external variables */
  21. extern jmp_buf *xljmpbuf;
  22. extern struct node *xlenv;
  23. extern struct node *s_lambda,*s_nlambda;
  24. extern struct node *s_unbound;
  25. extern struct node *s_stdout;
  26. extern struct node *s_tracenable;
  27. extern struct node *k_rest;
  28. extern struct node *k_aux;
  29.  
  30. /* forward declarations */
  31. FORWARD struct node *evform();
  32. FORWARD struct node *evsym();
  33. FORWARD struct node *evfun();
  34.  
  35. /* xleval - evaluate an xlisp expression */
  36. struct node *xleval(expr)
  37.   struct node *expr;
  38. {
  39.     /* evaluate null to itself */
  40.     if (expr == NULL)
  41.     return (NULL);
  42.  
  43.     /* add trace entry */
  44.     tpush(expr);
  45.  
  46.     /* check type of value */
  47.     switch (expr->n_type) {
  48.     case LIST:
  49.         expr = evform(expr);
  50.         break;
  51.     case SYM:
  52.         expr = evsym(expr);
  53.         break;
  54.     case INT:
  55.     case STR:
  56.     case SUBR:
  57.     case FSUBR:
  58.         break;
  59.     default:
  60.         xlfail("can't evaluate expression");
  61.     }
  62.  
  63.     /* remove trace entry */
  64.     tpop();
  65.  
  66.     /* return the value */
  67.     return (expr);
  68. }
  69.  
  70. /* xlapply - apply a function to a list of arguments */
  71. struct node *xlapply(fun,args)
  72.   struct node *fun,*args;
  73. {
  74.     struct node *val;
  75.  
  76.     /* check for a null function */
  77.     if (fun == NULL)
  78.     xlfail("null function");
  79.  
  80.     /* evaluate the function */
  81.     switch (fun->n_type) {
  82.     case SUBR:
  83.         val = (*fun->n_subr)(args);
  84.         break;
  85.     case LIST:
  86.         if (fun->n_listvalue != s_lambda)
  87.         xlfail("bad function type");
  88.         val = evfun(fun,args);
  89.         break;
  90.     default:
  91.         xlfail("bad function");
  92.     }
  93.  
  94.     /* return the result value */
  95.     return (val);
  96. }
  97.  
  98. /* evform - evaluate a form */
  99. LOCAL struct node *evform(nptr)
  100.   struct node *nptr;
  101. {
  102.     struct node *oldstk,fun,args,*val,*type;
  103.  
  104.     /* create a stack frame */
  105.     oldstk = xlsave(&fun,&args,NULL);
  106.  
  107.     /* get the function and the argument list */
  108.     fun.n_ptr = nptr->n_listvalue;
  109.     args.n_ptr = nptr->n_listnext;
  110.  
  111.     /* evaluate the first expression */
  112.     if ((fun.n_ptr = xleval(fun.n_ptr)) == NULL)
  113.     xlfail("null function");
  114.  
  115.     /* evaluate the function */
  116.     switch (fun.n_ptr->n_type) {
  117.     case SUBR:
  118.         args.n_ptr = xlevlist(args.n_ptr);
  119.     case FSUBR:
  120.         val = (*fun.n_ptr->n_subr)(args.n_ptr);
  121.         break;
  122.     case LIST:
  123.         if ((type = fun.n_ptr->n_listvalue) == s_lambda)
  124.         args.n_ptr = xlevlist(args.n_ptr);
  125.         else if (type != s_nlambda)
  126.         xlfail("bad function type");
  127.         val = evfun(fun.n_ptr,args.n_ptr);
  128.         break;
  129.     case OBJ:
  130.         val = xlsend(fun.n_ptr,args.n_ptr);
  131.         break;
  132.     default:
  133.         xlfail("bad function");
  134.     }
  135.  
  136.     /* restore the previous stack frame */
  137.     xlstack = oldstk;
  138.  
  139.     /* return the result value */
  140.     return (val);
  141. }
  142.  
  143. /* xlevlist - evaluate a list of arguments */
  144. struct node *xlevlist(args)
  145.   struct node *args;
  146. {
  147.     struct node *oldstk,src,dst,*new,*last,*val;
  148.  
  149.     /* create a stack frame */
  150.     oldstk = xlsave(&src,&dst,NULL);
  151.  
  152.     /* initialize */
  153.     src.n_ptr = args;
  154.  
  155.     /* evaluate each argument */
  156.     for (val = NULL; src.n_ptr; src.n_ptr = src.n_ptr->n_listnext) {
  157.  
  158.     /* check this entry */
  159.     if (src.n_ptr->n_type != LIST)
  160.         xlfail("bad argument list");
  161.  
  162.     /* allocate a new list entry */
  163.     new = newnode(LIST);
  164.     if (val)
  165.         last->n_listnext = new;
  166.     else
  167.         val = dst.n_ptr = new;
  168.     new->n_listvalue = xleval(src.n_ptr->n_listvalue);
  169.     last = new;
  170.     }
  171.  
  172.     /* restore the previous stack frame */
  173.     xlstack = oldstk;
  174.  
  175.     /* return the new list */
  176.     return (val);
  177. }
  178.  
  179. /* evsym - evaluate a symbol */
  180. LOCAL struct node *evsym(sym)
  181.   struct node *sym;
  182. {
  183.     struct node *p;
  184.  
  185.     /* check for a current object */
  186.     if ((p = xlobsym(sym)) != NULL)
  187.     return (p->n_listvalue);
  188.     else if ((p = sym->n_symvalue) == s_unbound)
  189.     xlfail("unbound variable");
  190.     else
  191.     return (p);
  192. }
  193.  
  194. /* evfun - evaluate a function */
  195. LOCAL struct node *evfun(fun,args)
  196.   struct node *fun,*args;
  197. {
  198.     struct node *oldenv,*oldstk,cptr,*fargs,*val;
  199.  
  200.     /* create a stack frame */
  201.     oldstk = xlsave(&cptr,NULL);
  202.  
  203.     /* skip the function type */
  204.     if ((fun = fun->n_listnext) == NULL)
  205.     xlfail("bad function definition");
  206.  
  207.     /* get the formal argument list */
  208.     if ((fargs = fun->n_listvalue) != NULL && fargs->n_type != LIST)
  209.     xlfail("bad formal argument list");
  210.  
  211.     /* bind the formal parameters */
  212.     oldenv = xlenv;
  213.     xlabind(fargs,args);
  214.     xlfixbindings(oldenv);
  215.  
  216.     /* execute the code */
  217.     for (cptr.n_ptr = fun->n_listnext; cptr.n_ptr != NULL; )
  218.     val = xlevarg(&cptr.n_ptr);
  219.  
  220.     /* restore the environment */
  221.     xlunbind(oldenv);
  222.  
  223.     /* restore the previous stack frame */
  224.     xlstack = oldstk;
  225.  
  226.     /* return the result value */
  227.     return (val);
  228. }
  229.  
  230. /* xlabind - bind the arguments for a function */
  231. xlabind(fargs,aargs)
  232.   struct node *fargs,*aargs;
  233. {
  234.     struct node *oldstk,farg,aarg,*arg;
  235.  
  236.     /* create a stack frame */
  237.     oldstk = xlsave(&farg,&aarg,NULL);
  238.  
  239.     /* initialize the pointers */
  240.     farg.n_ptr = fargs;
  241.     aarg.n_ptr = aargs;
  242.  
  243.     /* evaluate and bind each argument */
  244.     while (farg.n_ptr != NULL && aarg.n_ptr != NULL) {
  245.  
  246.     /* check for a keyword */
  247.     if (iskeyword(arg = farg.n_ptr->n_listvalue))
  248.         break;
  249.  
  250.     /* bind the formal variable to the argument value */
  251.     xlbind(arg,aarg.n_ptr->n_listvalue);
  252.  
  253.     /* move the argument list pointers ahead */
  254.     farg.n_ptr = farg.n_ptr->n_listnext;
  255.     aarg.n_ptr = aarg.n_ptr->n_listnext;
  256.     }
  257.  
  258.     /* check for the '&rest' keyword */
  259.     if (farg.n_ptr && farg.n_ptr->n_listvalue == k_rest) {
  260.     farg.n_ptr = farg.n_ptr->n_listnext;
  261.     if (farg.n_ptr && (arg = farg.n_ptr->n_listvalue) && !iskeyword(arg))
  262.         xlbind(arg,aarg.n_ptr);
  263.     else
  264.         xlfail("symbol missing after &rest");
  265.     farg.n_ptr = farg.n_ptr->n_listnext;
  266.     aarg.n_ptr = NULL;
  267.     }
  268.  
  269.     /* check for the '&aux' keyword */
  270.     if (farg.n_ptr && farg.n_ptr->n_listvalue == k_aux)
  271.     while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL)
  272.         xlbind(farg.n_ptr->n_listvalue,NULL);
  273.  
  274.     /* make sure the correct number of arguments were supplied */
  275.     if (farg.n_ptr != aarg.n_ptr)
  276.     xlfail("incorrect number of arguments to a function");
  277.  
  278.     /* restore the previous stack frame */
  279.     xlstack = oldstk;
  280. }
  281.  
  282. /* iskeyword - check to see if a symbol is a keyword */
  283. LOCAL int iskeyword(sym)
  284.   struct node *sym;
  285. {
  286.     return (sym == k_rest || sym == k_aux);
  287. }
  288.  
  289. /* xlsave - save nodes on the stack */
  290. struct node *xlsave(n)
  291.   struct node *n;
  292. {
  293.     struct node **nptr,*oldstk;
  294.  
  295.     /* save the old stack pointer */
  296.     oldstk = xlstack;
  297.  
  298.     /* save each node */
  299.     for (nptr = &n; *nptr != NULL; nptr++) {
  300.     (*nptr)->n_type = LIST;
  301.     (*nptr)->n_listvalue = NULL;
  302.     (*nptr)->n_listnext = xlstack;
  303.     xlstack = *nptr;
  304.     }
  305.  
  306.     /* return the old stack pointer */
  307.     return (oldstk);
  308. }
  309.  
  310. /* xlfail - error handling routine */
  311. xlfail(err)
  312.   char *err;
  313. {
  314.     /* print the error message */
  315.     printf("error: %s\n",err);
  316.  
  317.     /* flush the terminal input buffer */
  318.     xlflush();
  319.  
  320.     /* unbind bound symbols */
  321.     xlunbind(NULL);
  322.  
  323.     /* do the back trace */
  324.     if (s_tracenable->n_symvalue)
  325.     baktrace();
  326.     trace_pointer = -1;
  327.  
  328.     /* restart */
  329.     longjmp(xljmpbuf,1);
  330. }
  331.  
  332. /* tpush - add an entry to the trace stack */
  333. LOCAL tpush(nptr)
  334.     struct node *nptr;
  335. {
  336.     if (++trace_pointer < TDEPTH)
  337.     trace_stack[trace_pointer] = nptr;
  338. }
  339.  
  340. /* tpop - pop an entry from the trace stack */
  341. LOCAL tpop()
  342. {
  343.     trace_pointer--;
  344. }
  345.  
  346. /* baktrace - do a back trace */
  347. LOCAL baktrace()
  348. {
  349.     for (; trace_pointer >= 0; trace_pointer--)
  350.     if (trace_pointer < TDEPTH)
  351.         stdprint(trace_stack[trace_pointer]);
  352. }
  353.  
  354. /* stdprint - print to standard output */
  355. stdprint(expr)
  356.   struct node *expr;
  357. {
  358.     xlprint(s_stdout->n_symvalue,expr,TRUE);
  359.     xlterpri(s_stdout->n_symvalue);
  360. }
  361.  
  362. /* xleinit - initialize the evaluator */
  363. xleinit()
  364. {
  365.     /* initialize debugging stuff */
  366.     trace_pointer = -1;
  367. }
  368.