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