Commit eecdb1fa authored by Radford Neal's avatar Radford Neal

change applyClosure_v interfact to avoid creating pairlists needlessly

parent 7e338188
......@@ -1685,8 +1685,8 @@ SEXP Rf_allocVector1REAL(void);
SEXP Rf_reallocVector(SEXP, R_len_t);
int Rf_any_duplicated(SEXP x, Rboolean from_last);
int Rf_any_duplicated3(SEXP x, SEXP incomp, Rboolean from_last);
SEXP Rf_applyClosure(SEXP, SEXP, SEXP, SEXP, SEXP);
SEXP Rf_applyClosure_v(SEXP, SEXP, SEXP, SEXP, SEXP, int);
SEXP Rf_applyClosure(SEXP, SEXP, SEXP, SEXP, SEXP *);
SEXP Rf_applyClosure_v(SEXP, SEXP, SEXP, SEXP, SEXP *, int);
SEXP Rf_arraySubscript(int, SEXP, SEXP, SEXP (*)(SEXP,SEXP),
SEXP (*)(SEXP, int), SEXP);
SEXP Rf_classgets(SEXP, SEXP);
......
......@@ -1141,7 +1141,7 @@ static SEXP do_bind(SEXP call, SEXP op, SEXP args, SEXP env)
}
if (method != R_NilValue) {
PROTECT(method);
args = applyClosure(call, method, args, env, R_NoObject);
args = applyClosure(call, method, args, env, NULL);
UNPROTECT(2);
return args;
}
......
......@@ -599,7 +599,7 @@ SEXP attribute_hidden Rf_evalv2(SEXP e, SEXP rho, int variant)
if (TYPEOF(op) == CLOSXP) {
PROTECT(op);
res = applyClosure_v (e, op, promiseArgs(args,rho), rho,
R_NoObject, variant);
NULL, variant);
UNPROTECT(1);
}
else {
......@@ -955,8 +955,12 @@ static void start_browser (SEXP call, SEXP op, SEXP stmt, SEXP env)
do_browser(call, op, R_NilValue, env);
}
/* 'supplied' is an array of SEXP values, first a set of pairs of tag and
value, then a pairlist of tagged values (or R_NilValue). If NULL, no
extras supplied. */
SEXP attribute_hidden applyClosure_v(SEXP call, SEXP op, SEXP arglist, SEXP rho,
SEXP suppliedenv, int variant)
SEXP *supplied, int variant)
{
int vrnt = VARIANT_PENDING_OK | VARIANT_DIRECT_RETURN
| VARIANT_PASS_ON(variant);
......@@ -1020,8 +1024,12 @@ SEXP attribute_hidden applyClosure_v(SEXP call, SEXP op, SEXP arglist, SEXP rho,
/* Fix up any extras that were supplied by usemethod. */
if (suppliedenv != R_NoObject) {
for (SEXP t = FRAME(suppliedenv); t != R_NilValue; t = CDR(t)) {
if (supplied != NULL) {
while (TYPEOF(*supplied) == SYMSXP) {
set_var_in_frame (*supplied, *(supplied+1), newrho, TRUE, 3);
supplied += 2;
}
for (SEXP t = *supplied; t != R_NilValue; t = CDR(t)) {
for (a = actuals; a != R_NilValue; a = CDR(a))
if (TAG(a) == TAG(t))
break;
......@@ -1120,9 +1128,10 @@ SEXP attribute_hidden applyClosure_v(SEXP call, SEXP op, SEXP arglist, SEXP rho,
}
SEXP applyClosure (SEXP call, SEXP op, SEXP arglist, SEXP rho,
SEXP suppliedenv)
SEXP *supplied)
{
return applyClosure_v (call, op, arglist, rho, suppliedenv, 0);
if (supplied != NULL) error("Last argument to applyClosure must be NULL");
return applyClosure_v (call, op, arglist, rho, NULL, 0);
}
/* **** FIXME: This code is factored out of applyClosure. If we keep
......@@ -3266,7 +3275,7 @@ static SEXP do_recall(SEXP call, SEXP op, SEXP args, SEXP rho)
PROTECT(s = eval(CAR(cptr->call), cptr->sysparent));
if (TYPEOF(s) != CLOSXP)
error(_("'Recall' called from outside a closure"));
ans = applyClosure_v(cptr->call, s, args, cptr->sysparent, R_NoObject, 0);
ans = applyClosure_v(cptr->call, s, args, cptr->sysparent, NULL, 0);
UNPROTECT(1);
return ans;
}
......@@ -3521,8 +3530,8 @@ attribute_hidden
int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
SEXP *ans)
{
int i, j, nargs, lwhich, rwhich, set;
SEXP lclass, s, t, m, lmeth, lsxp, lgr, newrho;
int nargs, lwhich, rwhich, set;
SEXP lclass, s, t, m, lmeth, lsxp, lgr;
SEXP rclass, rmeth, rgr, rsxp, value;
char *generic;
Rboolean useS4 = TRUE, isOps = FALSE;
......@@ -3661,7 +3670,8 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
/* we either have a group method or a class method */
PROTECT(newrho = allocSExp(ENVSXP));
int i, j;
PROTECT(m = allocVector(STRSXP,nargs));
s = args;
for (i = 0 ; i < nargs ; i++) {
......@@ -3683,18 +3693,26 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
s = CDR(s);
}
defineVar(R_dot_Method, m, newrho);
UNPROTECT(1);
PROTECT(t = mkString(generic));
defineVar(R_dot_Generic, t, newrho);
UNPROTECT(1);
defineVar(R_dot_Group, lgr, newrho);
SEXP genstr = PROTECT(mkString(generic));
set = length(lclass) - lwhich;
t = allocVector(STRSXP, set);
PROTECT(t = allocVector(STRSXP, set));
copy_string_elements (t, 0, lclass, lwhich, set);
defineVar(R_dot_Class, t, newrho);
defineVar(R_dot_GenericCallEnv, rho, newrho);
defineVar(R_dot_GenericDefEnv, R_BaseEnv, newrho);
SEXP supplied[13];
supplied[0] = R_NilValue;
i = 0;
supplied[i++] = R_dot_Class; supplied[i++] = t;
supplied[i++] = R_dot_Generic; supplied[i++] = genstr;
supplied[i++] = R_dot_Method; supplied[i++] = m;
supplied[i++] = R_dot_GenericCallEnv; supplied[i++] = rho;
supplied[i++] = R_dot_GenericDefEnv; supplied[i++] = R_BaseEnv;
supplied[i++] = R_dot_Group; supplied[i++] = lgr;
supplied[i] = R_NilValue;
PROTECT(t = LCONS(lmeth, CDR(call)));
......@@ -3709,8 +3727,9 @@ int DispatchGroup(const char* group, SEXP call, SEXP op, SEXP args, SEXP rho,
SET_TAG(m, R_NilValue);
}
*ans = applyClosure_v(t, lsxp, s, rho, newrho, 0);
UNPROTECT(7);
*ans = applyClosure_v (t, lsxp, s, rho, supplied, 0);
UNPROTECT(9);
return 1;
}
......@@ -5490,7 +5509,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
if (flag < 2) R_Visible = flag != 1;
break;
case CLOSXP:
value = applyClosure_v(call, fun, args, rho, R_NoObject, 0);
value = applyClosure_v(call, fun, args, rho, NULL, 0);
break;
default: bad_function_error();
}
......@@ -5834,7 +5853,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
args = GETSTACK(-2);
SETCAR(args, prom);
/* make the call */
value = applyClosure_v(call, fun, args, rho, R_NoObject, 0);
value = applyClosure_v(call, fun, args, rho, NULL, 0);
break;
default: bad_function_error();
}
......@@ -5878,7 +5897,7 @@ static SEXP bcEval(SEXP body, SEXP rho, Rboolean useCache)
args = GETSTACK(-2);
SETCAR(args, prom);
/* make the call */
value = applyClosure_v(call, fun, args, rho, R_NoObject, 0);
value = applyClosure_v(call, fun, args, rho, NULL, 0);
break;
default: bad_function_error();
}
......
......@@ -107,8 +107,8 @@ static SEXP GetObject(RCNTXT *cptr)
return(s);
}
static SEXP applyMethod (SEXP call, SEXP op, SEXP args, SEXP rho, SEXP newrho,
int variant)
static SEXP applyMethod (SEXP call, SEXP op, SEXP args, SEXP rho,
SEXP *supplied, int variant)
{
SEXP ans;
......@@ -144,7 +144,7 @@ static SEXP applyMethod (SEXP call, SEXP op, SEXP args, SEXP rho, SEXP newrho,
VMAXSET(vmax);
}
else if (TYPEOF(op) == CLOSXP) {
ans = applyClosure_v(call, op, args, rho, newrho, variant);
ans = applyClosure_v(call, op, args, rho, supplied, variant);
}
else
ans = R_NilValue; /* for -Wall */
......@@ -332,13 +332,16 @@ found: ;
if (RDEBUG(op) || RSTEP(op)) SET_RSTEP(sxp, 1);
SEXP newrho = R_NilValue; /* not used for primitives */
SEXP supplied[11];
supplied[0] = R_NilValue;
int nprotect = 0;
if (TYPEOF(sxp) == CLOSXP) {
SEXP genstr, methstr;
PROTECT(genstr = mkString(generic));
PROTECT(methstr = ScalarString(PRINTNAME(method)));
nprotect += 2;
SEXP bindings = R_NilValue;
......@@ -364,25 +367,25 @@ found: ;
bindings = cons_with_tag (CAR(s), bindings, TAG(s));
next: ;
}
PROTECT(bindings);
nprotect += 1;
}
bindings = cons_with_tag (setcl, bindings, R_dot_Class);
bindings = cons_with_tag (genstr, bindings, R_dot_Generic);
bindings = cons_with_tag (methstr, bindings, R_dot_Method);
bindings = cons_with_tag (callrho, bindings, R_dot_GenericCallEnv);
bindings = cons_with_tag (defrho, bindings, R_dot_GenericDefEnv);
int i = 0;
newrho = NewEnvironment (R_NilValue, bindings, R_NilValue);
supplied[i++] = R_dot_Class; supplied[i++] = setcl;
supplied[i++] = R_dot_Generic; supplied[i++] = genstr;
supplied[i++] = R_dot_Method; supplied[i++] = methstr;
supplied[i++] = R_dot_GenericCallEnv; supplied[i++] = callrho;
supplied[i++] = R_dot_GenericDefEnv; supplied[i++] = defrho;
UNPROTECT(2);
supplied[i] = bindings;
}
PROTECT(newrho);
*ans = applyMethod(newcall, sxp, matchedarg, rho, newrho, variant);
*ans = applyMethod(newcall, sxp, matchedarg, rho, supplied, variant);
R_GlobalContext->callflag = CTXT_RETURN;
UNPROTECT(6);
UNPROTECT(nprotect+5);
return 1;
}
......@@ -811,7 +814,9 @@ static SEXP do_nextmethod (SEXP call, SEXP op, SEXP args, SEXP env,
}
PROTECT(nextfun);
SEXP m = R_NilValue; /* m not used for primitives */
SEXP supplied[13];
supplied[0] = R_NilValue;
int nprotect = 0;
if (TYPEOF(nextfun) == CLOSXP) {
......@@ -832,25 +837,26 @@ static SEXP do_nextmethod (SEXP call, SEXP op, SEXP args, SEXP env,
} else
PROTECT(method = mkString(buf));
SEXP bindings = R_NilValue;
bindings = cons_with_tag (s, bindings, R_dot_Class);
bindings = cons_with_tag (method, bindings, R_dot_Method);
bindings = cons_with_tag (callenv, bindings, R_dot_GenericCallEnv);
bindings = cons_with_tag (defenv, bindings, R_dot_GenericDefEnv);
bindings = cons_with_tag (generic, bindings, R_dot_Generic);
bindings = cons_with_tag (group, bindings, R_dot_Group);
m = NewEnvironment (R_NilValue, bindings, R_NilValue);
UNPROTECT(3);
nprotect = 3;
int i = 0;
supplied[i++] = R_dot_Class; supplied[i++] = s;
supplied[i++] = R_dot_Generic; supplied[i++] = generic;
supplied[i++] = R_dot_Method; supplied[i++] = method;
supplied[i++] = R_dot_GenericCallEnv; supplied[i++] = callenv;
supplied[i++] = R_dot_GenericDefEnv; supplied[i++] = defenv;
supplied[i++] = R_dot_Group; supplied[i++] = group;
supplied[i] = R_NilValue;
}
PROTECT(m);
SETCAR(newcall, install(buf));
ans = applyMethod(newcall, nextfun, matchedarg, env, m, variant);
ans = applyMethod(newcall, nextfun, matchedarg, env, supplied, variant);
UNPROTECT(8);
UNPROTECT(nprotect+7);
return(ans);
}
......@@ -1516,11 +1522,11 @@ R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,
/* found a method, call it with promised args */
if(!promisedArgs) {
PROTECT(s = promiseArgsWithValues(CDR(call), rho, args));
value = applyClosure(call, value, s, rho, R_NoObject);
value = applyClosure(call, value, s, rho, NULL);
UNPROTECT(1);
return value;
} else
return applyClosure(call, value, args, rho, R_NoObject);
return applyClosure(call, value, args, rho, NULL);
}
/* else, need to perform full method search */
}
......@@ -1532,10 +1538,10 @@ R_possible_dispatch(SEXP call, SEXP op, SEXP args, SEXP rho,
error in method search */
if(!promisedArgs) {
PROTECT(s = promiseArgsWithValues(CDR(call), rho, args));
value = applyClosure(call, fundef, s, rho, R_NoObject);
value = applyClosure(call, fundef, s, rho, NULL);
UNPROTECT(1);
} else
value = applyClosure(call, fundef, args, rho, R_NoObject);
value = applyClosure(call, fundef, args, rho, NULL);
prim_methods[offset] = current;
if(value == deferred_default_object)
return R_NoObject;
......
......@@ -1033,7 +1033,7 @@ static SEXP do_xtfrm(SEXP call, SEXP op, SEXP args, SEXP rho)
/* otherwise dispatch the default method */
PROTECT(fn = findFun(install("xtfrm.default"), rho));
PROTECT(prargs = promiseArgsWithValues(CDR(call), rho, args));
ans = applyClosure(call, fn, prargs, rho, R_NoObject);
ans = applyClosure(call, fn, prargs, rho, NULL);
UNPROTECT(2);
return ans;
......
......@@ -790,7 +790,7 @@ static SEXP do_range(SEXP call, SEXP op, SEXP args, SEXP env)
/* Below should really use CDR(call) for the unevaluated expressions,
but it can't because args has been fiddled with by fixup_NaRm. */
PROTECT(prargs = promiseArgsWithValues(args, R_EmptyEnv, args));
ans = applyClosure(call, op, prargs, env, R_NoObject);
ans = applyClosure(call, op, prargs, env, NULL);
UNPROTECT(3);
return(ans);
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment