/* xlputprop - put a property value onto the property list */ void xlputprop(LVAL sym, LVAL val, LVAL prp) { LVAL pair; if ((pair = findprop(sym,prp))) rplaca(pair,val); else setplist(sym,cons(prp,cons(val,getplist(sym)))); }
// Restore the symbol values to their original value and remove any added // symbols. LOCAL void nyx_restore_obarray() { LVAL obvec = getvalue(obarray); int i; // Scan all obarray vectors for (i = 0; i < HSIZE; i++) { LVAL last = NULL; LVAL dcon; // Scan all elements for (dcon = getelement(obvec, i); dcon; dcon = cdr(dcon)) { LVAL dsym = car(dcon); char *name = (char *)getstring(getpname(dsym)); LVAL scon; // Ignore *OBARRAY* since setting it causes the input array to be // truncated. if (strcmp(name, "*OBARRAY*") == 0) { continue; } // Ignore *SCRATCH* since it's allowed to be updated if (strcmp(name, "*SCRATCH*") == 0) { continue; } // Find the symbol in the original obarray. for (scon = getelement(nyx_obarray, hash(name, HSIZE)); scon; scon = cdr(scon)) { LVAL ssym = car(scon); // If found, then set the current symbols value to the original. if (strcmp(name, (char *)getstring(getpname(ssym))) == 0) { setvalue(dsym, nyx_dup_value(getvalue(ssym))); setplist(dsym, nyx_dup_value(getplist(ssym))); setfunction(dsym, nyx_dup_value(getfunction(ssym))); break; } } // If we didn't find the symbol in the original obarray, then it must've // been added and must be removed from the current obarray. if (scon == NULL) { if (last) { rplacd(last, cdr(dcon)); } else { setelement(obvec, i, cdr(dcon)); } } // Must track the last dcon for symbol removal last = dcon; } } }
/* xlputprop - put a property value onto the property list */ void xlputprop(NODE *sym,NODE *val,NODE *prp) { NODE ***oldstk,*p __HEAPIFY,*pair; if ((pair = findprop(sym,prp)) == NIL) { oldstk = xlsave1(&p); p = consa(prp); rplacd(p,pair = cons(val,getplist(sym))); setplist(sym,p); xlstack = oldstk; } rplaca(pair,val); }
/* xlremprop - remove a property from a property list */ void xlremprop(NODE *sym,NODE *prp) { NODE *last,*p; last = NIL; for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) { if (car(p) == prp) if (last) rplacd(last,cdr(cdr(p))); else setplist(sym,cdr(cdr(p))); last = cdr(p); } }
/* xlremprop - remove a property from a property list */ void xlremprop(LVAL sym, LVAL prp) { LVAL last,p; last = NIL; for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) { if (car(p) == prp) { if (last) rplacd(last,cdr(cdr(p))); else setplist(sym,cdr(cdr(p))); } last = cdr(p); } }
// Make a copy of the original obarray, leaving the original in place LOCAL void nyx_save_obarray() { LVAL newarray; int i; // This provide permanent protection for nyx_obarray as we do not want it // to be garbage-collected. xlprot1(nyx_obarray); nyx_obarray = getvalue(obarray); // Create and set the new vector. This allows us to use xlenter() to // properly add the new symbol. Probably slower than adding directly, // but guarantees proper hashing. newarray = newvector(HSIZE); setvalue(obarray, newarray); // Scan all obarray vectors for (i = 0; i < HSIZE; i++) { LVAL sym; // Scan all elements for (sym = getelement(nyx_obarray, i); sym; sym = cdr(sym)) { LVAL syma = car(sym); char *name = (char *) getstring(getpname(syma)); LVAL nsym = xlenter(name); // Ignore *OBARRAY* since there's no need to copy it if (strcmp(name, "*OBARRAY*") == 0) { continue; } // Ignore *SCRATCH* since it's allowed to be updated if (strcmp(name, "*SCRATCH*") == 0) { continue; } // Duplicate the symbol's values setvalue(nsym, nyx_dup_value(getvalue(syma))); setplist(nsym, nyx_dup_value(getplist(syma))); setfunction(nsym, nyx_dup_value(getfunction(syma))); } } // Swap the obarrays, so that the original is put back into service setvalue(obarray, nyx_obarray); nyx_obarray = newarray; }
/* 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); }