private static SubstituteContext buildContext(Context context, Environment rho, SEXP argument) {
if (argument == Symbol.MISSING_ARG) {
return buildContext(context, rho);
}
SEXP env = context.evaluate(argument, rho);
return buildContext(context, env);
}
/**
* Executes the default the standard R initialization sequence:
*
* <ol>
* <li>Load the base package (/org/renjin/library/base/R/base)
* <li>Execute the system profile (/org/renjin/library/base/R/Rprofile)
* <li>Evaluate .OptRequireMethods()
* <li>Evaluate .First.Sys()
* </ol>
*/
public void init() throws IOException {
BaseFrame baseFrame = (BaseFrame) session.getBaseEnvironment().getFrame();
baseFrame.load(this);
evaluate(FunctionCall.newCall(Symbol.get(".onLoad")), session.getBaseNamespaceEnv());
// evalBaseResource("/org/renjin/library/base/R/Rprofile");
//
// // FunctionCall.newCall(new Symbol(".OptRequireMethods")).evaluate(this, environment);
// evaluate( FunctionCall.newCall(Symbol.get(".First.sys")), environment);
}
private static SEXP R_loadMethod(Context context, SEXP def, String fname, Environment ev) {
/* since this is called every time a method is dispatched with a
definition that has a class, it should be as efficient as
possible => we build in knowledge of the standard
MethodDefinition and MethodWithNext slots. If these (+ the
class slot) don't account for all the attributes, regular
dispatch is done. */
int found = 1; /* we "know" the class attribute is there */
found++; // we also have our fake __S4_BIt for renjin
PairList attrib = def.getAttributes().asPairList();
for (PairList.Node s : attrib.nodes()) {
SEXP t = s.getTag();
if (t == R_target) {
ev.setVariable(R_dot_target, s.getValue());
found++;
} else if (t == R_defined) {
ev.setVariable(R_dot_defined, s.getValue());
found++;
} else if (t == R_nextMethod) {
ev.setVariable(R_dot_nextMethod, s.getValue());
found++;
} else if (t == Symbols.SOURCE) {
/* ignore */ found++;
}
}
ev.setVariable(R_dot_Method, def);
/* this shouldn't be needed but check the generic being
"loadMethod", which would produce a recursive loop */
if (fname.equals("loadMethod")) {
return def;
}
if (found < attrib.length()) {
FunctionCall call =
FunctionCall.newCall(R_loadMethod_name, def, StringArrayVector.valueOf(fname), ev);
return context.evaluate(call, ev);
// SEXP e, val;
// PROTECT(e = allocVector(LANGSXP, 4));
// SETCAR(e, R_loadMethod_name); val = CDR(e);
// SETCAR(val, def); val = CDR(val);
// SETCAR(val, fname); val = CDR(val);
// SETCAR(val, ev);
// val = eval(e, ev);
// return val;
} else {
return def;
}
}
protected void evalBaseResource(String resourceName) throws IOException {
Context evalContext = this.beginEvalContext(session.getBaseNamespaceEnv());
InputStream in = getClass().getResourceAsStream(resourceName);
if (in == null) {
throw new IOException("Could not load resource '" + resourceName + "'");
}
Reader reader = new InputStreamReader(in);
try {
evalContext.evaluate(RParser.parseSource(reader));
} finally {
reader.close();
}
}
private SEXP R_S_MethodsListSelect(Context context, SEXP fname, SEXP ev, SEXP mlist, SEXP f_env) {
PairList.Builder args = new PairList.Builder();
args.add(fname);
args.add(ev);
args.add(mlist);
if (f_env != Null.INSTANCE) {
args.add(f_env);
}
try {
return context.evaluate(
new FunctionCall(s_MethodsListSelect, args.build()), methodsNamespace);
} catch (EvalException e) {
throw new EvalException(
String.format(
"S language method selection got an error when called from"
+ " internal dispatch for function '%s'",
fname),
e);
}
}
/** Invokes any on.exit expressions that have been set. */
public void exit() {
for (SEXP exp : onExit) {
evaluate(exp, environment);
}
}
private SEXP do_inherited_table(
Context context, SEXP class_objs, SEXP fdef, SEXP mtable, Environment ev) {
SEXP fun = methodsNamespace.findFunction(context, Symbol.get(".InheritForDispatch"));
return context.evaluate(FunctionCall.newCall(fun, class_objs, fdef, mtable), ev);
}
private SEXP do_dispatch(
Context context, String fname, SEXP ev, SEXP mlist, boolean firstTry, boolean evalArgs) {
String klass;
SEXP arg_slot;
Symbol arg_sym;
SEXP method, value = Null.INSTANCE;
int nprotect = 0;
/* check for dispatch turned off inside MethodsListSelect */
if (mlist instanceof Function) {
return mlist;
}
arg_slot = Methods.R_do_slot(context, mlist, s_argument);
if (arg_slot == Null.INSTANCE) {
throw new EvalException(
"object of class \"%s\" used as methods list for function '%s' "
+ "( no 'argument' slot)",
mlist.toString(), fname);
}
if (arg_slot instanceof Symbol) {
arg_sym = (Symbol) arg_slot;
} else {
/* shouldn't happen, since argument in class MethodsList has class
"name" */
arg_sym = Symbol.get(arg_slot.asString());
}
// if(arg_sym == Symbols.ELLIPSES || DDVAL(arg_sym) > 0)
// error(_("(in selecting a method for function '%s') '...' and related variables cannot be
// used for methods dispatch"),
// CHAR(asChar(fname)));
// if(TYPEOF(ev) != ENVSXP) {
// error(_("(in selecting a method for function '%s') the 'environment' argument for dispatch
// must be an R environment; got an object of class \"%s\""),
// CHAR(asChar(fname)), class_string(ev));
// return(R_NilValue); /* -Wall */
// }
/* find the symbol in the frame, but don't use eval, yet, because
missing arguments are ok & don't require defaults */
if (evalArgs) {
if (is_missing_arg(context, arg_sym, (Environment) ev)) {
klass = "missing";
} else {
/* get its class */
SEXP arg, class_obj;
try {
arg = context.evaluate(arg_sym, (Environment) ev);
} catch (EvalException e) {
throw new EvalException(
String.format(
"error in evaluating the argument '%s' in selecting a method for function '%s'",
arg_sym.getPrintName(), fname),
e);
}
class_obj = Methods.R_data_class(arg, true);
klass = class_obj.asString();
}
} else {
/* the arg contains the class as a string */
SEXP arg;
int check_err;
try {
arg = context.evaluate(arg_sym, (Environment) ev);
} catch (Exception e) {
throw new EvalException(
String.format(
"error in evaluating the argument '%s' in selecting a method for function '%s'",
arg_sym.getPrintName(), fname));
}
klass = arg.asString();
}
method = R_find_method(mlist, klass, fname);
if (method == Null.INSTANCE) {
if (!firstTry) {
throw new EvalException(
"no matching method for function '%s' (argument '%s', with class \"%s\")",
fname, arg_sym.getPrintName(), klass);
}
}
if (value == Symbol.MISSING_ARG) {
/* the check put in before calling
function MethodListSelect in R */
throw new EvalException(
"recursive use of function '%s' in method selection, with no default method", fname);
}
if (!(method instanceof Function)) {
/* assumes method is a methods list itself. */
/* call do_dispatch recursively. Note the NULL for fname; this is
passed on to the S language search function for inherited
methods, to indicate a recursive call, not one to be stored in
the methods metadata */
method = do_dispatch(context, null, ev, method, firstTry, evalArgs);
}
return method;
}
public SEXP R_dispatchGeneric(Context context, Symbol fname, Environment ev, SEXP fdef) {
SEXP method;
SEXP f;
SEXP val = Null.INSTANCE;
// char *buf, *bufptr;
int lwidth = 0;
boolean prim_case = false;
Environment f_env;
if (fdef instanceof Closure) {
f_env = ((Closure) fdef).getEnclosingEnvironment();
} else if (fdef instanceof PrimitiveFunction) {
fdef = R_primitive_generic(fdef);
if (!(fdef instanceof Closure)) {
throw new EvalException(
"Failed to get the generic for the primitive \"%s\"", fname.asString());
}
f_env = ((Closure) fdef).getEnclosingEnvironment();
prim_case = true;
} else {
throw new EvalException(
"Expected a generic function or a primitive for dispatch, "
+ "got an object of class \"%s\"",
fdef.getImplicitClass());
}
SEXP mtable = f_env.getVariable(R_allmtable);
if (mtable == Symbol.UNBOUND_VALUE) {
do_mtable(fdef, ev); /* Should initialize the generic */
mtable = f_env.getVariable(R_allmtable);
}
SEXP sigargs = f_env.getVariable(R_sigargs);
SEXP siglength = f_env.getVariable(R_siglength);
if (sigargs == Symbol.UNBOUND_VALUE
|| siglength == Symbol.UNBOUND_VALUE
|| mtable == Symbol.UNBOUND_VALUE) {
throw new EvalException(
"Generic \"%s\" seems not to have been initialized for table dispatch---need to have .SigArgs and .AllMtable assigned in its environment",
fname.asString());
}
int nargs = (int) siglength.asReal();
ListVector.Builder classListBuilder = ListVector.newBuilder();
StringVector thisClass;
StringBuilder buf = new StringBuilder();
for (int i = 0; i < nargs; i++) {
Symbol arg_sym = sigargs.getElementAsSEXP(i);
if (is_missing_arg(context, arg_sym, ev)) {
thisClass = s_missing;
} else {
/* get its class */
SEXP arg;
try {
arg = context.evaluate(arg_sym, ev);
} catch (EvalException e) {
throw new EvalException(
String.format(
"error in evaluating the argument '%s' in selecting a "
+ "method for function '%s'",
arg_sym.getPrintName(), fname.asString()),
e);
}
thisClass = Methods.R_data_class(arg, true);
}
classListBuilder.set(i, thisClass);
if (i > 0) {
buf.append("#");
}
buf.append(thisClass.asString());
}
ListVector classes = classListBuilder.build();
method = ((Environment) mtable).getVariable(buf.toString());
if (method == Symbol.UNBOUND_VALUE) {
method = do_inherited_table(context, classes, fdef, mtable, (Environment) ev);
}
/* the rest of this is identical to R_standardGeneric;
hence the f=method to remind us */
f = method;
if (f.isObject()) f = R_loadMethod(context, f, fname.getPrintName(), ev);
if (f instanceof Closure) {
val = R_execMethod(context, (Closure) f, ev);
} else if (f instanceof PrimitiveFunction) {
/* primitives can't be methods; they arise only as the
default method when a primitive is made generic. In this
case, return a special marker telling the C code to go on
with the internal computations. */
// val = R_deferred_default_method();
throw new UnsupportedOperationException();
} else {
throw new EvalException("invalid object (non-function) used as method");
}
return val;
}