Regarding my suggesting speed improvement to evalList, Martin Morgan
has commented by email to me that at one point an object is left
unprotected when COPY_TAG is called, and has wondered whether that is
safe. I think it is safe, but the code can be changed to protect this
as well, which actually simplifies things, and could be more robust to
changes to the garbage collector. The cost is that sometimes there is
one more call of PROTECT and UNPROTECT, but with the speed improvement
to these that I just posted, this is a minor issue.
Martin has also pointed me to where you can get R sources via
subversion, but while I figure that out, and how to post up "diffs"
for changes, I'll put the revised evalList code below for anyone
interested...
Radford Neal
----------------------------------------------------------------------
/* Used in eval and applyMethod (object.c) for builtin primitives,
do_internal (names.c) for builtin .Internals
and in evalArgs.
'n' is the number of arguments already evaluated and hence not
passed to evalArgs and hence to here.
*/
SEXP attribute_hidden evalList(SEXP el, SEXP rho, SEXP call, int n)
{
SEXP head, tail, ev, h;
head = R_NilValue;
while (el != R_NilValue) {
n++;
if (CAR(el) == R_DotsSymbol) {
/* If we have a ... symbol, we look to see what it is bound to.
* If its binding is Null (i.e. zero length),
* we just ignore it and return the cdr with all its expressions
* evaluated.
* If it is bound to a ... list of promises,
* we force all the promises and then splice
* the list of resulting values into the return value.
* Anything else bound to a ... symbol is an error.
*/
h = findVar(CAR(el), rho);
if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
while (h != R_NilValue) {
ev = CONS(eval(CAR(h), rho), R_NilValue);
if (head==R_NilValue)
PROTECT(head = ev);
else
SETCDR(tail, ev);
COPY_TAG(ev, h);
tail = ev;
h = CDR(h);
}
}
else if (h != R_MissingArg)
error(_("'...' used in an incorrect context"));
} else if (CAR(el) == R_MissingArg) {
/* It was an empty element: most likely get here from evalArgs
which may have been called on part of the args. */
errorcall(call, _("argument %d is empty"), n);
} else if (isSymbol(CAR(el)) && R_isMissing(CAR(el), rho)) {
/* It was missing */
errorcall(call, _("'%s' is missing"), CHAR(PRINTNAME(CAR(el))));
} else {
ev = CONS(eval(CAR(el), rho), R_NilValue);
if (head==R_NilValue)
PROTECT(head = ev);
else
SETCDR(tail, ev);
COPY_TAG(ev, el);
tail = ev;
}
el = CDR(el);
}
if (head!=R_NilValue)
UNPROTECT(1);
return head;
} /* evalList() */
/* A slight variation of evaluating each expression in "el" in "rho". */
/* used in evalArgs, arithmetic.c, seq.c */
SEXP attribute_hidden evalListKeepMissing(SEXP el, SEXP rho)
{
SEXP head, tail, ev, h;
head = R_NilValue;
while (el != R_NilValue) {
/* If we have a ... symbol, we look to see what it is bound to.
* If its binding is Null (i.e. zero length)
* we just ignore it and return the cdr with all its expressions
evaluated;
* if it is bound to a ... list of promises,
* we force all the promises and then splice
* the list of resulting values into the return value.
* Anything else bound to a ... symbol is an error
*/
if (CAR(el) == R_DotsSymbol) {
h = findVar(CAR(el), rho);
if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
while (h != R_NilValue) {
if (CAR(h) == R_MissingArg)
ev = CONS(R_MissingArg, R_NilValue);
else
ev = CONS(eval(CAR(h), rho), R_NilValue);
if (head==R_NilValue)
PROTECT(head = ev);
else
SETCDR(tail, ev);
COPY_TAG(ev, h);
tail = ev;
h = CDR(h);
}
}
else if(h != R_MissingArg)
error(_("'...' used in an incorrect context"));
}
else {
if (CAR(el) == R_MissingArg ||
(isSymbol(CAR(el)) && R_isMissing(CAR(el), rho)))
ev = CONS(R_MissingArg, R_NilValue);
else
ev = CONS(eval(CAR(el), rho), R_NilValue);
if (head==R_NilValue)
PROTECT(head = ev);
else
SETCDR(tail, ev);
COPY_TAG(ev, el);
tail = ev;
}
el = CDR(el);
}
if (head!=R_NilValue)
UNPROTECT(1);
return head;
}
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
