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