From 424edf22f6b50ce17749df4f7d83d623db05398d Mon Sep 17 00:00:00 2001
From: Lukas Stadler <lukas.stadler@oracle.com>
Date: Wed, 30 Sep 2015 14:56:34 +0200
Subject: [PATCH] more function implementations in CallRFFIHelper
---
.../fficall/jni/src/misc.c | 7 +-
.../fficall/jni/src/rf_functions.c | 128 ++++++++++++++++--
.../r/runtime/ffi/jnr/CallRFFIHelper.java | 79 +++++++++--
3 files changed, 190 insertions(+), 24 deletions(-)
diff --git a/com.oracle.truffle.r.native/fficall/jni/src/misc.c b/com.oracle.truffle.r.native/fficall/jni/src/misc.c
index d3f4292619..eef818af3a 100644
--- a/com.oracle.truffle.r.native/fficall/jni/src/misc.c
+++ b/com.oracle.truffle.r.native/fficall/jni/src/misc.c
@@ -35,7 +35,8 @@ void init_misc(JNIEnv *env) {
}
char *dgettext(const char *domainname, const char *msgid) {
- unimplemented("dgettext");
+ printf("dgettext: '%s'\n", msgid);
+ return (char*) msgid;
}
const char *R_CHAR(SEXP string) {
@@ -85,10 +86,6 @@ int R_IsNaN(double x) {
return (*env)->CallStaticBooleanMethod(env, RRuntimeClass, isNAorNaNMethodID, x);
}
-void REprintf(const char *x, ...) {
- unimplemented("REprintf");
-}
-
R_len_t R_BadLongVector(SEXP x, const char *y, int z) {
unimplemented("R_BadLongVector");
}
diff --git a/com.oracle.truffle.r.native/fficall/jni/src/rf_functions.c b/com.oracle.truffle.r.native/fficall/jni/src/rf_functions.c
index 8486b64ef7..82d1e4f859 100644
--- a/com.oracle.truffle.r.native/fficall/jni/src/rf_functions.c
+++ b/com.oracle.truffle.r.native/fficall/jni/src/rf_functions.c
@@ -35,6 +35,7 @@ static jmethodID Rf_allocateArrayMethodID;
static jmethodID Rf_allocateMatrixMethodID;
static jmethodID Rf_duplicateMethodID;
static jmethodID Rf_consMethodID;
+static jmethodID Rf_evalMethodID;
static jmethodID Rf_defineVarMethodID;
static jmethodID Rf_findVarMethodID;
static jmethodID Rf_findVarInFrameMethodID;
@@ -49,6 +50,10 @@ static jmethodID Rf_NewHashedEnvMethodID;
static jmethodID Rf_rPsortMethodID;
static jmethodID Rf_iPsortMethodID;
static jmethodID RprintfMethodID;
+static jmethodID R_FindNamespaceMethodID;
+static jmethodID Rf_GetOption1MethodID;
+static jmethodID Rf_gsetVarMethodID;
+static jmethodID Rf_inheritsMethodID;
void init_rf_functions(JNIEnv *env) {
Rf_ScalarIntegerMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_ScalarInteger", "(I)Lcom/oracle/truffle/r/runtime/data/RIntVector;", 1);
@@ -56,6 +61,7 @@ void init_rf_functions(JNIEnv *env) {
Rf_ScalarStringMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_ScalarString", "(Ljava/lang/String;)Lcom/oracle/truffle/r/runtime/data/RStringVector;", 1);
Rf_ScalarLogicalMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_ScalarLogical", "(I)Lcom/oracle/truffle/r/runtime/data/RLogicalVector;", 1);
Rf_consMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_cons", "(Ljava/lang/Object;Ljava/lang/Object;)Ljava/lang/Object;", 1);
+ Rf_evalMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_eval", "(Ljava/lang/Object;Ljava/lang/Object;)Ljava/lang/Object;", 1);
Rf_defineVarMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_defineVar", "(Ljava/lang/Object;Ljava/lang/Object;Ljava/lang/Object;)V", 1);
Rf_findVarMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_findVar", "(Ljava/lang/Object;Ljava/lang/Object;)Ljava/lang/Object;", 1);
Rf_findVarInFrameMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_findVarInFrame", "(Ljava/lang/Object;Ljava/lang/Object;)Ljava/lang/Object;", 1);
@@ -72,6 +78,10 @@ void init_rf_functions(JNIEnv *env) {
Rf_duplicateMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_duplicate", "(Ljava/lang/Object;)Ljava/lang/Object;", 1);
Rf_NewHashedEnvMethodID = checkGetMethodID(env, RDataFactoryClass, "createNewEnv", "(Lcom/oracle/truffle/r/runtime/env/REnvironment;Ljava/lang/String;ZI)Lcom/oracle/truffle/r/runtime/env/REnvironment;", 1);
RprintfMethodID = checkGetMethodID(env, CallRFFIHelperClass, "printf", "(Ljava/lang/String;)V", 1);
+ R_FindNamespaceMethodID = checkGetMethodID(env, CallRFFIHelperClass, "R_FindNamespace", "(Ljava/lang/Object;)Ljava/lang/Object;", 1);
+ Rf_GetOption1MethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_GetOption1", "(Ljava/lang/Object;)Ljava/lang/Object;", 1);
+ Rf_gsetVarMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_gsetVar", "(Ljava/lang/Object;Ljava/lang/Object;Ljava/lang/Object;)V", 1);
+ Rf_inheritsMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_inherits", "(Ljava/lang/Object;Ljava/lang/String;)I", 1);
// Rf_rPsortMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_rPsort", "(Lcom/oracle/truffle/r/runtime/data/RDoubleVector;II)", 1);
// Rf_iPsortMethodID = checkGetMethodID(env, CallRFFIHelperClass, "Rf_iPsort", "(Lcom/oracle/truffle/r/runtime/data/RIntVector;II)", 1);
}
@@ -115,14 +125,14 @@ SEXP Rf_allocVector3(SEXPTYPE t, R_xlen_t len, R_allocator_t* allocator) {
}
SEXP Rf_allocArray(SEXPTYPE t, SEXP dims) {
- TRACE(TARG2d, t, len);
+ TRACE(TARG2d, t, dims);
JNIEnv *thisenv = getEnv();
SEXP result = (*thisenv)->CallStaticObjectMethod(thisenv, CallRFFIHelperClass, Rf_allocateArrayMethodID, t, dims);
return checkRef(thisenv, result);
}
SEXP Rf_allocMatrix(SEXPTYPE mode, int nrow, int ncol) {
- TRACE(TARG2d, t, len);
+ TRACE(TARG2d, mode, nrow, ncol);
JNIEnv *thisenv = getEnv();
SEXP result = (*thisenv)->CallStaticObjectMethod(thisenv, CallRFFIHelperClass, Rf_allocateMatrixMethodID, mode, nrow, ncol);
return checkRef(thisenv, result);
@@ -145,8 +155,9 @@ void Rf_defineVar(SEXP symbol, SEXP value, SEXP rho) {
}
SEXP Rf_eval(SEXP expr, SEXP env) {
- unimplemented("Rf_eval)");
- return NULL;
+ JNIEnv *thisenv = getEnv();
+ SEXP result = (*thisenv)->CallStaticObjectMethod(thisenv, CallRFFIHelperClass, Rf_evalMethodID, expr, env);
+ return checkRef(thisenv, result);
}
SEXP Rf_findFun(SEXP symbol, SEXP rho) {
@@ -196,8 +207,9 @@ SEXP Rf_duplicated(SEXP x, Rboolean y) {
}
Rboolean Rf_inherits(SEXP x, const char * klass) {
- unimplemented("Rf_inherits)");
- return FALSE;
+ JNIEnv *thisenv = getEnv();
+ jstring klazz = (*thisenv)->NewStringUTF(thisenv, klass);
+ return (*thisenv)->CallStaticIntMethod(thisenv, CallRFFIHelperClass, Rf_inheritsMethodID, x, klazz);
}
Rboolean Rf_isReal(SEXP x) {
@@ -253,8 +265,9 @@ Rboolean Rf_isString(SEXP s) {
}
cetype_t Rf_getCharCE(SEXP x) {
- unimplemented("Rf_getCharCE");
- return CE_NATIVE;
+ // unimplemented("Rf_getCharCE");
+ // TODO: real implementation
+ return CE_NATIVE;
}
SEXP Rf_mkChar(const char *x) {
@@ -383,6 +396,28 @@ void Rprintf(const char *format, ...) {
(*thisenv)->CallStaticObjectMethod(thisenv, CallRFFIHelperClass, RprintfMethodID, string);
}
+/*
+ REprintf is used by the error handler do not add
+ anything unless you're sure it won't
+ cause problems
+*/
+void REprintf(const char *format, ...)
+{
+ // TODO: determine correct target for this message
+ char buf[8192];
+ va_list(ap);
+ va_start(ap,format);
+ Rvsnprintf(buf, BUFSIZE - 1, format, ap);
+ va_end(ap);
+ JNIEnv *thisenv = getEnv();
+ jstring string = (*thisenv)->NewStringUTF(thisenv, buf);
+ (*thisenv)->CallStaticObjectMethod(thisenv, CallRFFIHelperClass, RprintfMethodID, string);
+}
+
+void R_FlushConsole(void) {
+ // ignored
+}
+
// Tools package support, not in public API
SEXP R_NewHashedEnv(SEXP parent, SEXP size) {
@@ -398,8 +433,11 @@ SEXP Rf_classgets(SEXP x, SEXP y) {
}
const char *Rf_translateChar(SEXP x) {
- unimplemented("Rf_translateChar");
- return NULL;
+// unimplemented("Rf_translateChar");
+ // TODO: proper implementation
+ const char *result = CHAR(x);
+// printf("translateChar: '%s'\n", result);
+ return result;
}
const char *Rf_translateChar0(SEXP x) {
@@ -419,6 +457,76 @@ const char *Rf_type2char(SEXPTYPE x) {
SEXP Rf_type2str(SEXPTYPE x) {
unimplemented("Rf_type2str");
+ return R_NilValue;
return NULL;
}
+SEXP R_FindNamespace(SEXP info) {
+ JNIEnv *thisenv = getEnv();
+ SEXP result = (*thisenv)->CallStaticObjectMethod(thisenv, CallRFFIHelperClass, R_FindNamespaceMethodID, info);
+ return checkRef(thisenv, result);
+}
+
+
+SEXP GetOption1(SEXP tag)
+{
+ JNIEnv *thisenv = getEnv();
+ SEXP result = (*thisenv)->CallStaticObjectMethod(thisenv, CallRFFIHelperClass, Rf_GetOption1MethodID, tag);
+ return checkRef(thisenv, result);
+}
+
+int GetOptionCutoff(void)
+{
+ int w;
+ w = asInteger(GetOption1(install("deparse.cutoff")));
+ if (w == NA_INTEGER || w <= 0) {
+ warning(_("invalid 'deparse.cutoff', used 60"));
+ w = 60;
+ }
+ return w;
+}
+
+#define R_MIN_WIDTH_OPT 10
+#define R_MAX_WIDTH_OPT 10000
+#define R_MIN_DIGITS_OPT 0
+#define R_MAX_DIGITS_OPT 22
+
+int GetOptionWidth(void)
+{
+ int w;
+ w = asInteger(GetOption1(install("width")));
+ if (w < R_MIN_WIDTH_OPT || w > R_MAX_WIDTH_OPT) {
+ warning(_("invalid printing width, used 80"));
+ return 80;
+ }
+ return w;
+}
+
+int GetOptionDigits(void)
+{
+ int d;
+ d = asInteger(GetOption1(install("digits")));
+ if (d < R_MIN_DIGITS_OPT || d > R_MAX_DIGITS_OPT) {
+ warning(_("invalid printing digits, used 7"));
+ return 7;
+ }
+ return d;
+}
+
+Rboolean Rf_GetOptionDeviceAsk(void)
+{
+ int ask;
+ ask = asLogical(GetOption1(install("device.ask.default")));
+ if(ask == NA_LOGICAL) {
+ warning(_("invalid value for \"device.ask.default\", using FALSE"));
+ return FALSE;
+ }
+ return ask != 0;
+}
+
+void Rf_gsetVar(SEXP symbol, SEXP value, SEXP rho)
+{
+ JNIEnv *thisenv = getEnv();
+ (*thisenv)->CallStaticObjectMethod(thisenv, CallRFFIHelperClass, Rf_gsetVarMethodID, symbol, value, rho);
+}
+
diff --git a/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIHelper.java b/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIHelper.java
index 2501963a3b..47e65caf32 100644
--- a/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIHelper.java
+++ b/com.oracle.truffle.r.runtime.ffi/src/com/oracle/truffle/r/runtime/ffi/jnr/CallRFFIHelper.java
@@ -215,6 +215,37 @@ public class CallRFFIHelper {
}
}
+ private static RStringVector getClassHr(Object v) {
+ if (v instanceof RAttributable) {
+ return ((RAttributable) v).getClassHierarchy();
+ } else if (v instanceof Byte) {
+ return RLogicalVector.implicitClassHeader;
+ } else if (v instanceof String) {
+ return RStringVector.implicitClassHeader;
+ } else if (v instanceof Integer) {
+ return RIntVector.implicitClassHeader;
+ } else if (v instanceof Double) {
+ return RDoubleVector.implicitClassHeader;
+ } else if (v instanceof RComplex) {
+ return RComplexVector.implicitClassHeader;
+ } else if (v instanceof RRaw) {
+ return RRawVector.implicitClassHeader;
+ } else {
+ guaranteeInstanceOf(v, RNull.class);
+ return RNull.implicitClassHeader;
+ }
+ }
+
+ static int Rf_inherits(Object x, String clazz) {
+ RStringVector hierarchy = getClassHr(x);
+ for (int i = 0; i < hierarchy.getLength(); i++) {
+ if (hierarchy.getDataAt(i).equals(clazz)) {
+ return 1;
+ }
+ }
+ return 0;
+ }
+
static int Rf_isString(Object x) {
return RRuntime.asString(x) == null ? 0 : 1;
}
@@ -433,23 +464,18 @@ public class CallRFFIHelper {
static Object TAG(Object e) {
guaranteeInstanceOf(e, RPairList.class);
-// System.out.println("TAG: " + e);
return ((RPairList) e).getTag();
}
static Object CAR(Object e) {
guaranteeInstanceOf(e, RPairList.class);
-// System.out.print("CAR: " + e);
Object car = ((RPairList) e).car();
-// System.out.println(" = " + car);
return car;
}
static Object CDR(Object e) {
guaranteeInstanceOf(e, RPairList.class);
-// System.out.print("CDR: " + e);
Object cdr = ((RPairList) e).cdr();
-// System.out.println(" = " + cdr);
return cdr;
}
@@ -464,11 +490,46 @@ public class CallRFFIHelper {
}
static Object SETCDR(Object x, Object y) {
- if (x instanceof RPairList) {
- ((RPairList) x).setCdr(y);
- return x; // TODO check or y?
+ guaranteeInstanceOf(x, RPairList.class);
+ ((RPairList) x).setCdr(y);
+ return x; // TODO check or y?
+ }
+
+ static Object R_FindNamespace(Object name) {
+ Object result = RContext.getInstance().stateREnvironment.getNamespaceRegistry().get(RRuntime.asString(name));
+ return result;
+ }
+
+ static Object Rf_eval(Object expr, Object env) {
+ guarantee(env instanceof REnvironment);
+ Object result;
+ if (expr instanceof RPromise) {
+ result = RContext.getRRuntimeASTAccess().forcePromise(expr);
+ } else if (expr instanceof RExpression) {
+ result = RContext.getEngine().eval((RExpression) expr, (REnvironment) env, 0);
+ } else if (expr instanceof RLanguage) {
+ result = RContext.getEngine().eval((RLanguage) expr, (REnvironment) env, 0);
} else {
- throw RInternalError.unimplemented();
+ // just return value
+ result = expr;
+ }
+ return result;
+ }
+
+ static Object Rf_GetOption1(Object tag) {
+ guarantee(tag instanceof RSymbol);
+ Object result = RContext.getInstance().stateROptions.getValue(((RSymbol) tag).getName());
+ return result;
+ }
+
+ static void Rf_gsetVar(Object symbol, Object value, Object rho) {
+ guarantee(symbol instanceof RSymbol);
+ REnvironment baseEnv = RContext.getInstance().stateREnvironment.getBaseEnv();
+ guarantee(rho == baseEnv);
+ try {
+ baseEnv.put(((RSymbol) symbol).getName(), value);
+ } catch (PutException e) {
+ e.printStackTrace();
}
}
--
GitLab