/* xlexpandmacros - expand macros in a form */ LVAL xlexpandmacros(LVAL form) { LVAL fun,args; /* protect some pointers */ xlstkcheck(3); xlprotect(form); xlsave(fun); xlsave(args); /* expand until the form isn't a macro call */ while (consp(form)) { fun = car(form); /* get the macro name */ args = cdr(form); /* get the arguments */ if (!symbolp(fun) || !fboundp(fun)) break; fun = xlgetfunction(fun); /* get the expansion function */ if (!macroexpand(fun,args,&form)) break; } /* restore the stack and return the expansion */ xlpopn(3); return (form); }
/* x1macroexpand - expand a macro call */ LVAL x1macroexpand(void) { LVAL form,fun,args; /* protect some pointers */ xlstkcheck(2); xlsave(fun); xlsave(args); /* get the form */ form = xlgetarg(); xllastarg(); /* expand until the form isn't a macro call */ if (consp(form)) { fun = car(form); /* get the macro name */ args = cdr(form); /* get the arguments */ if (symbolp(fun) && fboundp(fun)) { fun = xlgetfunction(fun); /* get the expansion function */ macroexpand(fun,args,&form); } } /* restore the stack and return the expansion */ xlpopn(2); return (form); }
/* xfunction - special form 'function' */ LVAL xfunction(V) { LVAL val; /* get the argument */ val = xlgetarg(); xllastarg(); /* create a closure for lambda expressions */ if (consp(val) && car(val) == s_lambda && consp(cdr(val))) val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv); /* otherwise, get the value of a symbol */ else if (symbolp(val)) val = xlgetfunction(val); /* otherwise, its an error */ else xlerror("not a function",val); /* return the function */ return (val); }
/* evform - evaluate a form */ LOCAL LVAL evform(LVAL form) { LVAL fun,args,val,type; LVAL tracing=NIL; LVAL *argv; LVAL old_profile_fixnum = profile_fixnum; FIXTYPE *old_profile_count_ptr = profile_count_ptr; LVAL funname; int argc; /* protect some pointers */ xlstkcheck(2); xlsave(fun); xlsave(args); (*profile_count_ptr)++; /* increment profile counter */ /* get the function and the argument list */ fun = car(form); args = cdr(form); funname = fun; /* get the functional value of symbols */ if (symbolp(fun)) { if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist))) tracing = fun; fun = xlgetfunction(fun); } /* check for nil */ if (null(fun)) xlerror("bad function",NIL); /* dispatch on node type */ switch (ntype(fun)) { case SUBR: argv = xlargv; argc = xlargc; xlargc = evpushargs(fun,args); xlargv = xlfp + 3; trenter(tracing,xlargc,xlargv); val = (*getsubr(fun))(); trexit(tracing,val); xlsp = xlfp; xlfp = xlfp - (int)getfixnum(*xlfp); xlargv = argv; xlargc = argc; break; case FSUBR: argv = xlargv; argc = xlargc; xlargc = pushargs(fun,args); xlargv = xlfp + 3; val = (*getsubr(fun))(); xlsp = xlfp; xlfp = xlfp - (int)getfixnum(*xlfp); xlargv = argv; xlargc = argc; break; case CONS: if (!consp(cdr(fun))) xlerror("bad function",fun); if ((type = car(fun)) == s_lambda) fun = xlclose(NIL, s_lambda, car(cdr(fun)), cdr(cdr(fun)), xlenv,xlfenv); else xlerror("bad function",fun); /**** fall through into the next case ****/ case CLOSURE: /* do profiling */ if (profile_flag && atomp(funname)) { LVAL profile_prop = findprop(funname, s_profile); if (null(profile_prop)) { /* make a new fixnum, don't use cvfixnum because it would return shared pointer to zero, but we are going to modify this integer in place -- dangerous but efficient. */ profile_fixnum = newnode(FIXNUM); profile_fixnum->n_fixnum = 0; setplist(funname, cons(s_profile, cons(profile_fixnum, getplist(funname)))); setvalue(s_profile, cons(funname, getvalue(s_profile))); } else profile_fixnum = car(profile_prop); profile_count_ptr = &getfixnum(profile_fixnum); } if (gettype(fun) == s_lambda) { argc = evpushargs(fun,args); argv = xlfp + 3; trenter(tracing,argc,argv); val = evfun(fun,argc,argv); trexit(tracing,val); xlsp = xlfp; xlfp = xlfp - (int)getfixnum(*xlfp); } else { macroexpand(fun,args,&fun); val = xleval(fun); } profile_fixnum = old_profile_fixnum; profile_count_ptr = old_profile_count_ptr; break; default: xlerror("bad function",fun); } /* restore the stack */ xlpopn(2); /* return the result value */ return (val); }