More extensive embedding examples in com.oracle.truffle.r.test.native/embedded

com.oracle.truffle.r.test.native/embedded/Makefile

 #
-# 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)

com.oracle.truffle.r.test.native/embedded/src/embedded.c

+/*
+ * 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;
+}
+

com.oracle.truffle.r.test.native/embedded/src/embedding.R

+
+runTwice <- function() {
+    cat("getDLLRegisteredRoutines('(embedding)'):\n")
+    print(getDLLRegisteredRoutines("(embedding)"))
+    .Call(getDLLRegisteredRoutines("(embedding)")[[".Call"]][[1]], 1:5);
+}
\ No newline at end of file

com.oracle.truffle.r.test.native/embedded/src/error.R

+foo <-
+function()
+{
+    on.exit(print(1:10))
+    stop("Stopping in function foo")
+}

com.oracle.truffle.r.test.native/embedded/src/foo.R

+foo <-
+function(...)
+{
+    args <- list(...)
+    print(args)
+    print(names(args))
+    TRUE
+}

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");
 }