home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispdos / source / xleval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-05-17  |  8.1 KB  |  369 lines
  1. /* xleval - xlisp evaluator */
  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. /* macro to check for lambda list keywords */
  9. #define iskeyword(s) ((s) == k_optional || (s) == k_rest || (s) == k_aux)
  10.  
  11. /* external variables */
  12. extern NODE *xlenv;
  13. extern NODE *s_lambda,*s_macro;
  14. extern NODE *k_optional,*k_rest,*k_aux;
  15. extern NODE *s_evalhook,*s_applyhook;
  16. extern NODE *s_unbound;
  17. extern int xlsample;
  18.  
  19. /* trace variables */
  20. extern NODE **trace_stack;
  21. extern int xltrace;
  22.  
  23. /* forward declarations */
  24. FORWARD NODE *xlxeval();
  25. FORWARD NODE *evalhook();
  26. FORWARD NODE *evform();
  27. FORWARD NODE *evfun();
  28.  
  29. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  30. NODE *xleval(expr)
  31.   NODE *expr;
  32. {
  33.     /* check for control codes */
  34.     if (--xlsample <= 0) {
  35.     xlsample = SAMPLE;
  36.     oscheck();
  37.     }
  38.  
  39.     /* check for *evalhook* */
  40.     if (getvalue(s_evalhook))
  41.     return (evalhook(expr));
  42.  
  43.     /* evaluate the expression */
  44.     if (consp(expr))
  45.     return (evform(expr));
  46.     else if (symbolp(expr))
  47.     return (xlgetvalue(expr));
  48.     else
  49.     return (expr);
  50. }
  51.  
  52. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  53. NODE *xlxeval(expr)
  54.   NODE *expr;
  55. {
  56.     if (consp(expr))
  57.     return (evform(expr));
  58.     else if (symbolp(expr))
  59.     return (xlgetvalue(expr));
  60.     else
  61.     return (expr);
  62. }
  63.  
  64. /* xlapply - apply a function to a list of arguments */
  65. NODE *xlapply(fun,args)
  66.   NODE *fun,*args;
  67. {
  68.     NODE *env;
  69.  
  70.     /* handle built-in functions */
  71.     if (subrp(fun))
  72.     return ((*getsubr(fun))(args));
  73.  
  74.     /* handle user defined functions */
  75.     else if (consp(fun)) {
  76.     if (consp(car(fun))) {
  77.         env = cdr(fun);
  78.         fun = car(fun);
  79.     }
  80.     else
  81.         env = xlenv;
  82.     if (car(fun) != s_lambda)
  83.         xlfail("bad function type");
  84.     return (evfun(fun,args,env));
  85.     }
  86.     else
  87.     xlfail("bad function");
  88. }
  89.  
  90. /* evform - evaluate a form */
  91. LOCAL NODE *evform(expr)
  92.   NODE *expr;
  93. {
  94.     NODE ***oldstk,*fun,*args,*env,*val,*type;
  95.  
  96.     /* create a stack frame */
  97.     oldstk = xlstack;
  98.     xlstkcheck(2);
  99.     xlsave(fun);
  100.     xlsave(args);
  101.  
  102.     /* add trace entry */
  103.     if (++xltrace < TDEPTH)
  104.     trace_stack[xltrace] = expr;
  105.  
  106.     /* get the function and the argument list */
  107.     fun = car(expr);
  108.     args = cdr(expr);
  109.  
  110.     /* evaluate the first expression */
  111.     fun = xleval(fun);
  112.  
  113.     /* handle built-in functions */
  114.     if (subrp(fun)) {
  115.     args = xlevlist(args);
  116.     val = (*getsubr(fun))(args);
  117.     }
  118.  
  119.     /* handle special forms */
  120.     else if (fsubrp(fun))
  121.     val = (*getsubr(fun))(args);
  122.  
  123.     /* handle user defined functions and macros */
  124.     else if (consp(fun)) {
  125.     if (consp(car(fun))) {
  126.         env = cdr(fun);
  127.         fun = car(fun);
  128.     }
  129.     else
  130.         env = xlenv;
  131.     if ((type = car(fun)) == s_lambda) {
  132.         args = xlevlist(args);
  133.         val = evfun(fun,args,env);
  134.     }
  135.     else if (type == s_macro) {
  136.         args = evfun(fun,args,env);
  137.         val = xleval(args);
  138.     }
  139.     else
  140.         xlfail("bad function type");
  141.     }
  142.  
  143.     /* handle messages sent to objects */
  144.     else if (objectp(fun))
  145.     val = xlsend(fun,args);
  146.     else
  147.     xlfail("bad function");
  148.  
  149.     /* remove trace entry */
  150.     --xltrace;
  151.  
  152.     /* restore the previous stack frame */
  153.     xlstack = oldstk;
  154.  
  155.     /* return the result value */
  156.     return (val);
  157. }
  158.  
  159. /* evalhook - call the evalhook function */
  160. LOCAL NODE *evalhook(expr)
  161.   NODE *expr;
  162. {
  163.     NODE ***oldstk,*ehook,*ahook,*args,*val;
  164.  
  165.     /* create a new stack frame */
  166.     oldstk = xlstack;
  167.     xlstkcheck(3);
  168.     xlsave(ehook);
  169.     xlsave(ahook);
  170.     xlsave(args);
  171.  
  172.     /* make an argument list */
  173.     args = cons(expr,cons(xlenv,NIL));
  174.  
  175.     /* rebind the hook functions to nil */
  176.     ehook = getvalue(s_evalhook);
  177.     setvalue(s_evalhook,NIL);
  178.     ahook = getvalue(s_applyhook);
  179.     setvalue(s_applyhook,NIL);
  180.  
  181.     /* call the hook function */
  182.     val = xlapply(ehook,args);
  183.  
  184.     /* unbind the symbols */
  185.     setvalue(s_evalhook,ehook);
  186.     setvalue(s_applyhook,ahook);
  187.  
  188.     /* restore the previous stack frame */
  189.     xlstack = oldstk;
  190.  
  191.     /* return the value */
  192.     return (val);
  193. }
  194.  
  195. /* xlevlist - evaluate a list of arguments */
  196. NODE *xlevlist(args)
  197.   NODE *args;
  198. {
  199.     NODE ***oldstk,*src,*dst,*new,*last;
  200.  
  201.     /* create a stack frame */
  202.     oldstk = xlstack;
  203.     xlstkcheck(2);
  204.     xlsave(src);
  205.     xlsave(dst);
  206.  
  207.     /* evaluate each argument */
  208.     for (src = args, dst = NIL; consp(src); src = cdr(src)) {
  209.  
  210.     /* allocate a new list entry */
  211.     new = cons(xleval(car(src)),NIL);
  212.     if (dst)
  213.         rplacd(last,new);
  214.     else
  215.         dst = new;
  216.     last = new;
  217.     }
  218.  
  219.     /* restore the previous stack frame */
  220.     xlstack = oldstk;
  221.  
  222.     /* return the new list */
  223.     return (dst);
  224. }
  225.  
  226. /* xlunbound - signal an unbound variable error */
  227. xlunbound(sym)
  228.   NODE *sym;
  229. {
  230.     xlcerror("try evaluating symbol again","unbound variable",sym);
  231. }
  232.  
  233. /* xlstkoverflow - signal a stack overflow error */
  234. xlstkoverflow()
  235. {
  236.     xlabort("evaulation stack overflow");
  237. }
  238.  
  239. /* evfun - evaluate a function */
  240. LOCAL NODE *evfun(fun,args,env)
  241.   NODE *fun,*args,*env;
  242. {
  243.     NODE ***oldstk,*oldenv,*newenv,*cptr,*fargs,*val;
  244.  
  245.     /* create a stack frame */
  246.     oldstk = xlstack;
  247.     xlstkcheck(3);
  248.     xlsave(oldenv);
  249.     xlsave(newenv);
  250.     xlsave(cptr);
  251.  
  252.     /* skip the function type */
  253.     if ((fun = cdr(fun)) == NIL || !consp(fun))
  254.     xlfail("bad function definition");
  255.  
  256.     /* get the formal argument list */
  257.     if ((fargs = car(fun)) && !consp(fargs))
  258.     xlfail("bad formal argument list");
  259.  
  260.     /* create a new environment frame */
  261.     newenv = xlframe(env);
  262.     oldenv = xlenv;
  263.  
  264.     /* bind the formal parameters */
  265.     xlabind(fargs,args,newenv);
  266.     xlenv = newenv;
  267.  
  268.     /* execute the code */
  269.     for (cptr = cdr(fun); consp(cptr); cptr = cdr(cptr))
  270.     val = xleval(car(cptr));
  271.  
  272.     /* restore the environment */
  273.     xlenv = oldenv;
  274.  
  275.     /* restore the previous stack frame */
  276.     xlstack = oldstk;
  277.  
  278.     /* return the result value */
  279.     return (val);
  280. }
  281.  
  282. /* xlabind - bind the arguments for a function */
  283. xlabind(fargs,aargs,env)
  284.   NODE *fargs,*aargs,*env;
  285. {
  286.     NODE *arg;
  287.  
  288.     /* evaluate and bind each required argument */
  289.     while (consp(fargs) && consp(aargs)) {
  290.  
  291.     /* get the next formal argument */
  292.     arg = car(fargs);
  293.  
  294.     /* check for a keyword */
  295.     if (iskeyword(arg))
  296.         break;
  297.  
  298.     /* bind the formal variable to the argument value */
  299.     xlbind(arg,car(aargs),env);
  300.  
  301.     /* move the argument list pointers ahead */
  302.     fargs = cdr(fargs);
  303.     aargs = cdr(aargs);
  304.     }
  305.  
  306.     /* check for the '&optional' keyword */
  307.     if (consp(fargs) && car(fargs) == k_optional) {
  308.     fargs = cdr(fargs);
  309.  
  310.     /* bind the arguments that were supplied */
  311.     while (consp(fargs) && consp(aargs)) {
  312.  
  313.         /* get the next formal argument */
  314.         arg = car(fargs);
  315.  
  316.         /* check for a keyword */
  317.         if (iskeyword(arg))
  318.         break;
  319.  
  320.         /* bind the formal variable to the argument value */
  321.         xlbind(arg,car(aargs),env);
  322.  
  323.         /* move the argument list pointers ahead */
  324.         fargs = cdr(fargs);
  325.         aargs = cdr(aargs);
  326.     }
  327.  
  328.     /* bind the rest to nil */
  329.     while (consp(fargs)) {
  330.  
  331.         /* get the next formal argument */
  332.         arg = car(fargs);
  333.  
  334.         /* check for a keyword */
  335.         if (iskeyword(arg))
  336.         break;
  337.  
  338.         /* bind the formal variable to nil */
  339.         xlbind(arg,NIL,env);
  340.  
  341.         /* move the argument list pointer ahead */
  342.         fargs = cdr(fargs);
  343.     }
  344.     }
  345.  
  346.     /* check for the '&rest' keyword */
  347.     if (consp(fargs) && car(fargs) == k_rest) {
  348.     fargs = cdr(fargs);
  349.  
  350.     /* bind the following symbol to the rest of the argument list */
  351.     if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
  352.         xlbind(arg,aargs,env);
  353.     else
  354.         xlfail("symbol missing after &rest");
  355.     fargs = cdr(fargs);
  356.     aargs = NIL;
  357.     }
  358.  
  359.     /* check for the '&aux' keyword */
  360.     if (consp(fargs) && car(fargs) == k_aux)
  361.     while ((fargs = cdr(fargs)) != NIL && consp(fargs))
  362.         xlbind(car(fargs),NIL,env);
  363.  
  364.     /* make sure the correct number of arguments were supplied */
  365.     if (fargs != aargs)
  366.     xlfail(fargs ? "too few arguments" : "too many arguments");
  367. }
  368.  
  369.