SEXP setOption(SEXP tag, SEXP value)
{
SEXP opt, old, t;
t = opt = SYMVALUE(Rf_install(".Options"));
if (!Rf_isList(opt))
Rf_error("corrupted options list");
opt = FindTaggedItem(opt, tag);
/* The option is being removed. */
if (value == R_NilValue) {
for ( ; t != R_NilValue ; t = CDR(t))
if (TAG(CDR(t)) == tag) {
old = CAR(t);
SETCDR(t, CDDR(t));
return old;
}
return R_NilValue;
}
/* If the option is new, a new slot */
/* is added to the end of .Options */
if (opt == R_NilValue) {
while (CDR(t) != R_NilValue)
t = CDR(t);
PROTECT(value);
SETCDR(t, Rf_allocList(1));
UNPROTECT(1);
opt = CDR(t);
SET_TAG(opt, tag);
}
old = CAR(opt);
SETCAR(opt, value);
return old;
}
/* Expand dots in args, but do not evaluate */
static SEXP expandDots(SEXP el, SEXP rho)
{
SEXP ans, tail;
PROTECT(el); /* in do_switch, this is already protected */
PROTECT(ans = tail = CONS(R_NilValue, R_NilValue));
while (el != R_NilValue) {
if (CAR(el) == R_DotsSymbol) {
SEXP h = findVar(CAR(el), rho);
if (TYPEOF(h) == DOTSXP || h == R_NilValue) {
while (h != R_NilValue) {
SETCDR(tail, CONS(CAR(h), R_NilValue));
tail = CDR(tail);
if(TAG(h) != R_NilValue) SET_TAG(tail, TAG(h));
h = CDR(h);
}
} else if (h != R_MissingArg)
error(_("'...' used in an incorrect context"));
} else {
SETCDR(tail, CONS(CAR(el), R_NilValue));
tail = CDR(tail);
if(TAG(el) != R_NilValue) SET_TAG(tail, TAG(el));
}
el = CDR(el);
}
UNPROTECT(2);
return CDR(ans);
}
SEXP interp_walk(SEXP x, SEXP env, SEXP data) {
if (!Rf_isLanguage(x))
return x;
if (is_call_to(x, "uq")) {
SEXP uq_call = PROTECT(Rf_lang3(Rf_install("uq"), CADR(x), data));
SEXP res = PROTECT(Rf_eval(uq_call, env));
UNPROTECT(2);
return res;
}
if (is_call_to(x, "uqf")) {
return Rf_eval(x, env);
}
// Recursive case
for(SEXP cur = x; cur != R_NilValue; cur = CDR(cur)) {
SETCAR(cur, interp_walk(CAR(cur), env, data));
SEXP nxt = CDR(cur);
if (is_call_to(CAR(nxt), "uqs")) {
// uqs() does error checking and returns a pair list
SEXP args_pl = Rf_eval(CAR(nxt), env);
// Insert args_pl into existing pairlist of args
SEXP last_arg = findLast(args_pl);
SETCDR(last_arg, CDR(nxt));
SETCDR(cur, args_pl);
}
}
return x;
}
Result* firstlast_prototype(SEXP call, const ILazySubsets& subsets, int nargs, int pos) {
SEXP tail = CDDR(call);
SETCAR(call, Rf_install("nth"));
Pairlist p(pos);
if (Rf_isNull(tail)) {
SETCDR(CDR(call), p);
} else {
SETCDR(p, tail);
SETCDR(CDR(call), p);
}
Result* res = nth_prototype(call, subsets, nargs + 1);
return res;
}
/* used in removeAttrib, commentgets and classgets */
static SEXP stripAttrib(SEXP tag, SEXP lst)
{
if(lst == R_NilValue) return lst;
if(tag == TAG(lst)) return stripAttrib(tag, CDR(lst));
SETCDR(lst, stripAttrib(tag, CDR(lst)));
return lst;
}
HIDE void deserializeSEXP(SEXP o) {
_dbg(rjprintf("attempt to deserialize %p (clCL=%p, oCL=%p)\n", o, clClassLoader, oClassLoader));
SEXP s = EXTPTR_PROT(o);
if (TYPEOF(s) == RAWSXP && EXTPTR_PTR(o) == NULL) {
JNIEnv *env = getJNIEnv();
if (env && clClassLoader && oClassLoader) {
jbyteArray ser = newByteArray(env, RAW(s), LENGTH(s));
if (ser) {
jmethodID mid = (*env)->GetMethodID(env, clClassLoader, "toObject", "([B)Ljava/lang/Object;");
if (mid) {
jobject res = (*env)->CallObjectMethod(env, oClassLoader, mid, ser);
if (res) {
jobject go = makeGlobal(env, res);
_mp(MEM_PROF_OUT("R %08x RNEW %08x\n", (int) go, (int) res))
if (go) {
_dbg(rjprintf(" - succeeded: %p\n", go));
/* set the deserialized object */
EXTPTR_PTR(o) = (SEXP) go;
/* Note: currently we don't remove the serialized content, because it was created explicitly using .jcache to allow repeated saving. Once this is handled by a hook, we shall remove it. However, to assure compatibility TAG is always NULL for now, so we do clear the cache if TAG is non-null for future use. */
if (EXTPTR_TAG(o) != R_NilValue) {
/* remove the serialized raw vector */
SETCDR(o, R_NilValue); /* Note: this is abuse of the API since it uses the fact that PROT is stored in CDR */
}
}
}
}
releaseObject(env, ser);
}
}
static SEXP matchPar_int(const char *tag, SEXP *list, Rboolean exact)
{
if (*list == R_NilValue)
return R_MissingArg;
else if (TAG(*list) != R_NilValue &&
psmatch(tag, CHAR(PRINTNAME(TAG(*list))), exact)) {
SEXP s = *list;
*list = CDR(*list);
return CAR(s);
}
else {
SEXP last = *list;
SEXP next = CDR(*list);
while (next != R_NilValue) {
if (TAG(next) != R_NilValue &&
psmatch(tag, CHAR(PRINTNAME(TAG(next))), exact)) {
SETCDR(last, CDR(next));
return CAR(next);
}
else {
last = next;
next = CDR(next);
}
}
return R_MissingArg;
}
}
/**
* Insert a new element at the __head__ of a stretchy list
*
* @param l stretchy list in which we want to insert s
* @param s element to add to l
* @return the stretchy list l appended by s
*/
SEXP Insert(SEXP l, SEXP s){
SEXP tmp;
PROTECT(s);
tmp = CONS(s, CDR(l));
UNPROTECT(1);
SETCDR(l, tmp);
return l;
}
/**
* Add a new element at the __end__ of a stretchy list
*
* @param l stretchy list to expand
* @param s element to add at the __end__ of the list
* @return
*/
SEXP GrowList(SEXP l, SEXP s) {
SEXP tmp;
PROTECT(s);
tmp = CONS(s, R_NilValue);
UNPROTECT(1);
SETCDR(CAR(l), tmp);
SETCAR(l, tmp);
return l;
}
static SEXP Prune(SEXP lst)
{
if (lst == R_NilValue)
return lst;
SETCDR(lst, Prune(CDR(lst)));
if (CAR(lst) == R_MissingArg)
return CDR(lst);
else return lst ;
}
void GEaddDevice(pGEDevDesc gdd)
{
int i;
Rboolean appnd;
SEXP s, t;
pGEDevDesc oldd;
PROTECT(s = getSymbolValue(R_DevicesSymbol));
if (!NoDevices()) {
oldd = GEcurrentDevice();
if(oldd->dev->deactivate) oldd->dev->deactivate(oldd->dev);
}
/* find empty slot for new descriptor */
i = 1;
if (CDR(s) == R_NilValue)
appnd = TRUE;
else {
s = CDR(s);
appnd = FALSE;
}
while (R_Devices[i] != NULL) {
i++;
if (CDR(s) == R_NilValue)
appnd = TRUE;
else
s = CDR(s);
}
R_CurrentDevice = i;
R_NumDevices++;
R_Devices[i] = gdd;
active[i] = TRUE;
GEregisterWithDevice(gdd);
if(gdd->dev->activate) gdd->dev->activate(gdd->dev);
/* maintain .Devices (.Device has already been set) */
t = PROTECT(duplicate(getSymbolValue(R_DeviceSymbol)));
if (appnd)
SETCDR(s, CONS(t, R_NilValue));
else
SETCAR(s, t);
UNPROTECT(2);
/* In case a device driver did not call R_CheckDeviceAvailable
before starting its allocation, we complete the allocation and
then call killDevice here. This ensures that the device gets a
chance to deallocate its resources and the current active
device is restored to a sane value. */
if (i == R_MaxDevices - 1) {
killDevice(i);
error(_("too many open devices"));
}
}
INLINE_FUN SEXP listAppend(SEXP s, SEXP t)
{
SEXP r;
if (s == R_NilValue)
return t;
r = s;
while (CDR(r) != R_NilValue)
r = CDR(r);
SETCDR(r, t);
return s;
}
SEXP
RecursiveRelease(SEXP obj, SEXP list)
{
if (!isNull(list)) {
if (obj == CAR(list))
return CDR(list);
else
SETCDR(list, RecursiveRelease(obj, CDR(list)));
}
return list;
}
/* all, any */
SEXP attribute_hidden do_logic3(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, s, t, call2;
int narm, has_na = 0;
/* initialize for behavior on empty vector
all(logical(0)) -> TRUE
any(logical(0)) -> FALSE
*/
Rboolean val = PRIMVAL(op) == _OP_ALL ? TRUE : FALSE;
PROTECT(args = fixup_NaRm(args));
PROTECT(call2 = duplicate(call));
SETCDR(call2, args);
if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
UNPROTECT(2);
return(ans);
}
ans = matchArgExact(R_NaRmSymbol, &args);
narm = asLogical(ans);
for (s = args; s != R_NilValue; s = CDR(s)) {
t = CAR(s);
/* Avoid memory waste from coercing empty inputs, and also
avoid warnings with empty lists coming from sapply */
if(xlength(t) == 0) continue;
/* coerceVector protects its argument so this actually works
just fine */
if (TYPEOF(t) != LGLSXP) {
/* Coercion of integers seems reasonably safe, but for
other types it is more often than not an error.
One exception is perhaps the result of lapply, but
then sapply was often what was intended. */
if(TYPEOF(t) != INTSXP)
warningcall(call,
_("coercing argument of type '%s' to logical"),
type2char(TYPEOF(t)));
t = coerceVector(t, LGLSXP);
}
val = checkValues(PRIMVAL(op), narm, LOGICAL(t), XLENGTH(t));
if (val != NA_LOGICAL) {
if ((PRIMVAL(op) == _OP_ANY && val)
|| (PRIMVAL(op) == _OP_ALL && !val)) {
has_na = 0;
break;
}
} else has_na = 1;
}
UNPROTECT(2);
return has_na ? ScalarLogical(NA_LOGICAL) : ScalarLogical(val);
}
static int Accumulate2(SEXP expr, SEXP exprlist)
{
SEXP e;
int k;
e = exprlist;
k = 0;
while(CDR(e) != R_NilValue) {
e = CDR(e);
k = k + 1;
}
SETCDR(e, CONS(expr, R_NilValue));
return k + 1;
}
static SEXP Replace(SEXP sym, SEXP expr, SEXP lst)
{
switch(TYPEOF(lst)) {
case SYMSXP:
if (lst == sym) return expr;
else return lst;
case LISTSXP:
case LANGSXP:
SETCAR(lst, Replace(sym, expr, CAR(lst)));
SETCDR(lst, Replace(sym, expr, CDR(lst)));
return lst;
default:
return lst;
}
}
/* Returns and removes a named argument from argument list args.
The search ends as soon as a matching argument is found. If
the argument is not found, the argument list is not modified
and R_NilValue is returned.
*/
static SEXP ExtractArg(SEXP args, SEXP arg_sym)
{
SEXP arg, prev_arg;
int found = 0;
for (arg = prev_arg = args; arg != R_NilValue; arg = CDR(arg)) {
if(TAG(arg) == arg_sym) {
if (arg == prev_arg) /* found at head of args */
args = CDR(args);
else
SETCDR(prev_arg, CDR(arg));
found = 1;
break;
}
else prev_arg = arg;
}
return found ? CAR(arg) : R_NilValue;
}
PRIVATE VECTOR contents_remove(VECTOR c, OBJECT o) {
VECTOR prev = NULL;
VECTOR curr = c;
while (curr != NULL) {
if (CAR(curr) == (OBJ) o) {
if (prev == NULL)
return (VECTOR) CDR(curr);
SETCDR(prev, CDR(curr));
return c;
}
prev = curr;
curr = (VECTOR) CDR(curr);
}
return c;
}
void dybuf_add(SEXP s, const char *data, unsigned long len) {
dybuf_info_t *d = (dybuf_info_t*) RAW(VECTOR_ELT(s, 1));
unsigned long n = (d->pos + len > d->size) ? (d->size - d->pos) : len;
if (!len) return;
/* printf("[%lu/%lu] %lu\n", d->pos, d->size, len); */
if (n) {
memcpy(d->data + d->pos, data, n);
d->pos += n;
if (len == n) return;
data += n;
len -= n;
}
/* printf("[%lu/%lu] filled, need %lu more", d->pos, d->size, len); */
/* if the output is connection-based, flush */
if (d->con) {
long wr;
/* FIXME: should we try partial sends as well ? */
if ((wr = R_WriteConnection(d->con, d->data, d->pos)) != d->pos)
Rf_error("write failed, expected %lu, got %ld", d->pos, wr);
d->pos = 0;
/* if the extra content is substantially big, don't even
bother storing it and send right away */
if (len > (d->size / 2)) {
/* FIXME: (actually FIX R): WriteConnection should be using const void* */
if ((wr = R_WriteConnection(d->con, (void*) data, len)) != len)
Rf_error("write failed, expected %lu, got %ld", len, wr);
} else { /* otherwise copy into the buffer */
memcpy(d->data, data, len);
d->pos = len;
}
} else { /* need more buffers */
SEXP nb;
while (len > d->size) d->size *= 2;
/* printf(", creating %lu more\n", d->size); */
d->tail = SETCDR(d->tail, list1(nb = allocVector(RAWSXP, d->size)));
memcpy(d->data = (char*) RAW(nb), data, len);
d->pos = len;
}
}
/* Tweaks here based in part on PR#14934 */
static SEXP installAttrib(SEXP vec, SEXP name, SEXP val)
{
SEXP t = R_NilValue; /* -Wall */
if(TYPEOF(vec) == CHARSXP)
error("cannot set attribute on a CHARSXP");
/* this does no allocation */
for (SEXP s = ATTRIB(vec); s != R_NilValue; s = CDR(s)) {
if (TAG(s) == name) {
SETCAR(s, val);
return val;
}
t = s; // record last attribute, if any
}
/* The usual convention is that the caller protects,
so this is historical over-cautiousness */
PROTECT(vec); PROTECT(name); PROTECT(val);
SEXP s = CONS(val, R_NilValue);
SET_TAG(s, name);
if (ATTRIB(vec) == R_NilValue) SET_ATTRIB(vec, s); else SETCDR(t, s);
UNPROTECT(3);
return val;
}
SEXP deriv(SEXP args)
{
/* deriv(expr, namevec, function.arg, tag, hessian) */
SEXP ans, ans2, expr, funarg, names, s;
int f_index, *d_index, *d2_index;
int i, j, k, nexpr, nderiv=0, hessian;
SEXP exprlist, tag;
args = CDR(args);
InitDerivSymbols();
PROTECT(exprlist = LCONS(R_BraceSymbol, R_NilValue));
/* expr: */
if (isExpression(CAR(args)))
PROTECT(expr = VECTOR_ELT(CAR(args), 0));
else PROTECT(expr = CAR(args));
args = CDR(args);
/* namevec: */
names = CAR(args);
if (!isString(names) || (nderiv = length(names)) < 1)
error(_("invalid variable names"));
args = CDR(args);
/* function.arg: */
funarg = CAR(args);
args = CDR(args);
/* tag: */
tag = CAR(args);
if (!isString(tag) || length(tag) < 1
|| length(STRING_ELT(tag, 0)) < 1 || length(STRING_ELT(tag, 0)) > 60)
error(_("invalid tag"));
args = CDR(args);
/* hessian: */
hessian = asLogical(CAR(args));
/* NOTE: FindSubexprs is destructive, hence the duplication.
It can allocate, so protect the duplicate.
*/
PROTECT(ans = duplicate(expr));
f_index = FindSubexprs(ans, exprlist, tag);
d_index = (int*)R_alloc((size_t) nderiv, sizeof(int));
if (hessian)
d2_index = (int*)R_alloc((size_t) ((nderiv * (1 + nderiv))/2),
sizeof(int));
else d2_index = d_index;/*-Wall*/
UNPROTECT(1);
for(i=0, k=0; i<nderiv ; i++) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
PROTECT(ans2 = duplicate(ans)); /* keep a temporary copy */
d_index[i] = FindSubexprs(ans, exprlist, tag); /* examine the derivative first */
PROTECT(ans = duplicate(ans2)); /* restore the copy */
if (hessian) {
for(j = i; j < nderiv; j++) {
PROTECT(ans2 = duplicate(ans)); /* install could allocate */
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
d2_index[k] = FindSubexprs(ans2, exprlist, tag);
k++;
UNPROTECT(2);
}
}
UNPROTECT(4);
}
nexpr = length(exprlist) - 1;
if (f_index) {
Accumulate2(MakeVariable(f_index, tag), exprlist);
}
else {
PROTECT(ans = duplicate(expr));
Accumulate2(expr, exprlist);
UNPROTECT(1);
}
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
for (i = 0, k = 0; i < nderiv ; i++) {
if (d_index[i]) {
Accumulate2(MakeVariable(d_index[i], tag), exprlist);
if (hessian) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
UNPROTECT(2);
}
} else { /* the first derivative is constant or simple variable */
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
Accumulate2(ans, exprlist);
UNPROTECT(2);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
if(isZero(ans2)) Accumulate2(R_MissingArg, exprlist);
else Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
}
}
}
Accumulate2(R_NilValue, exprlist);
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
i = 0;
ans = CDR(exprlist);
while (i < nexpr) {
if (CountOccurrences(MakeVariable(i+1, tag), CDR(ans)) < 2) {
SETCDR(ans, Replace(MakeVariable(i+1, tag), CAR(ans), CDR(ans)));
SETCAR(ans, R_MissingArg);
}
else {
SEXP var;
PROTECT(var = MakeVariable(i+1, tag));
SETCAR(ans, lang3(install("<-"), var, AddParens(CAR(ans))));
UNPROTECT(1);
}
i = i + 1;
ans = CDR(ans);
}
/* .value <- ... */
SETCAR(ans, lang3(install("<-"), install(".value"), AddParens(CAR(ans))));
ans = CDR(ans);
/* .grad <- ... */
SETCAR(ans, CreateGrad(names));
ans = CDR(ans);
/* .hessian <- ... */
if (hessian) { SETCAR(ans, CreateHess(names)); ans = CDR(ans); }
/* .grad[, "..."] <- ... */
for (i = 0; i < nderiv ; i++) {
SETCAR(ans, DerivAssign(STRING_ELT(names, i), AddParens(CAR(ans))));
ans = CDR(ans);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (CAR(ans) != R_MissingArg) {
if (i == j) {
SETCAR(ans, HessAssign1(STRING_ELT(names, i),
AddParens(CAR(ans))));
} else {
SETCAR(ans, HessAssign2(STRING_ELT(names, i),
STRING_ELT(names, j),
AddParens(CAR(ans))));
}
}
ans = CDR(ans);
}
}
}
/* attr(.value, "gradient") <- .grad */
SETCAR(ans, AddGrad());
ans = CDR(ans);
if (hessian) { SETCAR(ans, AddHess()); ans = CDR(ans); }
/* .value */
SETCAR(ans, install(".value"));
/* Prune the expression list removing eliminated sub-expressions */
SETCDR(exprlist, Prune(CDR(exprlist)));
if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */
funarg = names;
}
if (TYPEOF(funarg) == CLOSXP)
{
funarg = mkCLOSXP(FORMALS(funarg), exprlist, CLOENV(funarg));
}
else if (isString(funarg)) {
SEXP formals = allocList(length(funarg));
ans = formals;
for(i = 0; i < length(funarg); i++) {
SET_TAG(ans, installTrChar(STRING_ELT(funarg, i)));
SETCAR(ans, R_MissingArg);
ans = CDR(ans);
}
funarg = mkCLOSXP(formals, exprlist, R_GlobalEnv);
}
else {
funarg = allocVector(EXPRSXP, 1);
SET_VECTOR_ELT(funarg, 0, exprlist);
/* funarg = lang2(install("expression"), exprlist); */
}
UNPROTECT(2);
return funarg;
}
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);
}
