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