From b8c651ff27b5bc3a005f48107b99784cb602e3cd Mon Sep 17 00:00:00 2001
From: stepan <stepan.sindelar@oracle.com>
Date: Wed, 28 Mar 2018 10:59:33 +0200
Subject: [PATCH] DATAPTR supports complex, charsxp and shows informative error
for character vectors
---
.../fficall/src/common/Rinternals_common.c | 15 +++++++++++----
.../packages/testrffi/testrffi/R/testrffi.R | 4 ++++
.../packages/testrffi/testrffi/src/init.c | 1 +
.../packages/testrffi/testrffi/src/testrffi.c | 17 ++++++++++++++++-
.../packages/testrffi/testrffi/src/testrffi.h | 2 ++
.../testrffi/testrffi/tests/simpleTests.R | 4 ++++
6 files changed, 38 insertions(+), 5 deletions(-)
diff --git a/com.oracle.truffle.r.native/fficall/src/common/Rinternals_common.c b/com.oracle.truffle.r.native/fficall/src/common/Rinternals_common.c
index db517f214d..d24ede22e8 100644
--- a/com.oracle.truffle.r.native/fficall/src/common/Rinternals_common.c
+++ b/com.oracle.truffle.r.native/fficall/src/common/Rinternals_common.c
@@ -1,5 +1,5 @@
/*
- * Copyright (c) 2015, 2017, Oracle and/or its affiliates. All rights reserved.
+ * Copyright (c) 2015, 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
@@ -113,9 +113,16 @@ void *DATAPTR(SEXP x) {
return LOGICAL(x);
} else if (type == RAWSXP) {
return RAW(x);
- } else {
- printf("DATAPTR %d\n", type);
- unimplemented("R_DATAPTR");
+ } else if (type == CPLXSXP) {
+ return COMPLEX(x);
+ } else if (type == CHARSXP) {
+ return R_CHAR(x);
+ } else if (type == STRSXP) {
+ printf("FastR does not support DATAPTR macro with character vectors, please use SET_STRING_ELT or STRING_ELT.\n");
+ exit(1);
+ } else {
+ printf("DATAPTR macro with SEXPTYPE %d is not supported.\n", type);
+ exit(1);
return NULL;
}
}
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/R/testrffi.R b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/R/testrffi.R
index 54ea96bf5f..0d07fac889 100644
--- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/R/testrffi.R
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/R/testrffi.R
@@ -224,3 +224,7 @@ rffi.RfRMultinom <- function() {
rffi.RfFunctions <- function() {
.Call('test_RfFunctions')
}
+
+rffi.testDATAPTR <- function(strings, testSingleString) {
+ .Call('test_DATAPTR', strings, testSingleString)
+}
\ No newline at end of file
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c
index 38516b5c98..58ee3bacce 100644
--- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c
@@ -90,6 +90,7 @@ static const R_CallMethodDef CallEntries[] = {
CALLDEF(test_RfRandomFunctions, 0),
CALLDEF(test_RfRMultinom, 0),
CALLDEF(test_RfFunctions, 0),
+ CALLDEF(test_DATAPTR, 2),
#include "init_api.h"
{NULL, NULL, 0}
};
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.c b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.c
index 0229801217..1fb610c2ae 100644
--- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.c
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.c
@@ -23,11 +23,11 @@
// A very simple test of the R FFI interface
+#define USE_RINTERNALS
#include <R.h>
#include <Rdefines.h>
#include <Rinterface.h>
#include <Rinternals.h>
-#include <Rinterface.h>
#include <Rmath.h>
#include <R_ext/Connections.h>
#include <R_ext/Parse.h>
@@ -718,3 +718,18 @@ SEXP test_RfFunctions() {
return v;
}
+SEXP test_DATAPTR(SEXP strings, SEXP testSingleChar) {
+ if (asLogical(testSingleChar)) {
+ void* data = DATAPTR(STRING_ELT(strings, 0));
+ printf("DATAPTR(STRING_ELT(strings, 0)) == '%s'\n", (char *)data);
+ } else {
+ // pointer to CHARSXP array
+ void* data = DATAPTR(strings);
+ for (int i = 0; i < LENGTH(strings); ++i) {
+ printf("DATAPTR(strings)[%d] == '%s'\n", i, R_CHAR(((SEXP*)data)[i]));
+ }
+ }
+ fflush(stdout);
+ return R_NilValue;
+}
+
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.h b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.h
index eac32181f6..56b758f24a 100644
--- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.h
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/testrffi.h
@@ -122,3 +122,5 @@ extern SEXP test_RfRandomFunctions();
extern SEXP test_RfRMultinom();
extern SEXP test_RfFunctions();
+
+extern SEXP test_DATAPTR(SEXP,SEXP);
diff --git a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R
index dfd740c94c..91f4ba3cd9 100644
--- a/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R
+++ b/com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/simpleTests.R
@@ -150,6 +150,10 @@ setAttrTarget
typeof(api.ATTRIB(mtcars))
api.ATTRIB(structure(c(1,2,3), myattr3 = 33))
+invisible(rffi.testDATAPTR('hello', testSingleString = T));
+# Ignored: FastR does not support DATAPTR for character vectors
+# rffi.testDATAPTR(c('hello', 'world'), testSingleString = F);
+
# SET_OBJECT
# FastR does not fully support the SET_OBJECT fully,
# the test is left here in case there is a need to actually implement it.
--
GitLab