/* xleval - xlisp evaluator */ #ifdef AZTEC #include "a:stdio.h" #include "a:setjmp.h" #else #include #include #endif #include "xlisp.h" /* global variables */ struct node *xlstack; /* trace stack */ static struct node *trace_stack[TDEPTH]; static int trace_pointer; /* external variables */ extern jmp_buf xljmpbuf; extern struct node *xlenv; /* local variables */ static struct node *slash; /* forward declarations (the extern hack is for decusc) */ extern struct node *evlist(); extern struct node *evsym(); extern struct node *evfun(); /* eval - the builtin function 'eval' */ static struct node *eval(args) struct node *args; { struct node *oldstk,expr,*val; /* create a new stack frame */ oldstk = xlsave(&expr,NULL); /* get the expression to evaluate */ expr.n_ptr = xlevarg(&args); /* make sure there aren't any more arguments */ xllastarg(args); /* evaluate the expression */ val = xleval(expr.n_ptr); /* restore the previous stack frame */ xlstack = oldstk; /* return the expression evaluated */ return (val); } /* xleval - evaluate an xlisp expression */ struct node *xleval(expr) struct node *expr; { /* evaluate null to itself */ if (expr == NULL) return (NULL); /* check type of value */ switch (expr->n_type) { case LIST: return (evlist(expr)); case SYM: return (evsym(expr)); case INT: case STR: case SUBR: return (expr); default: xlfail("can't evaluate expression"); } } /* xlsave - save nodes on the stack */ struct node *xlsave(n) struct node *n; { struct node **nptr,*oldstk; /* save the old stack pointer */ oldstk = xlstack; /* save each node */ for (nptr = &n; *nptr != NULL; nptr++) { (*nptr)->n_type = LIST; (*nptr)->n_listvalue = NULL; (*nptr)->n_listnext = xlstack; xlstack = *nptr; } /* return the old stack pointer */ return (oldstk); } /* evlist - evaluate a list */ static struct node *evlist(nptr) struct node *nptr; { struct node *oldstk,fun,args,*val; /* create a stack frame */ oldstk = xlsave(&fun,&args,NULL); /* get the function and the argument list */ fun.n_ptr = nptr->n_listvalue; args.n_ptr = nptr->n_listnext; /* add trace entry */ tpush(nptr); /* evaluate the first expression */ if ((fun.n_ptr = xleval(fun.n_ptr)) == NULL) xlfail("null function"); /* evaluate the function */ switch (fun.n_ptr->n_type) { case SUBR: val = (*fun.n_ptr->n_subr)(args.n_ptr); break; case LIST: val = evfun(fun.n_ptr,args.n_ptr); break; case OBJ: val = xlsend(fun.n_ptr,args.n_ptr); break; default: xlfail("bad function"); } /* restore the previous stack frame */ xlstack = oldstk; /* remove trace entry */ tpop(); /* return the result value */ return (val); } /* evsym - evaluate a symbol */ static struct node *evsym(sym) struct node *sym; { struct node *lptr; /* check for a current object */ if ((lptr = xlobsym(sym)) != NULL) return (lptr->n_listvalue); else return (sym->n_symvalue); } /* evfun - evaluate a function */ static struct node *evfun(fun,args) struct node *fun,*args; { struct node *oldenv,*oldstk,cptr,*fargs,*val; /* create a stack frame */ oldstk = xlsave(&cptr,NULL); /* get the formal argument list */ if ((fargs = fun->n_listvalue) != NULL && fargs->n_type != LIST) xlfail("bad formal argument list"); /* bind the formal parameters */ oldenv = xlenv; xlabind(fargs,args); xlfixbindings(oldenv); /* execute the code */ for (cptr.n_ptr = fun->n_listnext; cptr.n_ptr != NULL; ) val = xlevarg(&cptr.n_ptr); /* restore the environment */ xlunbind(oldenv); /* restore the previous stack frame */ xlstack = oldstk; /* return the result value */ return (val); } /* xlabind - bind the arguments for a function */ xlabind(fargs,aargs) struct node *fargs,*aargs; { struct node *oldstk,farg,aarg,val; /* create a stack frame */ oldstk = xlsave(&farg,&aarg,&val,NULL); /* initialize the pointers */ farg.n_ptr = fargs; aarg.n_ptr = aargs; /* evaluate and bind each argument */ while (farg.n_ptr != NULL && aarg.n_ptr != NULL) { /* check for local variable separator */ if (farg.n_ptr->n_listvalue == slash) break; /* evaluate the argument */ val.n_ptr = xlevarg(&aarg.n_ptr); /* bind the formal variable to the argument value */ xlbind(farg.n_ptr->n_listvalue,val.n_ptr); /* move the formal argument list pointer ahead */ farg.n_ptr = farg.n_ptr->n_listnext; } /* check for local variables */ if (farg.n_ptr != NULL && farg.n_ptr->n_listvalue == slash) while ((farg.n_ptr = farg.n_ptr->n_listnext) != NULL) xlbind(farg.n_ptr->n_listvalue,NULL); /* restore the previous stack frame */ xlstack = oldstk; /* make sure the correct number of arguments were supplied */ if (farg.n_ptr != aarg.n_ptr) xlfail("incorrect number of arguments to a function"); } /* xlfail - error handling routine */ xlfail(err) char *err; { /* print the error message */ printf("error: %s\n",err); /* unbind bound symbols */ xlunbind(NULL); /* restore input to the terminal */ xltin(TRUE); /* do the back trace */ trace(); trace_pointer = -1; /* restart */ longjmp(xljmpbuf,1); } /* tpush - add an entry to the trace stack */ static tpush(nptr) struct node *nptr; { if (++trace_pointer < TDEPTH) trace_stack[trace_pointer] = nptr; } /* tpop - pop an entry from the trace stack */ static tpop() { trace_pointer--; } /* trace - do a back trace */ static trace() { for (; trace_pointer >= 0; trace_pointer--) if (trace_pointer < TDEPTH) { xlprint(trace_stack[trace_pointer],TRUE); putchar('\n'); } } /* xleinit - initialize the evaluator */ xleinit() { /* enter the local variable separator symbol */ slash = xlenter("/"); /* initialize debugging stuff */ trace_pointer = -1; /* builtin functions */ xlsubr("eval",eval); }