[Rd] Speed improvement to evalList

[Radford Neal]

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;
}