/* Version of DispatchOrEval for "[" and friends that speeds up simple cases.
Also defined in subassign.c */
static R_INLINE
int R_DispatchOrEvalSP(SEXP call, SEXP op, const char *generic, SEXP args,
SEXP rho, SEXP *ans)
{
SEXP prom = NULL;
if (args != R_NilValue && CAR(args) != R_DotsSymbol) {
SEXP x = eval(CAR(args), rho);
PROTECT(x);
if (! OBJECT(x)) {
*ans = CONS_NR(x, evalListKeepMissing(CDR(args), rho));
UNPROTECT(1);
return FALSE;
}
prom = mkPROMISE(CAR(args), R_GlobalEnv);
SET_PRVALUE(prom, x);
args = CONS(prom, CDR(args));
UNPROTECT(1);
}
PROTECT(args);
int disp = DispatchOrEval(call, op, generic, args, rho, ans, 0, 0);
if (prom) DECREMENT_REFCNT(PRVALUE(prom));
UNPROTECT(1);
return disp;
}
SEXP attribute_hidden matchUnnamedArgsCreateEnv(SEXP formals, SEXP supplied, SEXP call, SEXP rho, SEXP* outActuals)
{
SEXP f, s;
SEXP actuals = PROTECT(supplied);
SEXP newrho = PROTECT(NewEnvironmentNR(rho));
SEXP prevS = R_NilValue;
for (f = formals, s = supplied ; f != R_NilValue ; f = CDR(f), prevS = s, s = CDR(s)) {
if (TAG(f) == R_DotsSymbol) {
/* pack all arguments into ... */
SEXP dots = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(dots, R_DotsSymbol);
if (prevS == R_NilValue) {
UNPROTECT(1); /* old actuals */
PROTECT(actuals = dots);
} else {
SETCDR(prevS, dots);
ENABLE_REFCNT(prevS); /* dots are part of a protected list */
}
if (s != R_NilValue) {
SET_TYPEOF(s, DOTSXP);
SETCAR(dots, s);
s = R_NilValue;
} else {
SET_MISSING(dots, 1);
}
prevS = dots;
f = CDR(f);
/* falls through into s == R_NilValue case */
}
if (s == R_NilValue) {
/* fewer supplied arguments than formals */
SEXP ds;
for(; f != R_NilValue ; f = CDR(f), prevS = ds) {
ds = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(ds, TAG(f));
if (prevS == R_NilValue) {
UNPROTECT(1); /* old actuals */
PROTECT(actuals = ds);
} else {
SETCDR(prevS, ds);
ENABLE_REFCNT(prevS); /* ds is part of a protected list */
}
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(ds, 2);
SETCAR(ds, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(ds, 1);
}
}
break;
}
/* normal case, the next supplied arg is available */
SET_TAG(s, TAG(f));
if (CAR(s) == R_MissingArg) {
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(s, 2);
SETCAR(s, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(s, 1);
}
}
if (prevS != R_NilValue) {
ENABLE_REFCNT(prevS);
}
}
if (s != R_NilValue) {
/* some arguments are not used */
SEXP unusedForError = PROTECT(s);
SETCDR(prevS, R_NilValue); /* make sure they're not in the new environment */
/* show bad arguments in call without evaluating them */
for (; s != R_NilValue; s = CDR(s)) {
SEXP carS = CAR(s);
if (TYPEOF(carS) == PROMSXP) {
SETCAR(s, PREXPR(carS));
}
}
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
UNPROTECT(1);
}
if (prevS != R_NilValue) {
ENABLE_REFCNT(prevS);
}
SET_FRAME(newrho, actuals);
ENABLE_REFCNT(newrho);
UNPROTECT(2); /* newrho, actuals */
*outActuals = actuals;
return(newrho);
}
SEXP attribute_hidden matchPositionalArgsCreateEnv(SEXP formals, SEXP *supplied, int nsupplied, SEXP call, SEXP rho, SEXP* outActuals)
{
SEXP *s;
SEXP f, a;
SEXP actuals = R_NilValue;
SEXP newrho = PROTECT(NewEnvironmentNR(rho));
SEXP *endSupplied = supplied + nsupplied;
for (f = formals, s = supplied, a = actuals ; f != R_NilValue ; f = CDR(f), s++) {
if (TAG(f) == R_DotsSymbol) {
/* pack all remaining arguments into ... */
SEXP *rs = endSupplied - 1;
SEXP dotsContent = R_NilValue;
for(; rs >= s; rs--) {
dotsContent = CONS(*rs, dotsContent); /* FIXME: enabling refcnt? */
}
SEXP dots = CONS_NR(dotsContent, R_NilValue);
SET_TAG(dots, R_DotsSymbol);
if (dotsContent != R_NilValue) {
SET_TYPEOF(dotsContent, DOTSXP);
} else {
SET_MISSING(dots, 1);
}
if (a == R_NilValue) {
PROTECT(actuals = dots);
} else {
SETCDR(a, dots);
ENABLE_REFCNT(a); /* dots are part of a protected list */
}
a = dots;
f = CDR(f);
s = endSupplied;
/* falls through into noMoreSupplied branch below */
}
if (s == endSupplied) {
/* possibly fewer supplied arguments than formals */
SEXP ds;
for(; f != R_NilValue ; f = CDR(f), a = ds) {
ds = CONS_NR(R_MissingArg, R_NilValue);
SET_TAG(ds, TAG(f));
if (a == R_NilValue) {
PROTECT(actuals = ds);
} else {
SETCDR(a, ds);
ENABLE_REFCNT(a); /* ds is part of a protected list */
}
SEXP fdefault = CAR(f);
if (fdefault != R_MissingArg) {
SET_MISSING(ds, 2);
SETCAR(ds, mkPROMISEorConst(fdefault, newrho));
} else {
SET_MISSING(ds, 1);
}
}
break;
}
/* normal case, the next supplied arg is available */
SEXP arg = CONS_NR(*s, R_NilValue);
SET_TAG(arg, TAG(f));
if (a == R_NilValue) {
PROTECT(actuals = arg);
} else {
SETCDR(a, arg);
ENABLE_REFCNT(a);
}
a = arg;
}
if (s < endSupplied) {
/* some arguments are not used */
SEXP *rs = endSupplied - 1;
SEXP unusedForError = R_NilValue;
for(; rs >= s; rs--) {
SEXP rsValue = *rs;
if (TYPEOF(rsValue) == PROMSXP) {
rsValue = PREXPR(rsValue);
}
unusedForError = CONS(rsValue, unusedForError);
}
PROTECT(unusedForError); /* needed? */
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
UNPROTECT(1);
}
if (a != R_NilValue) {
ENABLE_REFCNT(a);
}
SET_FRAME(newrho, actuals);
ENABLE_REFCNT(newrho);
UNPROTECT(1); /* newrho */
if (actuals != R_NilValue) {
UNPROTECT(1); /* actuals */
}
*outActuals = actuals;
return(newrho);
}
SEXP attribute_hidden matchArgs(SEXP formals, SEXP supplied, SEXP call)
{
int i, seendots, arg_i = 0;
SEXP f, a, b, dots, actuals;
actuals = R_NilValue;
for (f = formals ; f != R_NilValue ; f = CDR(f), arg_i++) {
/* CONS_NR is used since argument lists created here are only
used internally and so should not increment reference
counts */
actuals = CONS_NR(R_MissingArg, actuals);
SET_MISSING(actuals, 1);
}
/* We use fargused instead of ARGUSED/SET_ARGUSED on elements of
formals to avoid modification of the formals SEXPs. A gc can
cause matchArgs to be called from finalizer code, resulting in
another matchArgs call with the same formals. In R-2.10.x, this
corrupted the ARGUSED data of the formals and resulted in an
incorrect "formal argument 'foo' matched by multiple actual
arguments" error.
*/
int fargused[arg_i ? arg_i : 1]; // avoid undefined behaviour
memset(fargused, 0, sizeof(fargused));
for(b = supplied; b != R_NilValue; b = CDR(b)) SET_ARGUSED(b, 0);
PROTECT(actuals);
/* First pass: exact matches by tag */
/* Grab matched arguments and check */
/* for multiple exact matches. */
f = formals;
a = actuals;
arg_i = 0;
while (f != R_NilValue) {
if (TAG(f) != R_DotsSymbol) {
i = 1;
for (b = supplied; b != R_NilValue; b = CDR(b)) {
if (TAG(b) != R_NilValue && pmatch(TAG(f), TAG(b), 1)) {
if (fargused[arg_i] == 2)
error(_("formal argument \"%s\" matched by multiple actual arguments"),
CHAR(PRINTNAME(TAG(f))));
if (ARGUSED(b) == 2)
error(_("argument %d matches multiple formal arguments"), i);
SETCAR(a, CAR(b));
if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 2);
fargused[arg_i] = 2;
}
i++;
}
}
f = CDR(f);
a = CDR(a);
arg_i++;
}
/* Second pass: partial matches based on tags */
/* An exact match is required after first ... */
/* The location of the first ... is saved in "dots" */
dots = R_NilValue;
seendots = 0;
f = formals;
a = actuals;
arg_i = 0;
while (f != R_NilValue) {
if (fargused[arg_i] == 0) {
if (TAG(f) == R_DotsSymbol && !seendots) {
/* Record where ... value goes */
dots = a;
seendots = 1;
} else {
i = 1;
for (b = supplied; b != R_NilValue; b = CDR(b)) {
if (ARGUSED(b) != 2 && TAG(b) != R_NilValue &&
pmatch(TAG(f), TAG(b), seendots)) {
if (ARGUSED(b))
error(_("argument %d matches multiple formal arguments"), i);
if (fargused[arg_i] == 1)
error(_("formal argument \"%s\" matched by multiple actual arguments"),
CHAR(PRINTNAME(TAG(f))));
if (R_warn_partial_match_args) {
warningcall(call,
_("partial argument match of '%s' to '%s'"),
CHAR(PRINTNAME(TAG(b))),
CHAR(PRINTNAME(TAG(f))) );
}
SETCAR(a, CAR(b));
if (CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 1);
fargused[arg_i] = 1;
}
i++;
}
}
}
f = CDR(f);
a = CDR(a);
arg_i++;
}
/* Third pass: matches based on order */
/* All args specified in tag=value form */
/* have now been matched. If we find ... */
/* we gobble up all the remaining args. */
/* Otherwise we bind untagged values in */
/* order to any unmatched formals. */
f = formals;
a = actuals;
b = supplied;
seendots = 0;
while (f != R_NilValue && b != R_NilValue && !seendots) {
if (TAG(f) == R_DotsSymbol) {
/* Skip ... matching until all tags done */
seendots = 1;
f = CDR(f);
a = CDR(a);
} else if (CAR(a) != R_MissingArg) {
/* Already matched by tag */
/* skip to next formal */
f = CDR(f);
a = CDR(a);
} else if (ARGUSED(b) || TAG(b) != R_NilValue) {
/* This value used or tagged , skip to next value */
/* The second test above is needed because we */
/* shouldn't consider tagged values for positional */
/* matches. */
/* The formal being considered remains the same */
b = CDR(b);
} else {
/* We have a positional match */
SETCAR(a, CAR(b));
if(CAR(b) != R_MissingArg) SET_MISSING(a, 0);
SET_ARGUSED(b, 1);
b = CDR(b);
f = CDR(f);
a = CDR(a);
}
}
if (dots != R_NilValue) {
/* Gobble up all unused actuals */
SET_MISSING(dots, 0);
i = 0;
for(a = supplied; a != R_NilValue ; a = CDR(a)) if(!ARGUSED(a)) i++;
if (i) {
a = allocList(i);
SET_TYPEOF(a, DOTSXP);
f = a;
for(b = supplied; b != R_NilValue; b = CDR(b))
if(!ARGUSED(b)) {
SETCAR(f, CAR(b));
SET_TAG(f, TAG(b));
f = CDR(f);
}
SETCAR(dots, a);
}
} else {
/* Check that all arguments are used */
SEXP unused = R_NilValue, last = R_NilValue;
for (b = supplied; b != R_NilValue; b = CDR(b))
if (!ARGUSED(b)) {
if(last == R_NilValue) {
PROTECT(unused = CONS(CAR(b), R_NilValue));
SET_TAG(unused, TAG(b));
last = unused;
} else {
SETCDR(last, CONS(CAR(b), R_NilValue));
last = CDR(last);
SET_TAG(last, TAG(b));
}
}
if(last != R_NilValue) {
/* show bad arguments in call without evaluating them */
SEXP unusedForError = R_NilValue, last = R_NilValue;
for(b = unused ; b != R_NilValue ; b = CDR(b)) {
SEXP tagB = TAG(b), carB = CAR(b) ;
if (TYPEOF(carB) == PROMSXP) carB = PREXPR(carB) ;
if (last == R_NilValue) {
PROTECT(last = CONS(carB, R_NilValue));
SET_TAG(last, tagB);
unusedForError = last;
} else {
SETCDR(last, CONS(carB, R_NilValue));
last = CDR(last);
SET_TAG(last, tagB);
}
}
errorcall(call /* R_GlobalContext->call */,
ngettext("unused argument %s",
"unused arguments %s",
(unsigned long) length(unusedForError)),
CHAR(STRING_ELT(deparse1line(unusedForError, 0), 0)) + 4);
/* '+ 4' is to remove 'list' from 'list(badTag1,...)' */
}
}
UNPROTECT(1);
return(actuals);
}
