/* xcomplement - create a complementary function */ LVAL xcomplement(V) { LVAL val; LVAL args, body; LVAL newxlenv; /* protect some pointers */ xlstkcheck(3); xlsave(newxlenv); xlsave(args); xlsave(body); /* get the argument */ val = xlgetarg(); xllastarg(); /* build the argument list (&rest x) */ args = cons(lk_rest, consa(s_x)); /* build body (not (apply s x)) */ body = consa(cons(s_not, consa(cons(s_apply, cons(s_s, consa(s_x)))))); /* create a closure for lambda expressions */ newxlenv = xlframe(newxlenv); xlpbind(s_s, val, newxlenv); val = xlclose(NIL,s_lambda,args,body,newxlenv,NIL); /* unprotect pointers */ xlpopn(3); /* return the function */ return (val); }
/* 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); }
/* clanswer - define a method for answering a message */ LVAL clanswer(void) { LVAL self,msg,fargs,code,mptr; /* message symbol, formal argument list and code */ self = xlgaobject(); msg = xlgasymbol(); fargs = xlgalist(); code = xlgalist(); xllastarg(); /* make a new message list entry */ mptr = entermsg(self,msg); /* setup the message node */ xlprot1(fargs); fargs = cons(s_self,fargs); /* add 'self' as the first argument */ rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL)); xlpop(); /* return the object */ return (self); }
/* xlapply - apply a function to arguments (already on the stack) */ LVAL xlapply(int argc) { LVAL *oldargv,fun,val; LVAL funname; LVAL old_profile_fixnum = profile_fixnum; FIXTYPE *old_profile_count_ptr = profile_count_ptr; int oldargc; /* get the function */ fun = xlfp[1]; /* get the functional value of symbols */ if (symbolp(fun)) { funname = fun; /* save it */ while ((val = getfunction(fun)) == s_unbound) xlfunbound(fun); fun = xlfp[1] = val; 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); } } /* check for nil */ if (null(fun)) xlerror("bad function",fun); /* dispatch on node type */ switch (ntype(fun)) { case SUBR: oldargc = xlargc; oldargv = xlargv; xlargc = argc; xlargv = xlfp + 3; val = (*getsubr(fun))(); xlargc = oldargc; xlargv = oldargv; break; case CONS: if (!consp(cdr(fun))) xlerror("bad function",fun); if (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: if (gettype(fun) != s_lambda) xlerror("bad function",fun); val = evfun(fun,argc,xlfp+3); break; default: xlerror("bad function",fun); } /* restore original profile counting state */ profile_fixnum = old_profile_fixnum; profile_count_ptr = old_profile_count_ptr; /* remove the call frame */ xlsp = xlfp; xlfp = xlfp - (int)getfixnum(*xlfp); /* return the function value */ 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); }