RObject* RObject::getAttribute(const Symbol* name) const
{
for (PairList* node = m_attrib; node; node = node->tail())
if (node->tag() == name)
return node->car();
return 0;
}
static int SubAssignArgs(PairList* args, SEXP *x, PairList** s, SEXP *y)
{
if (CDR(args) == R_NilValue)
Rf_error(_("SubAssignArgs: invalid number of arguments"));
*x = args->car();
if(CDDR(args) == R_NilValue) {
*s = nullptr;
*y = args->tail()->car();
return 0;
}
else {
int nsubs = 1;
PairList* p = args->tail();
*s = p;
PairList* ptail = p->tail();
while (ptail->tail()) {
p = ptail;
ptail = p->tail();
nsubs++;
}
*y = ptail->car();
p->setTail(nullptr);
return nsubs;
}
}
int main(int argc, char* argv[]) {
Evaluator evalr;
if (argc < 3 || argc > 4)
usage(argv[0]);
// Set up error reporting:
ptr_R_WriteConsoleEx = WriteConsoleEx;
ptr_R_ResetConsole = ptr_R_FlushConsole =
ptr_R_ClearerrConsole = DoNothing;
Rf_InitOptions();
// Set up Environments:
GCStackRoot<Frame> ff(CXXR_NEW(ListFrame));
GCStackRoot<Environment> fenvrt(CXXR_NEW(Environment(0, ff)));
fenv = fenvrt;
// Process formals:
cout << "Formal arguments:\n\n";
GCStackRoot<PairList> formals(getArgs(argv[1]));
GCStackRoot<ArgMatcher> matcher;
try {
matcher = GCNode::expose(new ArgMatcher(formals));
} catch (CommandTerminated) {
cerr << "ArgMatchertest: Error encountered while processing formals" << endl;
return 0;
}
// Process supplied arguments:
cout << "\nSupplied arguments:\n\n";
ArgList supplied(getArgs(argv[2]), ArgList::RAW);
// Set up frame and prior bindings (if any):
Frame* frame = fenv->frame();
if (argc == 4) {
cout << "\nPrior bindings:\n\n";
GCStackRoot<PairList> prior_bindings(getArgs(argv[3]));
for (PairList* pb = prior_bindings; pb; pb = pb->tail()) {
const Symbol* tag = static_cast<const Symbol*>(pb->tag());
Frame::Binding* bdg = frame->obtainBinding(tag);
bdg->setValue(pb->car(), Frame::Binding::EXPLICIT);
}
}
// Perform match and show result:
try {
matcher->match(fenv, &supplied);
} catch (CommandTerminated) {
cerr << "ArgMatchertest: Error encountered while matching arguments" << endl;
return 0;
}
cout << "\nMatch result:\n\n";
showFrame(frame);
return 0;
}
SEXP attribute_hidden do_subassign_dflt(SEXP call, SEXP op, SEXP argsarg,
SEXP rho)
{
GCStackRoot<PairList> args(SEXP_downcast<PairList*>(argsarg));
SEXP ignored, x, y;
PairList* subs;
int nsubs = SubAssignArgs(args, &x, &subs, &y);
/* If there are multiple references to an object we must */
/* duplicate it so that only the local version is mutated. */
/* This will duplicate more often than necessary, but saves */
/* over always duplicating. */
if (MAYBE_SHARED(CAR(args))) {
x = SETCAR(args, shallow_duplicate(CAR(args)));
}
bool S4 = IS_S4_OBJECT(x);
SEXPTYPE xorigtype = TYPEOF(x);
if (xorigtype == LISTSXP || xorigtype == LANGSXP)
x = PairToVectorList(x);
/* bug PR#2590 coerce only if null */
if (!x)
x = coerceVector(x, TYPEOF(y));
switch (TYPEOF(x)) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case EXPRSXP:
case VECSXP:
case RAWSXP:
{
VectorBase* xv = static_cast<VectorBase*>(x);
if (xv->size() == 0 && Rf_length(y) == 0)
return x;
size_t nsubs = listLength(subs);
switch (nsubs) {
case 0:
x = VectorAssign(call, x, R_MissingArg, y);
break;
case 1:
x = VectorAssign(call, x, subs->car(), y);
break;
default:
x = ArrayAssign(call, x, subs, y);
break;
}
}
break;
default:
error(R_MSG_ob_nonsub, TYPEOF(x));
break;
}
if (xorigtype == LANGSXP) {
if(Rf_length(x)) {
GCStackRoot<PairList> xlr(static_cast<PairList*>(VectorToPairList(x)));
GCStackRoot<Expression> xr(ConsCell::convert<Expression>(xlr));
x = xr;
} else
error(_("result is zero-length and so cannot be a language object"));
}
/* Note the setting of NAMED(x) to zero here. This means */
/* that the following assignment will not duplicate the value. */
/* This works because at this point, x is guaranteed to have */
/* at most one symbol bound to it. It does mean that there */
/* will be multiple reference problems if "[<-" is used */
/* in a naked fashion. */
SET_NAMED(x, 0);
if (S4)
SET_S4_OBJECT(x);
return x;
}
