pair<bool, RObject*> ArgList::firstArg(Environment* env)
{
const PairList* elt = list();
if (!elt)
return pair<bool, RObject*>(false, 0);
if (m_status == EVALUATED)
return make_pair(true, elt->car());
while (elt) {
RObject* arg1 = elt->car();
if (!arg1)
return pair<bool, RObject*>(true, 0);
if (arg1 != DotsSymbol) {
m_first_arg = Evaluator::evaluate(arg1, env);
m_first_arg_env = env;
return make_pair(true, m_first_arg.get());
}
// If we get here it must be DotSymbol.
Frame::Binding* bdg = env->findBinding(DotsSymbol);
if (bdg && bdg->origin() != Frame::Binding::MISSING) {
RObject* val = bdg->forcedValue();
if (val) {
if (val->sexptype() != DOTSXP)
Rf_error(_("'...' used in an incorrect context"));
RObject* dots1 = static_cast<DottedArgs*>(val)->car();
if (dots1->sexptype() != PROMSXP)
Rf_error(_("value in '...' is not a promise"));
m_first_arg = Evaluator::evaluate(dots1, env);
m_first_arg_env = env;
return make_pair(true, m_first_arg.get());
}
}
elt = elt->tail(); // elt was unbound or missing DotsSymbol
}
return pair<bool, RObject*>(false, 0);
}
std::pair<FunctionBase*, bool>
S3Launcher::findMethod(const Symbol* symbol, Environment* call_env,
Environment* table_env)
{
FunctionBase* fun = findFunction(symbol, call_env);
if (fun)
return make_pair(fun, true);
if (!table_env)
return pair<FunctionBase*, bool>(nullptr, false);
Environment* table = nullptr;
// Look for S3 methods table:
{
Frame::Binding* tblbdg
= table_env->frame()->binding(S3MethodsTableSymbol);
if (tblbdg) {
RObject* tblbdgval = tblbdg->forcedValue();
if (tblbdgval && tblbdgval->sexptype() == ENVSXP)
table = static_cast<Environment*>(tblbdgval);
}
}
// Look up method in table:
if (table) {
Frame::Binding* symbdg = table->frame()->binding(symbol);
if (symbdg) {
RObject* symbdgval = symbdg->forcedValue();
// Assume that the result is a FunctionBase:
return make_pair(static_cast<FunctionBase*>(symbdgval), false);
}
}
return pair<FunctionBase*, bool>(nullptr, false);
}
/** @brief Get or create a Binding for a Symbol.
*
* If the Frame already contains a Binding for a specified
* Symbol, the function returns it. Otherwise a Binding to
* the null pointer is created, and a pointer to that Binding
* returned.
*
* An error is raised if a new Binding needs to be created and
* the Frame is locked.
*
* @param symbol The Symbol for which a Binding is to be
* obtained.
* @param location assigned to the Symbol in the FrameDescriptor.
*
* @return Pointer to the required Binding.
*/
Binding* obtainBinding(const Symbol* symbol, int location) {
Frame::Binding* binding = m_bindings + location;
if (!binding->isSet()) {
initializeBindingIfUnlocked(binding, symbol);
m_used_bindings_size = std::max(m_used_bindings_size,
(unsigned char)(location + 1));
}
return binding;
}
void ArgList::wrapInPromises(Environment* env)
{
if (m_status == PROMISED)
Rf_error("Internal error:"
" ArgList already wrapped in Promises");
if (m_status == EVALUATED)
env = 0;
else if (m_first_arg_env && env != m_first_arg_env)
Rf_error("Internal error: first arg of ArgList"
" previously evaluated in different environment");
GCStackRoot<const PairList> oldargs(list());
setList(0);
PairList* lastout = 0;
for (const PairList* inp = oldargs; inp; inp = inp->tail()) {
RObject* rawvalue = inp->car();
if (rawvalue == DotsSymbol) {
Frame::Binding* binding = env->findBinding(DotsSymbol);
if (binding) {
RObject* dval = binding->forcedValue();
if (!dval || dval->sexptype() == DOTSXP) {
ConsCell* dotlist = static_cast<ConsCell*>(dval);
while (dotlist) {
Promise* prom;
if (!m_first_arg_env)
prom = new Promise(dotlist->car(), env);
else {
prom = new Promise(m_first_arg, 0);
m_first_arg = 0;
m_first_arg_env = 0;
}
prom->expose();
const Symbol* tag = tag2Symbol(dotlist->tag());
PairList* cell = PairList::cons(prom, 0, tag);
lastout = append(cell, lastout);
dotlist = dotlist->tail();
}
} else if (dval != Symbol::missingArgument())
Rf_error(_("'...' used in an incorrect context"));
}
} else {
const Symbol* tag = tag2Symbol(inp->tag());
RObject* value = Symbol::missingArgument();
if (m_first_arg_env) {
value = CXXR_NEW(Promise(m_first_arg, 0));
m_first_arg = 0;
m_first_arg_env = 0;
} else if (rawvalue != Symbol::missingArgument())
value = CXXR_NEW(Promise(rawvalue, env));
PairList* cell = PairList::cons(value, 0, tag);
lastout = append(cell, lastout);
}
}
m_status = PROMISED;
}
/*
* Assign to a symbol in a CompiledFrame.
*/
void rho_runtime_assignSymbolInCompiledFrame(const Symbol* symbol,
Environment* environment,
int position,
RObject* value)
{
assert(environment->frame() != nullptr);
assert(value != R_MissingArg);
assert(position >= 0);
Frame* frame = environment->frame();
assert(frame != nullptr);
Frame::Binding* binding = frame->obtainBinding(symbol, position);
binding->assign(value);
}
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;
}
/*
* Assign to a symbol in a CompiledFrame.
*/
void cxxr_runtime_assignSymbolInCompiledFrame(const Symbol* symbol,
Environment* environment,
int position,
RObject* value)
{
assert(environment->frame() != nullptr);
assert(value != R_MissingArg);
assert(position >= 0);
JIT::CompiledFrame* frame
// TODO(kmillar): when optimizing make this a static cast.
= dynamic_cast<JIT::CompiledFrame*>(environment->frame());
assert(frame != nullptr);
Frame::Binding* binding = frame->obtainBinding(symbol, position);
binding->assign(value);
}
SEXP attribute_hidden do_provCommand (SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifndef PROVENANCE_TRACKING
Rf_error(_("provenance tracking not implemented in this build"));
return 0;
#else
int n;
if ((n=length(args))!=1)
errorcall(call,_("%d arguments passed to 'provCommand' which requires 1"),n);
if (TYPEOF(CAR(args))!=SYMSXP)
errorcall(call,_("provCommand expects Symbol argument"));
Symbol* sym=SEXP_downcast<Symbol*>(CAR(args));
Environment* env=static_cast<Environment*>(rho);
Frame::Binding* bdg = env->findBinding(sym);
return const_cast<RObject*>(bdg->provenance()->command());
#endif // PROVENANCE_TRACKING
}
SEXP attribute_hidden do_hasProvenance (SEXP call, SEXP op, SEXP args, SEXP rho)
{
int n;
if ((n=length(args))!=1)
errorcall(call,_("%d arguments passed to 'hasProvenance' which requires 1"),n);
if (TYPEOF(CAR(args))!=SYMSXP)
errorcall(call,_("hasProvenance expects Symbol argument"));
GCStackRoot<LogicalVector> v(GCNode::expose(new LogicalVector(1)));
#ifdef PROVENANCE_TRACKING
Symbol* sym=SEXP_downcast<Symbol*>(CAR(args));
Environment* env=static_cast<Environment*>(rho);
Frame::Binding* bdg = env->findBinding(sym);
(*v)[0] = (bdg->provenance() != 0);
#else
(*v)[0] = false;
#endif
return v;
}
/*
* Lookup a symbol in a CompiledFrame.
* Note that this function doesn't handle the cases where the symbol is
* ..., ..n, or missingArg(). cxxr_runtime_lookupSymbol should be used in
* those cases.
*/
RObject* cxxr_runtime_lookupSymbolInCompiledFrame(const Symbol* symbol,
Environment* environment,
int position)
{
assert(environment->frame() != nullptr);
assert(symbol != DotsSymbol);
assert(!symbol->isDotDotSymbol());
assert(symbol != R_MissingArg);
assert(position >= 0);
JIT::CompiledFrame* frame
// TODO(kmillar): when optimizing make this a static cast.
= dynamic_cast<JIT::CompiledFrame*>(environment->frame());
assert(frame != nullptr);
Frame::Binding* binding = frame->binding(position);
if (binding) {
// NB: this logic handles the case where the binding is a promise that
// resolves to an unboundValue or missingArgument slightly differently
// than Symbol::evaluate() does.
std::pair<RObject*, bool> pair = binding->forcedValue2();
RObject* value = pair.first;
if (value
&& value != Symbol::missingArgument()
&& value != Symbol::unboundValue())
{
if (pair.second) {
SET_NAMED(value, 2);
}
else if (NAMED(value) < 1) {
SET_NAMED(value, 1);
}
return value;
}
}
// Fallback to the interpreter.
return cxxr_runtime_lookupSymbol(symbol, environment);
}
void ArgList::evaluate(Environment* env, bool allow_missing)
{
if (m_status == EVALUATED)
Rf_error("Internal error: ArgList already evaluated");
if (m_first_arg_env && env != m_first_arg_env)
Rf_error("Internal error: first arg of ArgList"
" previously evaluated in different environment");
GCStackRoot<const PairList> oldargs(list());
setList(0);
PairList* lastout = 0;
unsigned int arg_number = 1;
for (const PairList* inp = oldargs; inp; inp = inp->tail()) {
RObject* incar = inp->car();
if (incar == DotsSymbol) {
Frame::Binding* bdg = env->findBinding(CXXR::DotsSymbol);
if (!bdg)
Rf_error(_("'...' used but not bound"));
RObject* h = bdg->forcedValue();
if (!h || h->sexptype() == DOTSXP) {
ConsCell* dotlist = static_cast<DottedArgs*>(h);
while (dotlist) {
RObject* dotcar = dotlist->car();
RObject* outcar = Symbol::missingArgument();
if (m_first_arg_env) {
outcar = m_first_arg;
m_first_arg = 0;
m_first_arg_env = 0;
} else if (dotcar != Symbol::missingArgument())
outcar = Evaluator::evaluate(dotcar, env);
PairList* cell = PairList::cons(outcar, 0, dotlist->tag());
lastout = append(cell, lastout);
dotlist = dotlist->tail();
}
} else if (h != Symbol::missingArgument())
Rf_error(_("'...' used in an incorrect context"));
} else {
const RObject* tag = inp->tag();
PairList* cell = 0;
if (m_first_arg_env) {
cell = PairList::cons(m_first_arg, 0, tag);
m_first_arg = 0;
m_first_arg_env = 0;
} else if (incar && incar->sexptype() == SYMSXP) {
Symbol* sym = static_cast<Symbol*>(incar);
if (sym == Symbol::missingArgument()) {
if (allow_missing)
cell = PairList::cons(Symbol::missingArgument(), 0, tag);
else Rf_error(_("argument %d is empty"), arg_number);
} else if (isMissingArgument(sym, env->frame())) {
if (allow_missing)
cell = PairList::cons(Symbol::missingArgument(), 0, tag);
else Rf_error(_("'%s' is missing"),
sym->name()->c_str());
}
}
if (!cell) {
RObject* outcar = Evaluator::evaluate(incar, env);
cell = PairList::cons(outcar, 0, inp->tag());
}
lastout = append(cell, lastout);
}
++arg_number;
}
m_status = EVALUATED;
}
SEXP attribute_hidden
do_provenance_graph(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifndef PROVENANCE_TRACKING
Rf_error(_("provenance tracking not implemented in this build"));
return 0;
#else
int nargs = length(args);
if (nargs != 1)
Rf_error(_("%d arguments passed to 'provenance.graph' which requires 1"),
nargs);
SEXP arg1 = CAR(args);
if (!arg1 || arg1->sexptype() != STRSXP)
Rf_error(_("invalid 'names' argument"));
Environment* env = static_cast<Environment*>(rho);
Provenance::Set provs;
StringVector* sv = static_cast<StringVector*>(arg1);
for (size_t i = 0; i < sv->size(); i++) {
const char* name = (*sv)[i]->c_str();
Symbol* sym = Symbol::obtain(name);
Frame::Binding* bdg = env->findBinding(sym);
if (!bdg)
Rf_error(_("symbol '%s' not found"), name);
else {
Provenance* prov = const_cast<Provenance*>(bdg->provenance());
if (!prov)
Rf_warning(_("'%s' does not have provenance information"),
name);
else provs.insert(prov);
}
}
Provenance::Set* ancestors = Provenance::ancestors(provs);
GCStackRoot<ListVector> ans(CXXR_NEW(ListVector(7)));
std::map<const Provenance*, unsigned int> ancestor_index;
std::vector<std::pair<unsigned int, const RObject*> > xenogenous_bdgs;
// Assemble information on graph nodes:
{
size_t n = ancestors->size();
GCStackRoot<ListVector> symbols(CXXR_NEW(ListVector(n)));
GCStackRoot<ListVector> commands(CXXR_NEW(ListVector(n)));
GCStackRoot<RealVector> timestamps(CXXR_NEW(RealVector(n)));
size_t i = 0;
for (Provenance::Set::iterator it = ancestors->begin();
it != ancestors->end(); ++it) {
const Provenance* p = *it;
(*symbols)[i] = const_cast<Symbol*>(p->symbol());
(*commands)[i] = const_cast<RObject*>(p->command());
(*timestamps)[i] = p->timestamp();
++i;
ancestor_index[p] = i;
if (p->isXenogenous())
xenogenous_bdgs.push_back(std::make_pair(i, p->value()));
}
(*ans)[0] = symbols;
(*ans)[1] = commands;
(*ans)[2] = timestamps;
}
// Record information on xenogenous bindings:
{
size_t xn = xenogenous_bdgs.size();
GCStackRoot<IntVector> xenogenous(CXXR_NEW(IntVector(xn)));
GCStackRoot<ListVector> values(CXXR_NEW(ListVector(xn)));
for (unsigned int i = 0; i < xn; ++i) {
std::pair<unsigned int, const RObject*>& pr = xenogenous_bdgs[i];
(*xenogenous)[i] = pr.first;
(*values)[i] = const_cast<RObject*>(pr.second);
}
(*ans)[3] = xenogenous;
(*ans)[4] = values;
}
// Assemble information on graph edges:
{
typedef std::set<std::pair<unsigned int, unsigned int> > EdgeSet;
EdgeSet edges;
for (Provenance::Set::iterator it = ancestors->begin();
it != ancestors->end(); ++it) {
const Provenance* child = *it;
unsigned int child_idx = ancestor_index[child];
std::pair<CommandChronicle::ParentVector::const_iterator,
CommandChronicle::ParentVector::const_iterator>
pr = child->parents();
for (CommandChronicle::ParentVector::const_iterator it = pr.first;
it != pr.second; ++it) {
const Provenance* parent = *it;
unsigned int parent_idx = ancestor_index[parent];
edges.insert(std::make_pair(parent_idx, child_idx));
}
}
size_t en = edges.size();
GCStackRoot<IntVector> parents(CXXR_NEW(IntVector(en)));
GCStackRoot<IntVector> children(CXXR_NEW(IntVector(en)));
unsigned int i = 0;
for (EdgeSet::const_iterator it = edges.begin(); it != edges.end(); ++it) {
const std::pair<unsigned int, unsigned int>& edge = *it;
(*parents)[i] = edge.first;
(*children)[i] = edge.second;
++i;
}
(*ans)[5] = parents;
(*ans)[6] = children;
}
delete ancestors;
return ans;
#endif // PROVENANCE_TRACKING
}
SEXP attribute_hidden do_provenance (SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifndef PROVENANCE_TRACKING
Rf_error(_("provenance tracking not implemented in this build"));
return 0;
#else
const int nfields=5;
int n;
if ((n=length(args))!=1)
errorcall(call,_("%d arguments passed to 'provenance' which requires 1"),n);
if (TYPEOF(CAR(args))!=SYMSXP)
errorcall(call,_("provenance expects Symbol argument"));
Symbol* sym=SEXP_downcast<Symbol*>(CAR(args));
Environment* env=static_cast<Environment*>(rho);
Frame::Binding* bdg = env->findBinding(sym);
if (!bdg)
errorcall(call,_("invalid Symbol passed to 'provenance'"));
Provenance* provenance=const_cast<Provenance*>(bdg->provenance());
if (!provenance)
errorcall(call,_("object does not have any provenance"));
const Provenance::Set& children=provenance->children();
GCStackRoot<ListVector> list(GCNode::expose(new ListVector(nfields)));
GCStackRoot<StringVector> timestamp(GCNode::expose(new StringVector(1)));
GCStackRoot<StringVector> names(GCNode::expose(new StringVector(nfields)));
(*timestamp)[0]=const_cast<String*>(provenance->getTime());
(*names)[0]=const_cast<String*>(String::obtain("command"));
(*names)[1]=const_cast<String*>(String::obtain("symbol"));
(*names)[2]=const_cast<String*>(String::obtain("timestamp"));
(*names)[3]=const_cast<String*>(String::obtain("parents"));
(*names)[4]=const_cast<String*>(String::obtain("children"));
(*list)[0] = const_cast<RObject*>(provenance->command());
(*list)[1] = const_cast<Symbol*>(provenance->symbol());
(*list)[2]=timestamp;
// Handle parents:
{
std::pair<CommandChronicle::ParentVector::const_iterator,
CommandChronicle::ParentVector::const_iterator>
pr = provenance->parents();
size_t sz = pr.second - pr.first;
StringVector* sv = CXXR_NEW(StringVector(sz));
(*list)[3] = sv;
unsigned int i = 0;
for (CommandChronicle::ParentVector::const_iterator it = pr.first;
it != pr.second; ++it) {
const Provenance* p = *it;
(*sv)[i++] = const_cast<String*>(p->symbol()->name());
}
}
if (!children.empty()) {
StringVector* sv = CXXR_NEW(StringVector(children.size()));
(*list)[4] = sv;
unsigned int i = 0;
for (Provenance::Set::const_iterator it = children.begin();
it != children.end(); ++it) {
const Provenance* p = *it;
(*sv)[i++] = const_cast<String*>(p->symbol()->name());
}
}
setAttrib(list,R_NamesSymbol,names);
return list;
#endif // PROVENANCE_TRACKING
}