/* xlapply - apply a function to a list of arguments */ NODE *xlapply(NODE *fun,NODE *args) { NODE *env,*val; val = 0; //BUG: uninitialized variable is used if xlfail returns /* check for a null function */ if (fun == NIL) xlfail("bad function"); /* evaluate the function */ if (subrp(fun)) val = (*getsubr(fun))(args); else if (consp(fun)) { if (consp(car(fun))) { env = cdr(fun); fun = car(fun); } else env = xlenv; if (car(fun) != s_lambda) xlfail("bad function type"); val = evfun(fun,args,env); } else xlfail("bad function"); /* return the result value */ return (val); }
/* xsendmsg - send a message to an object */ LOCAL LVAL xsendmsg(LVAL obj, LVAL cls, LVAL sym) { LVAL msg=NULL,msgcls,method,val,p; /* look for the message in the class or superclasses */ for (msgcls = cls; msgcls; ) { /* lookup the message in this class */ for (p = getivar(msgcls,MESSAGES); p; p = cdr(p)) if ((msg = car(p)) && car(msg) == sym) goto send_message; /* look in class's superclass */ msgcls = getivar(msgcls,SUPERCLASS); } /* message not found */ xlerror("no method for this message",sym); send_message: /* insert the value for 'self' (overwrites message selector) */ *--xlargv = obj; ++xlargc; /* invoke the method */ if ((method = cdr(msg)) == NULL) xlerror("bad method",method); switch (ntype(method)) { case SUBR: val = (*getsubr(method))(); break; case CLOSURE: if (gettype(method) != s_lambda) xlerror("bad method",method); val = evmethod(obj,msgcls,method); break; default: xlerror("bad method",method); } /* after creating an object, send it the ":isnew" message */ if (car(msg) == k_new && val) { xlprot1(val); xsendmsg(val,getclass(val),k_isnew); xlpop(); } /* return the result value */ return (val); }
/* evform - evaluate a form */ LOCAL NODE *evform(NODE *expr) { NODE ***oldstk,*fun __HEAPIFY,*args __HEAPIFY,*env,*val,*type; val = 0; //BUG: uninitialized variable is used if xlfail returns /* create a stack frame */ oldstk = xlsave2(&fun,&args); /* get the function and the argument list */ fun = car(expr); args = cdr(expr); /* evaluate the first expression */ if ((fun = xleval(fun)) == NIL) xlfail("bad function"); /* evaluate the function */ if (subrp(fun) || fsubrp(fun)) { if (subrp(fun)) args = xlevlist(args); val = (*getsubr(fun))(args); } else if (consp(fun)) { if (consp(car(fun))) { env = cdr(fun); fun = car(fun); } else env = xlenv; if ((type = car(fun)) == s_lambda) { args = xlevlist(args); val = evfun(fun,args,env); } else if (type == s_macro) { args = evfun(fun,args,env); val = xleval(args); } else xlfail("bad function type"); } else if (objectp(fun)) val = xlsend(fun,args); else xlfail("bad function"); /* restore the previous stack frame */ xlstack = oldstk; /* return the result value */ return (val); }
// Copy a node (recursively if appropriate) LOCAL LVAL nyx_dup_value(LVAL val) { LVAL nval = val; // Protect old and new values xlprot1(val); xlprot1(nval); // Copy the node if (val != NIL) { switch (ntype(val)) { case FIXNUM: nval = cvfixnum(getfixnum(val)); break; case FLONUM: nval = cvflonum(getflonum(val)); break; case CHAR: nval = cvchar(getchcode(val)); break; case STRING: nval = cvstring((char *) getstring(val)); break; case VECTOR: { int len = getsize(val); int i; nval = newvector(len); nval->n_type = ntype(val); for (i = 0; i < len; i++) { if (getelement(val, i) == val) { setelement(nval, i, val); } else { setelement(nval, i, nyx_dup_value(getelement(val, i))); } } } break; case CONS: nval = nyx_dup_value(cdr(val)); nval = cons(nyx_dup_value(car(val)), nval); break; case SUBR: case FSUBR: nval = cvsubr(getsubr(val), ntype(val), getoffset(val)); break; // Symbols should never be copied since their addresses are cached // all over the place. case SYMBOL: nval = val; break; // Streams are not copied (although USTREAM could be) and reference // the original value. case USTREAM: case STREAM: nval = val; break; // Externals aren't copied because I'm not entirely certain they can be. case EXTERN: nval = val; break; // For all other types, just allow them to reference the original // value. Probably not the right thing to do, but easier. case OBJECT: case CLOSURE: default: nval = val; break; } } xlpop(); xlpop(); return nval; }
/* 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); }