diff --git a/com.oracle.truffle.r.test.native/embedded/Makefile b/com.oracle.truffle.r.test.native/embedded/Makefile
index f8e3d2ad094a917280195a05ea510467c47750ea..77632483e40d1ca9fa6cfc7f5256b8b0fbb34373 100644
--- a/com.oracle.truffle.r.test.native/embedded/Makefile
+++ b/com.oracle.truffle.r.test.native/embedded/Makefile
@@ -1,5 +1,5 @@
#
-# Copyright (c) 2016, Oracle and/or its affiliates. All rights reserved.
+# Copyright (c) 2016, 2018, Oracle and/or its affiliates. All rights reserved.
# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
#
# This code is free software; you can redistribute it and/or modify it
@@ -53,16 +53,20 @@ C_OBJECTS := $(subst $(SRC),$(OBJ),$(C_SOURCES:.c=.o))
INCLUDE_DIR := $(NATIVE_PROJECT)/include
-all: $(OBJ)/main Makefile
+all: $(OBJ)/main $(OBJ)/embedded Makefile
$(OBJ)/main: | $(OBJ)
+$(OBJ)/embedded: | $(OBJ)
$(OBJ):
mkdir -p $(OBJ)
-
$(OBJ)/main: $(SRC)/main.c
$(CC) $(CFLAGS) -I$(INCLUDE_DIR) $< -o $(OBJ)/main -L $(FASTR_LIB_DIR) -ldl -lR $(LD_FLAGS) -Wl,-rpath,$(FASTR_LIB_DIR)
+$(OBJ)/embedded: $(SRC)/embedded.c
+ $(CC) $(CFLAGS) -I$(INCLUDE_DIR) $< -o $(OBJ)/embedded -L $(FASTR_LIB_DIR) -ldl -lR $(LD_FLAGS) -Wl,-rpath,$(FASTR_LIB_DIR)
+ cp $(SRC)/*.R $(OBJ)
+
clean:
rm -rf $(OBJ)
diff --git a/com.oracle.truffle.r.test.native/embedded/src/embedded.c b/com.oracle.truffle.r.test.native/embedded/src/embedded.c
new file mode 100644
index 0000000000000000000000000000000000000000..84d129e2e60419537abee49a0e88030dc519ea12
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/embedded/src/embedded.c
@@ -0,0 +1,207 @@
+/*
+ * Copyright (c) 2018, Oracle and/or its affiliates. All rights reserved.
+ * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
+ *
+ * This code is free software; you can redistribute it and/or modify it
+ * under the terms of the GNU General Public License version 2 only, as
+ * published by the Free Software Foundation.
+ *
+ * This code is distributed in the hope that it will be useful, but WITHOUT
+ * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+ * version 2 for more details (a copy is included in the LICENSE file that
+ * accompanied this code).
+ *
+ * You should have received a copy of the GNU General Public License version
+ * 2 along with this work; if not, write to the Free Software Foundation,
+ * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
+ *
+ * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
+ * or visit www.oracle.com if you need additional information or have any
+ * questions.
+ */
+
+// Simple program testing FastR embedded mode where R is initialized and then evaluation is controlled by the embedder
+// See also main.c for example where R is initialized and then the R's REPL is run.
+
+// Note: some of the examples were taken from GNU R tests/Embedded directory and slightly adapted
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <dlfcn.h>
+#include <sys/utsname.h>
+#include <string.h>
+#define R_INTERFACE_PTRS 1
+#include <Rinterface.h>
+#include <Rembedded.h>
+#include <R_ext/RStartup.h>
+#include <R_ext/Rdynload.h>
+
+#define CALLDEF(name, n) {#name, (DL_FUNC) &name, n}
+
+SEXP twice(SEXP x) {
+ int *xi = INTEGER(x);
+ int len = LENGTH(x);
+ SEXP res;
+ PROTECT(res = allocVector(INTSXP, len));
+ int *resi = INTEGER(res);
+ for (int i = 0; i < len; ++i) {
+ resi[i] = xi[i] * 2;
+ }
+ UNPROTECT(1);
+ return res;
+}
+
+static void checkError(int errorOccurred, const char* context) {
+ if (errorOccurred) {
+ printf("Unexpected error occurred when %s.\n", context);
+ exit(1);
+ }
+}
+
+static void source(const char* file) {
+ FILE *f;
+ if (f = fopen(file, "r")){
+ fclose(f);
+ } else {
+ printf("File '%s' is not accessible. Are you running the program from within a directory that contains this file, e.g. 'obj'?\n", file);
+ exit(1);
+ }
+
+ SEXP e;
+ PROTECT(e = lang2(install("source"), mkString(file)));
+ printf("Sourcing '%s'...\n", file);
+ int errorOccurred;
+ R_tryEval(e, R_GlobalEnv, &errorOccurred);
+ UNPROTECT(1);
+ checkError(errorOccurred, "sourcing a file");
+}
+
+/*
+ Call the function foo() with 3 arguments, 2 of which
+ are named.
+ foo(pch="+", id = 123, c(T,F))
+
+ Note that PrintValue() of the expression seg-faults.
+ We have to set the print name correctly.
+*/
+
+static void bar1() {
+ SEXP fun, pch;
+ SEXP e;
+
+ PROTECT(e = allocVector(LANGSXP, 4));
+ fun = findFun(install("foo"), R_GlobalEnv);
+ if(fun == R_NilValue) {
+ printf("No definition for function foo. Source foo.R and save the session.\n");
+ UNPROTECT(1);
+ exit(1);
+ }
+ SETCAR(e, fun);
+
+ SETCADR(e, mkString("+"));
+ SET_TAG(CDR(e), install("pch"));
+
+ SETCADDR(e, ScalarInteger(123));
+ SET_TAG(CDR(CDR(e)), install("id"));
+
+ pch = allocVector(LGLSXP, 2);
+ LOGICAL(pch)[0] = TRUE;
+ LOGICAL(pch)[1] = FALSE;
+ SETCADDDR(e, pch);
+
+ printf("Printing the expression to be eval'ed...\n");
+ PrintValue(e);
+ printf("Eval'ing the expression...\n");
+ eval(e, R_GlobalEnv);
+
+ SETCAR(e, install("foo"));
+ printf("Printing the expression to be tryEval'ed...\n");
+ PrintValue(e);
+ printf("TryEval'ing the expression...\n");
+ R_tryEval(e, R_GlobalEnv, NULL);
+
+ UNPROTECT(1);
+}
+
+int main(int argc, char **argv) {
+ setbuf(stdout, NULL);
+ char *r_home = getenv("R_HOME");
+ if (r_home == NULL) {
+ printf("R_HOME must be set\n");
+ exit(1);
+ }
+ printf("Initializing R with Rf_initEmbeddedR...\n");
+ Rf_initEmbeddedR(argc, argv);
+
+ // ------------------------------
+ // tests/Embedded/Rerror.c
+
+ /*
+ Evaluates the two expressions:
+ source("error.R")
+ and then calls foo() twice
+ where foo is defined in the file error.R
+ */
+ SEXP e;
+ int errorOccurred;
+ source("error.R");
+
+ PROTECT(e = lang1(install("foo")));
+ printf("Invoking foo() via tryEval...");
+ R_tryEval(e, R_GlobalEnv, &errorOccurred);
+ printf("errorOccurred=%d\n", errorOccurred);
+ printf("Invoking foo() via tryEval once more...");
+ R_tryEval(e, R_GlobalEnv, &errorOccurred);
+ printf("errorOccurred=%d\n", errorOccurred);
+ UNPROTECT(1);
+
+ // ------------------------------
+ // tests/Embedded/tryEval.c
+
+ printf("Trying sqrt with wrong and then correct argument...\n");
+ PROTECT(e = lang2(install("sqrt"), mkString("")));
+ SEXP val = R_tryEval(e, NULL, &errorOccurred);
+ // Note: even the official example is not PROTECTing the val
+ if(errorOccurred) {
+ printf("Caught an error calling sqrt(). Try again with a different argument.\n");
+ }
+ SETCAR(CDR(e), ScalarInteger(9));
+ val = R_tryEval(e, NULL, &errorOccurred);
+ if(errorOccurred) {
+ printf("Caught another error calling sqrt()\n");
+ } else {
+ Rf_PrintValue(val);
+ }
+ UNPROTECT(1);
+
+ // ------------------------------
+ // tests/Embedded/RNamedCall.c
+
+ source("foo.R");
+ printf("Calling foo with named arguments...\n");
+ bar1();
+
+ // ------------------------------
+ // Register custom native symbols and invoke them
+
+ printf("Calling R_getEmbeddingDllInfo...\n");
+ DllInfo *eDllInfo = R_getEmbeddingDllInfo();
+ R_CallMethodDef CallEntries[] = {
+ CALLDEF(twice, 2),
+ {NULL, NULL, 0}
+ };
+ R_registerRoutines(eDllInfo, NULL, CallEntries, NULL, NULL);
+ source("embedding.R");
+ PROTECT(e = lang1(install("runTwice")));
+ SEXP twiceRes = R_tryEval(e, R_GlobalEnv, &errorOccurred);
+ checkError(errorOccurred, "evaluating runTwice");
+ UNPROTECT(1);
+ Rf_PrintValue(twiceRes);
+
+
+ Rf_endEmbeddedR(0);
+ printf("DONE\n");
+ return 0;
+}
+
diff --git a/com.oracle.truffle.r.test.native/embedded/src/embedding.R b/com.oracle.truffle.r.test.native/embedded/src/embedding.R
new file mode 100644
index 0000000000000000000000000000000000000000..4170f8be6123e436e341c270c2e1a318a25309fa
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/embedded/src/embedding.R
@@ -0,0 +1,6 @@
+
+runTwice <- function() {
+ cat("getDLLRegisteredRoutines('(embedding)'):\n")
+ print(getDLLRegisteredRoutines("(embedding)"))
+ .Call(getDLLRegisteredRoutines("(embedding)")[[".Call"]][[1]], 1:5);
+}
\ No newline at end of file
diff --git a/com.oracle.truffle.r.test.native/embedded/src/error.R b/com.oracle.truffle.r.test.native/embedded/src/error.R
new file mode 100644
index 0000000000000000000000000000000000000000..3f4a2b61f4d26e38542a67e005755c4362603197
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/embedded/src/error.R
@@ -0,0 +1,6 @@
+foo <-
+function()
+{
+ on.exit(print(1:10))
+ stop("Stopping in function foo")
+}
diff --git a/com.oracle.truffle.r.test.native/embedded/src/foo.R b/com.oracle.truffle.r.test.native/embedded/src/foo.R
new file mode 100644
index 0000000000000000000000000000000000000000..06ef4aa9ee43023ac42d8bd9b28df54aff052cc7
--- /dev/null
+++ b/com.oracle.truffle.r.test.native/embedded/src/foo.R
@@ -0,0 +1,8 @@
+foo <-
+function(...)
+{
+ args <- list(...)
+ print(args)
+ print(names(args))
+ TRUE
+}
diff --git a/com.oracle.truffle.r.test.native/embedded/src/main.c b/com.oracle.truffle.r.test.native/embedded/src/main.c
index 9de0840477855701f938db79008498e274a1e27f..03a6f18fb3718fe4e13bd038b2fbf5e049e12409 100644
--- a/com.oracle.truffle.r.test.native/embedded/src/main.c
+++ b/com.oracle.truffle.r.test.native/embedded/src/main.c
@@ -21,8 +21,8 @@
* questions.
*/
-// A simple test program for FastR embedded mode.
-// compile with "gcc -I include main.c -ldl
+// A simple program testing FastR embedded mode use case where R is initialized and then the R's REPL is run.
+// See embedded.c for example where R is initialized and then evaluation is controlled by the embedder
#include <stdlib.h>
#include <stdio.h>
@@ -40,23 +40,23 @@ void (*ptr_stdR_CleanUp)(SA_TYPE, int, int);
void (*ptr_stdR_Suicide)(const char *);
void testR_CleanUp(SA_TYPE x, int y, int z) {
- printf("test Cleanup\n");
- (ptr_stdR_CleanUp)(x, y, z);
+ printf("test Cleanup\n");
+ (ptr_stdR_CleanUp)(x, y, z);
}
void testR_Suicide(const char *msg) {
- printf("testR_Suicide: %s\n",msg);
- (ptr_stdR_Suicide(msg));
+ printf("testR_Suicide: %s\n",msg);
+ (ptr_stdR_Suicide(msg));
}
int testR_ReadConsole(const char *prompt, unsigned char *buf, int len, int h) {
- fputs(prompt, stdout);
- fflush(stdout); /* make sure prompt is output */
- if (fgets((char *)buf, len, stdin) == NULL) {
- return 0;
- } else {
- return 1;
- }
+ fputs(prompt, stdout);
+ fflush(stdout); /* make sure prompt is output */
+ if (fgets((char *)buf, len, stdin) == NULL) {
+ return 0;
+ } else {
+ return 1;
+ }
}
void testR_WriteConsole(const char *buf, int len) {
@@ -65,31 +65,28 @@ void testR_WriteConsole(const char *buf, int len) {
}
int main(int argc, char **argv) {
- char *r_home = getenv("R_HOME");
- if (r_home == NULL) {
- printf("R_HOME must be set\n");
- exit(1);
- }
- printf("Initializing R with Rf_initialize_R...\n");
- Rf_initialize_R(argc, argv);
- structRstart rp;
- Rstart Rp = &rp;
- R_DefParams(Rp);
- Rp->SaveAction = SA_SAVEASK;
- printf("Initializing R with R_SetParams...\n");
- R_SetParams(Rp);
- ptr_stdR_CleanUp = ptr_R_CleanUp;
- ptr_R_CleanUp = &testR_CleanUp;
- ptr_stdR_Suicide = ptr_R_Suicide;
- ptr_R_Suicide = &testR_Suicide;
- ptr_R_ReadConsole = &testR_ReadConsole;
- ptr_R_WriteConsole = &testR_WriteConsole;
- // TODO:
- // printf("Calling R_getEmbeddingDllInfo...\n");
- // DllInfo *eDllInfo = R_getEmbeddingDllInfo();
- printf("Running R with Rf_mainloop...\n");
- Rf_mainloop();
- printf("Closing R with Rf_endEmbeddedR...\n");
- Rf_endEmbeddedR(0);
- printf("Done");
+ char *r_home = getenv("R_HOME");
+ if (r_home == NULL) {
+ printf("R_HOME must be set\n");
+ exit(1);
+ }
+ printf("Initializing R with Rf_initialize_R...\n");
+ Rf_initialize_R(argc, argv);
+ structRstart rp;
+ Rstart Rp = &rp;
+ R_DefParams(Rp);
+ Rp->SaveAction = SA_SAVEASK;
+ printf("Initializing R with R_SetParams...\n");
+ R_SetParams(Rp);
+ ptr_stdR_CleanUp = ptr_R_CleanUp;
+ ptr_R_CleanUp = &testR_CleanUp;
+ ptr_stdR_Suicide = ptr_R_Suicide;
+ ptr_R_Suicide = &testR_Suicide;
+ ptr_R_ReadConsole = &testR_ReadConsole;
+ ptr_R_WriteConsole = &testR_WriteConsole;
+ printf("Running R with Rf_mainloop...\n");
+ Rf_mainloop();
+ printf("Closing R with Rf_endEmbeddedR...\n");
+ Rf_endEmbeddedR(0);
+ printf("Done");
}