home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / languags / xlisp / xlisp11.ark / XLEVAL.C < prev    next >
Text File  |  1986-10-12  |  7KB  |  291 lines
  1. /* xleval - xlisp evaluator */
  2.  
  3. #ifdef AZTEC
  4. #include "a:stdio.h"
  5. #include "a: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.  
  24. /* local variables */
  25. static struct node *slash;
  26.  
  27. /* forward declarations (the extern hack is for decusc) */
  28. extern struct node *evlist();
  29. extern struct node *evsym();
  30. extern struct node *evfun();
  31.  
  32. /* eval - the builtin function 'eval' */
  33. static struct node *eval(args)
  34.   struct node *args;
  35. {
  36.     struct node *oldstk,expr,*val;
  37.  
  38.     /* create a new stack frame */
  39.     oldstk = xlsave(&expr,NULL);
  40.  
  41.     /* get the expression to evaluate */
  42.     expr.n_ptr = xlevarg(&args);
  43.  
  44.     /* make sure there aren't any more arguments */
  45.     xllastarg(args);
  46.  
  47.     /* evaluate the expression */
  48.     val = xleval(expr.n_ptr);
  49.  
  50.     /* restore the previous stack frame */
  51.     xlstack = oldstk;
  52.  
  53.     /* return the expression evaluated */
  54.     return (val);
  55. }
  56.  
  57. /* xleval - evaluate an xlisp expression */
  58. struct node *xleval(expr)
  59.   struct node *expr;
  60. {
  61.     /* evaluate null to itself */
  62.     if (expr == NULL)
  63.     return (NULL);
  64.  
  65.     /* check type of value */
  66.     switch (expr->n_type) {
  67.     case LIST:
  68.         return (evlist(expr));
  69.     case SYM:
  70.         return (evsym(expr));
  71.     case INT:
  72.     case STR:
  73.     case SUBR:
  74.         return (expr);
  75.     default:
  76.         xlfail("can't evaluate expression");
  77.     }
  78. }
  79.  
  80. /* xlsave - save nodes on the stack */
  81. struct node *xlsave(n)
  82.   struct node *n;
  83. {
  84.     struct node **nptr,*oldstk;
  85.  
  86.     /* save the old stack pointer */
  87.     oldstk = xlstack;
  88.  
  89.     /* save each node */
  90.     for (nptr = &n; *nptr != NULL; nptr++) {
  91.     (*nptr)->n_type = LIST;
  92.     (*nptr)->n_listvalue = NULL;
  93.     (*nptr)->n_listnext = xlstack;
  94.     xlstack = *nptr;
  95.     }
  96.  
  97.     /* return the old stack pointer */
  98.     return (oldstk);
  99. }
  100.  
  101. /* evlist - evaluate a list */
  102. static struct node *evlist(nptr)
  103.   struct node *nptr;
  104. {
  105.     struct node *oldstk,fun,args,*val;
  106.  
  107.     /* create a stack frame */
  108.     oldstk = xlsave(&fun,&args,NULL);
  109.  
  110.     /* get the function and the argument list */
  111.     fun.n_ptr = nptr->n_listvalue;
  112.     args.n_ptr = nptr->n_listnext;
  113.  
  114.     /* add trace entry */
  115.     tpush(nptr);
  116.  
  117.     /* evaluate the first expression */
  118.     if ((fun.n_ptr = xleval(fun.n_ptr)) == NULL)
  119.     xlfail("null function");
  120.  
  121.     /* evaluate the function */
  122.     switch (fun.n_ptr->n_type) {
  123.     case SUBR:
  124.         val = (*fun.n_ptr->n_subr)(args.n_ptr);
  125.         break;
  126.     case LIST:
  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.     /* remove trace entry */
  140.     tpop();
  141.  
  142.     /* return the result value */
  143.     return (val);
  144. }
  145.  
  146. /* evsym - evaluate a symbol */
  147. static struct node *evsym(sym)
  148.   struct node *sym;
  149. {
  150.     struct node *lptr;
  151.  
  152.     /* check for a current object */
  153.     if ((lptr = xlobsym(sym)) != NULL)
  154.     return (lptr->n_listvalue);
  155.     else
  156.     return (sym->n_symvalue);
  157. }
  158.  
  159. /* evfun - evaluate a function */
  160. static struct node *evfun(fun,args)
  161.   struct node *fun,*args;
  162. {
  163.     struct node *oldenv,*oldstk,cptr,*fargs,*val;
  164.  
  165.     /* create a stack frame */
  166.     oldstk = xlsave(&cptr,NULL);
  167.  
  168.     /* get the formal argument list */
  169.     if ((fargs = fun->n_listvalue) != NULL && fargs->n_type != LIST)
  170.     xlfail("bad formal argument list");
  171.  
  172.     /* bind the formal parameters */
  173.     oldenv = xlenv;
  174.     xlabind(fargs,args);
  175.     xlfixbindings(oldenv);
  176.  
  177.     /* execute the code */
  178.     for (cptr.n_ptr = fun->n_listnext; cptr.n_ptr != NULL; )
  179.     val = xlevarg(&cptr.n_ptr);
  180.  
  181.     /* restore the environment */
  182.     xlunbind(oldenv);
  183.  
  184.     /* restore the previous stack frame */
  185.     xlstack = oldstk;
  186.  
  187.     /* return the result value */
  188.     return (val);
  189. }
  190.  
  191. /* xlabind - bind the arguments for a function */
  192. xlabind(fargs,aargs)
  193.   struct node *fargs,*aargs;
  194. {
  195.     struct node *oldstk,farg,aarg,val;
  196.  
  197.     /* create a stack frame */
  198.     oldstk = xlsave(&farg,&aarg,&val,NULL);
  199.  
  200.     /* initialize the pointers */
  201.     farg.n_ptr = fargs;
  202.     aarg.n_ptr = aargs;
  203.  
  204.     /* evaluate and bind each argument */
  205.     while (farg.n_ptr != NULL && aarg.n_ptr != NULL) {
  206.  
  207.     /* check for local variable separator */
  208.     if (farg.n_ptr->n_listvalue == slash)
  209.         break;
  210.  
  211.     /* evaluate the argument */
  212.     val.n_ptr = xlevarg(&aarg.n_ptr);
  213.  
  214.     /* bind the formal variable to the argument value */
  215.     xlbind(farg.n_ptr->n_listvalue,val.n_ptr);
  216.  
  217.     /* move the formal argument list pointer ahead */
  218.     farg.n_ptr = farg.n_ptr->n_listnext;
  219.     }
  220.  
  221.     /* check for local variables */
  222.     if (farg.n_ptr != NULL && farg.n_ptr->n_listvalue == slash)
  223.     while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL)
  224.         xlbind(farg.n_ptr->n_listvalue,NULL);
  225.  
  226.     /* restore the previous stack frame */
  227.     xlstack = oldstk;
  228.  
  229.     /* make sure the correct number of arguments were supplied */
  230.     if (farg.n_ptr != aarg.n_ptr)
  231.     xlfail("incorrect number of arguments to a function");
  232. }
  233.  
  234. /* xlfail - error handling routine */
  235. xlfail(err)
  236.   char *err;
  237. {
  238.     /* print the error message */
  239.     printf("error: %s\n",err);
  240.  
  241.     /* unbind bound symbols */
  242.     xlunbind(NULL);
  243.  
  244.     /* restore input to the terminal */
  245.     xltin(TRUE);
  246.  
  247.     /* do the back trace */
  248.     trace();
  249.     trace_pointer = -1;
  250.  
  251.     /* restart */
  252.     longjmp(xljmpbuf,1);
  253. }
  254.  
  255. /* tpush - add an entry to the trace stack */
  256. static tpush(nptr)
  257.     struct node *nptr;
  258. {
  259.     if (++trace_pointer < TDEPTH)
  260.     trace_stack[trace_pointer] = nptr;
  261. }
  262.  
  263. /* tpop - pop an entry from the trace stack */
  264. static tpop()
  265. {
  266.     trace_pointer--;
  267. }
  268.  
  269. /* trace - do a back trace */
  270. static trace()
  271. {
  272.     for (; trace_pointer >= 0; trace_pointer--)
  273.     if (trace_pointer < TDEPTH) {
  274.         xlprint(trace_stack[trace_pointer],TRUE);
  275.         putchar('\n');
  276.     }
  277. }
  278.  
  279. /* xleinit - initialize the evaluator */
  280. xleinit()
  281. {
  282.     /* enter the local variable separator symbol */
  283.     slash = xlenter("/");
  284.  
  285.     /* initialize debugging stuff */
  286.     trace_pointer = -1;
  287.  
  288.     /* builtin functions */
  289.     xlsubr("eval",eval);
  290. }
  291.