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; } }
// This follows CR in adding new attributes at the end of the list, // though it would be easier to add them at the beginning. void RObject::setAttribute(const Symbol* name, RObject* value) { if (!name) Rf_error(_("attributes must be named")); // Update 'has class' bit if necessary: if (name == R_ClassSymbol) { if (value == 0) m_type &= static_cast<signed char>(~s_class_mask); else m_type |= static_cast<signed char>(s_class_mask); } // Find attribute: PairList* prev = 0; PairList* node = m_attrib; while (node && node->tag() != name) { prev = node; node = node->tail(); } if (node) { // Attribute already present // Update existing attribute: if (value) node->setCar(value); // Delete existing attribute: else if (prev) prev->setTail(node->tail()); else m_attrib = node->tail(); } else if (value) { // Create new node: PairList* newnode = PairList::cons(value, 0, name); if (prev) prev->setTail(newnode); else { // No preexisting attributes at all: m_attrib = newnode; } } }
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; }
void ArgList::merge(const ConsCell* extraargs) { if (m_status != PROMISED) Rf_error("Internal error: ArgList::merge() requires PROMISED ArgList"); // Convert extraargs into a doubly linked list: typedef std::list<pair<const RObject*, RObject*> > Xargs; Xargs xargs; for (const ConsCell* cc = extraargs; cc; cc = cc->tail()) xargs.push_back(make_pair(cc->tag(), cc->car())); // Apply overriding arg values supplied in extraargs: PairList* last = 0; for (PairList* pl = mutable_list(); pl; pl = pl->tail()) { last = pl; const RObject* tag = pl->tag(); if (tag) { Xargs::iterator it = xargs.begin(); while (it != xargs.end() && (*it).first != tag) ++it; if (it != xargs.end()) { pl->setCar((*it).second); xargs.erase(it); } } } // Append remaining extraargs: for (Xargs::const_iterator it = xargs.begin(); it != xargs.end(); ++it) { PairList* cell = PairList::cons((*it).second, 0, (*it).first); last = append(cell, last); } }
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; }
void ArgList::stripTags() { for (PairList* p = mutable_list(); p; p = p->tail()) p->setTag(0); }
SEXP attribute_hidden do_subassign2_dflt(SEXP call, SEXP op, SEXP argsarg, SEXP rho) { PairList* args = SEXP_downcast<PairList*>(argsarg); SEXP dims, indx, names, newname, x, xtop, xup, y, thesub = R_NilValue, xOrig = R_NilValue; int i, ndims, nsubs, which, len = 0 /* -Wall */; R_xlen_t stretch, offset, off = -1; /* -Wall */ Rboolean S4, recursed=FALSE; PROTECT(args); PairList* subs; nsubs = SubAssignArgs(args, &x, &subs, &y); S4 = CXXRCONSTRUCT(Rboolean, IS_S4_OBJECT(x)); /* Handle NULL left-hand sides. If the right-hand side */ /* is NULL, just return the left-hand size otherwise, */ /* convert to a zero length list (VECSXP). */ if (isNull(x)) { if (isNull(y)) { UNPROTECT(1); return x; } if (Rf_length(y) == 1) SETCAR(args, x = allocVector(TYPEOF(y), 0)); else SETCAR(args, x = allocVector(VECSXP, 0)); } /* Ensure that the LHS is a local variable. */ /* If it is not, then make a local copy. */ if (MAYBE_SHARED(x)) { x = shallow_duplicate(x); SETCAR(args, x); } xtop = xup = x; /* x will be the element which is assigned to */ dims = getAttrib(x, R_DimSymbol); ndims = Rf_length(dims); /* code to allow classes to extend ENVSXP */ if(TYPEOF(x) == S4SXP) { xOrig = x; /* will be an S4 object */ x = R_getS4DataSlot(x, ANYSXP); if(TYPEOF(x) != ENVSXP) errorcall(call, _("[[<- defined for objects of type \"S4\" only for subclasses of environment")); } /* ENVSXP special case first */ if( TYPEOF(x) == ENVSXP) { if( nsubs!=1 || !isString(CAR(subs)) || Rf_length(CAR(subs)) != 1 ) error(_("wrong args for environment subassignment")); defineVar(installTrChar(STRING_ELT(CAR(subs), 0)), y, x); UNPROTECT(1); return(S4 ? xOrig : x); } /* new case in 1.7.0, one vector index for a list, more general as of 2.10.0 */ if (nsubs == 1) { thesub = CAR(subs); len = Rf_length(thesub); /* depth of recursion, small */ if (len > 1) { xup = vectorIndex(x, thesub, 0, len-2, /*partial ok*/TRUE, call, TRUE); /* OneIndex sets newname, but it will be overwritten before being used. */ off = OneIndex(xup, thesub, xlength(xup), 0, &newname, len-2, R_NilValue); x = vectorIndex(xup, thesub, len-2, len-1, TRUE, call, TRUE); recursed = TRUE; } } stretch = 0; if (isVector(x)) { if (!isVectorList(x) && LENGTH(y) == 0) error(_("replacement has length zero")); if (!isVectorList(x) && LENGTH(y) > 1) error(_("more elements supplied than there are to replace")); if (nsubs == 0 || CAR(subs) == R_MissingArg) error(_("[[ ]] with missing subscript")); if (nsubs == 1) { offset = OneIndex(x, thesub, Rf_length(x), 0, &newname, recursed ? len-1 : -1, R_NilValue); if (isVectorList(x) && isNull(y)) { x = DeleteOneVectorListItem(x, offset); if(recursed) { if(isVectorList(xup)) SET_VECTOR_ELT(xup, off, x); else xup = SimpleListAssign(call, xup, subs, x, len-2); } else xtop = x; UNPROTECT(1); return xtop; } if (offset < 0) error(_("[[ ]] subscript out of bounds")); if (offset >= XLENGTH(x)) stretch = offset + 1; } else { if (ndims != nsubs) error(_("[[ ]] improper number of subscripts")); PROTECT(indx = allocVector(INTSXP, ndims)); names = getAttrib(x, R_DimNamesSymbol); for (i = 0; i < ndims; i++) { INTEGER(indx)[i] = int( get1index(CAR(subs), isNull(names) ? R_NilValue : VECTOR_ELT(names, i), INTEGER(dims)[i], /*partial ok*/FALSE, -1, call)); subs = subs->tail(); if (INTEGER(indx)[i] < 0 || INTEGER(indx)[i] >= INTEGER(dims)[i]) error(_("[[ ]] subscript out of bounds")); } offset = 0; for (i = (ndims - 1); i > 0; i--) offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1]; offset += INTEGER(indx)[0]; UNPROTECT(1); } which = SubassignTypeFix(&x, &y, 2, call); if (stretch) { PROTECT(x); PROTECT(y); x = EnlargeVector(x, stretch); UNPROTECT(2); } PROTECT(x); switch (which) { /* as from 2.3.0 'which' is after conversion */ case 1010: /* logical <- logical */ case 1310: /* integer <- logical */ /* case 1013: logical <- integer */ case 1313: /* integer <- integer */ INTEGER(x)[offset] = INTEGER(y)[0]; break; case 1410: /* real <- logical */ case 1413: /* real <- integer */ if (INTEGER(y)[0] == NA_INTEGER) REAL(x)[offset] = NA_REAL; else REAL(x)[offset] = INTEGER(y)[0]; break; /* case 1014: logical <- real */ /* case 1314: integer <- real */ case 1414: /* real <- real */ REAL(x)[offset] = REAL(y)[0]; break; case 1510: /* complex <- logical */ case 1513: /* complex <- integer */ if (INTEGER(y)[0] == NA_INTEGER) { COMPLEX(x)[offset].r = NA_REAL; COMPLEX(x)[offset].i = NA_REAL; } else { COMPLEX(x)[offset].r = INTEGER(y)[0]; COMPLEX(x)[offset].i = 0.0; } break; case 1514: /* complex <- real */ if (ISNA(REAL(y)[0])) { COMPLEX(x)[offset].r = NA_REAL; COMPLEX(x)[offset].i = NA_REAL; } else { COMPLEX(x)[offset].r = REAL(y)[0]; COMPLEX(x)[offset].i = 0.0; } break; /* case 1015: logical <- complex */ /* case 1315: integer <- complex */ /* case 1415: real <- complex */ case 1515: /* complex <- complex */ COMPLEX(x)[offset] = COMPLEX(y)[0]; break; case 1610: /* character <- logical */ case 1613: /* character <- integer */ case 1614: /* character <- real */ case 1615: /* character <- complex */ case 1616: /* character <- character */ /* case 1016: logical <- character */ /* case 1316: integer <- character */ /* case 1416: real <- character */ /* case 1516: complex <- character */ SET_STRING_ELT(x, offset, STRING_ELT(y, 0)); break; case 1019: /* logical <- vector */ case 1319: /* integer <- vector */ case 1419: /* real <- vector */ case 1519: /* complex <- vector */ case 1619: /* character <- vector */ case 1901: /* vector <- symbol */ case 1902: /* vector <- pairlist */ case 1904: /* vector <- environment*/ case 1905: /* vector <- promise */ case 1906: /* vector <- language */ case 1910: /* vector <- logical */ case 1913: /* vector <- integer */ case 1914: /* vector <- real */ case 1915: /* vector <- complex */ case 1916: /* vector <- character */ case 1919: /* vector <- vector */ case 1920: /* vector <- expression */ case 1921: /* vector <- bytecode */ case 1922: /* vector <- external pointer */ case 1923: /* vector <- weak reference */ case 1924: /* vector <- raw */ case 1925: /* vector <- S4 */ case 1903: case 1907: case 1908: case 1999: /* functions */ if( NAMED(y) ) y = duplicate(y); SET_VECTOR_ELT(x, offset, y); break; case 2002: /* expression <- pairlist */ case 2006: /* expression <- language */ case 2010: /* expression <- logical */ case 2013: /* expression <- integer */ case 2014: /* expression <- real */ case 2015: /* expression <- complex */ case 2016: /* expression <- character */ case 2024: /* expression <- raw */ case 2025: /* expression <- S4 */ case 2020: /* expression <- expression */ SET_XVECTOR_ELT(x, offset, R_FixupRHS(x, y)); break; case 2424: /* raw <- raw */ RAW(x)[offset] = RAW(y)[0]; break; default: error(_("incompatible types (from %s to %s) in [[ assignment"), type2char(CXXRCONSTRUCT(SEXPTYPE, which%100)), type2char(CXXRCONSTRUCT(SEXPTYPE, which/100))); } /* If we stretched, we may have a new name. */ /* In this case we must create a names attribute */ /* (if it doesn't already exist) and set the new */ /* value in the names attribute. */ if (stretch && newname != R_NilValue) { names = getAttrib(x, R_NamesSymbol); if (names == R_NilValue) { PROTECT(names = allocVector(STRSXP, Rf_length(x))); SET_STRING_ELT(names, offset, newname); setAttrib(x, R_NamesSymbol, names); UNPROTECT(1); } else SET_STRING_ELT(names, offset, newname); } UNPROTECT(1); } else if (isPairList(x)) { y = R_FixupRHS(x, y); PROTECT(y); if (nsubs == 1) { if (isNull(y)) { x = listRemove(x, CAR(subs), len-1); } else { x = SimpleListAssign(call, x, subs, y, len-1); } } else { if (ndims != nsubs) error(_("[[ ]] improper number of subscripts")); PROTECT(indx = allocVector(INTSXP, ndims)); names = getAttrib(x, R_DimNamesSymbol); for (i = 0; i < ndims; i++) { INTEGER(indx)[i] = int( get1index(CAR(subs), VECTOR_ELT(names, i), INTEGER(dims)[i], /*partial ok*/FALSE, -1, call)); subs = subs->tail(); if (INTEGER(indx)[i] < 0 || INTEGER(indx)[i] >= INTEGER(dims)[i]) error(_("[[ ]] subscript (%d) out of bounds"), i+1); } offset = 0; for (i = (ndims - 1); i > 0; i--) offset = (offset + INTEGER(indx)[i]) * INTEGER(dims)[i - 1]; offset += INTEGER(indx)[0]; SEXP slot = nthcdr(x, (int) offset); SETCAR(slot, duplicate(y)); /* FIXME: add name */ UNPROTECT(1); } UNPROTECT(1); } else error(R_MSG_ob_nonsub, type2char(TYPEOF(x))); if(recursed) { if (isVectorList(xup)) { SET_VECTOR_ELT(xup, off, x); } else { xup = SimpleListAssign(call, xup, subs, x, len-2); } if (len == 2) xtop = xup; } else xtop = x; UNPROTECT(1); SET_NAMED(xtop, 0); if(S4) SET_S4_OBJECT(xtop); return xtop; }