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;
}
}
@Override
public SEXP apply(Context context, Environment rho, FunctionCall call, PairList args) {
PairList matchedArguments = ClosureDispatcher.matchArguments(formals, args);
SEXP exprArgument = matchedArguments.findByTag(EXPR_ARGUMENT);
SEXP envArgument = matchedArguments.findByTag(ENV_ARGUMENT);
// Substitute handles ... in an idiosyncratic way:
// Only the first argument is used, and there is no attempt to
// match subsequent arguments against the 'env' argument.
SEXP expr;
if (exprArgument == Symbols.ELLIPSES) {
SEXP ellipses = rho.getVariable(Symbols.ELLIPSES);
if (ellipses == Null.INSTANCE) {
expr = Null.INSTANCE;
} else {
PromisePairList.Node promisePairList = (PromisePairList.Node) ellipses;
Promise promisedArg = (Promise) promisePairList.getValue();
expr = promisedArg.getExpression();
}
} else {
expr = exprArgument;
}
return substitute(expr, buildContext(context, rho, envArgument));
}
public Context beginFunction(
Environment rho, FunctionCall call, Closure closure, PairList arguments) {
Context context = new Context();
context.type = Type.FUNCTION;
context.parent = this;
context.evaluationDepth = evaluationDepth + 1;
context.closure = closure;
context.environment = Environment.createChildEnvironment(closure.getEnclosingEnvironment());
context.session = session;
context.arguments = arguments;
context.call = call;
context.callingEnvironment = rho;
return context;
}
private Function evaluateFunction(SEXP functionExp, Environment rho) {
if (functionExp instanceof Symbol) {
Symbol symbol = (Symbol) functionExp;
Function fn = rho.findFunction(this, symbol);
if (fn == null) {
throw new EvalException("could not find function '%s'", symbol.getPrintName());
}
return fn;
} else {
SEXP evaluated = evaluate(functionExp, rho).force(this);
if (!(evaluated instanceof Function)) {
throw new EvalException(
"'function' of lang expression is of unsupported type '%s'", evaluated.getTypeName());
}
return (Function) evaluated;
}
}
private SEXP evaluateSymbol(Symbol symbol, Environment rho) {
clearInvisibleFlag();
if (symbol == Symbol.MISSING_ARG) {
return symbol;
}
SEXP value = rho.findVariable(symbol);
if (value == Symbol.UNBOUND_VALUE) {
throw new EvalException(String.format("object '%s' not found", symbol.getPrintName()));
}
if (value instanceof Promise) {
return evaluate(value, rho);
} else {
return value;
}
}
@Override
public boolean hasVariable(Symbol name) {
return rho.hasVariable(name);
}
@Override
public SEXP getVariable(Symbol name) {
return rho.getVariable(name);
}
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);
}
public static SEXP R_execMethod(Context context, Closure op, Environment rho) {
/* create a new environment frame enclosed by the lexical
environment of the method */
Environment newrho = Environment.createChildEnvironment(op.getEnclosingEnvironment());
/* copy the bindings for the formal environment from the top frame
of the internal environment of the generic call to the new
frame. need to make sure missingness information is preserved
and the environments for any default expression promises are
set to the new environment. should move this to envir.c where
it can be done more efficiently. */
for (PairList.Node next : op.getFormals().nodes()) {
// R_varloc_t loc;
// int missing;
// TODO(alex): redo missingness handling
// loc = R_findVarLocInFrame(rho,symbol);
// if(loc == NULL)
// throw new EvalException("could not find symbol \"%s\" in environment of the generic
// function"),
// CHAR(PRINTNAME(symbol)));
// missing = R_GetVarLocMISSING(loc);
// val = R_GetVarLocValue(loc);
if (!next.hasTag()) {
throw new EvalException("closure formal has no tag! op = " + op);
}
Symbol symbol = next.getTag();
SEXP val = rho.findVariable(symbol);
if (val == Symbol.UNBOUND_VALUE) {
throw new EvalException(
"could not find symbol \"%s\" in the environment of the generic function",
symbol.getPrintName());
}
// SET_FRAME(newrho, CONS(val, FRAME(newrho)));
// SET_TAG(FRAME(newrho), symbol);
newrho.setVariable(symbol, val);
// if (missing) {
// SET_MISSING(FRAME(newrho), missing);
// if (TYPEOF(val) == PROMSXP && PRENV(val) == rho) {
// SEXP deflt;
// SET_PRENV(val, newrho);
// /* find the symbol in the method, copy its expression
// * to the promise */
// for(deflt = CAR(op); deflt != R_NilValue; deflt = CDR(deflt)) {
// if(TAG(deflt) == symbol)
// break;
// }
// if(deflt == R_NilValue)
// error(_("symbol \"%s\" not in environment of method"),
// CHAR(PRINTNAME(symbol)));
// SET_PRCODE(val, CAR(deflt));
// }
// }
}
/* copy the bindings of the spacial dispatch variables in the top
frame of the generic call to the new frame */
newrho.setVariable(DOT_DEFINED, rho.getVariable(DOT_DEFINED));
newrho.setVariable(DOT_METHOD, rho.getVariable(DOT_METHOD));
newrho.setVariable(DOT_TARGET, rho.getVariable(DOT_TARGET));
/* copy the bindings for .Generic and .Methods. We know (I think)
that they are in the second frame, so we could use that. */
newrho.setVariable(Symbols.GENERIC, newrho.getVariable(".Generic"));
newrho.setVariable(DOT_METHODS, newrho.getVariable(DOT_METHODS));
/* Find the calling context. Should be R_GlobalContext unless
profiling has inserted a CTXT_BUILTIN frame. */
Context cptr = context;
// cptr = R_GlobalContext;
// if (cptr->callflag & CTXT_BUILTIN)
// cptr = cptr->nextcontext;
/* The calling environment should either be the environment of the
generic, rho, or the environment of the caller of the generic,
the current sysparent. */
Environment callerenv = cptr.getCallingEnvironment(); /* or rho? */
/* get the rest of the stuff we need from the current context,
execute the method, and return the result */
FunctionCall call = cptr.getCall();
PairList arglist = cptr.getArguments();
SEXP val = R_execClosure(context, call, op, arglist, callerenv, newrho);
return val;
}
/* C version of the standardGeneric R function. */
public SEXP R_standardGeneric(Context context, Symbol fsym, Environment ev, SEXP fdef) {
String fname = fsym.getPrintName();
Environment f_env = context.getGlobalEnvironment().getBaseEnvironment();
SEXP mlist = Null.INSTANCE;
SEXP f;
SEXP val = Null.INSTANCE;
int nprotect = 0;
// if(!initialized)
// R_initMethodDispatch(NULL);
if (fdef instanceof Closure) {
f_env = ((Closure) fdef).getEnclosingEnvironment();
mlist = f_env.getVariable(".Methods");
if (mlist == Symbol.UNBOUND_VALUE) {
mlist = Null.INSTANCE;
}
} else if (fdef instanceof PrimitiveFunction) {
f_env = context.getBaseEnvironment();
// mlist = R_primitive_methods((PrimitiveFunction)fdef);
throw new UnsupportedOperationException();
} else {
throw new EvalException(
"invalid generic function object for method selection for function '%s': expected a function or a primitive, got an object of class \"%s\"",
fsym.getPrintName(), fdef.getAttributes().getClassVector());
}
if (mlist instanceof Null || mlist instanceof Closure || mlist instanceof PrimitiveFunction) {
f = mlist;
} else {
// f = do_dispatch(fname, ev, mlist, TRUE, TRUE);
throw new UnsupportedOperationException();
}
if (f == Null.INSTANCE) {
SEXP value =
R_S_MethodsListSelect(context, StringArrayVector.valueOf(fname), ev, mlist, f_env);
if (value == Null.INSTANCE) {
throw new EvalException(
"no direct or inherited method for function '%s' for this call", fname);
}
mlist = value;
/* now look again. This time the necessary method should
have been inserted in the MethodsList object */
f = do_dispatch(context, fname, (Environment) ev, mlist, false, true);
}
// /* loadMethod methods */
if (f.isObject()) {
f = R_loadMethod(context, f, fsym.getPrintName(), ev);
}
if (f instanceof Closure) {
return 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;
}
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;
}
