Add strings test to testrffi

(cherry picked from commit 3bf81b1)

Author: Pavel Marek

com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/init.c

@@ -26,6 +26,7 @@
 #include <R_ext/Rdynload.h>
 #include "testrffi.h"
 #include "serialization.h"
+#include "strings.h"
 #include "rapi_helpers.h"
 #include "rffiwrappers.h"
 
@@ -127,6 +128,10 @@ static const R_CallMethodDef CallEntries[] = {
         CALLDEF(testPRIMFUN, 2),
         CALLDEF(serialize, 1),
         CALLDEF(testInstallTrChar, 2),
+        CALLDEF(replace_nth_str, 3),
+        CALLDEF(nth_str, 2),
+        CALLDEF(create_empty_str, 1),
+        CALLDEF(str_tests, 0),
         #include "init_api.h"
         {NULL, NULL, 0}
 };

com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/strings.c

@@ -0,0 +1,94 @@
+/*
+ * Copyright (c) 2021, 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 3 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 3 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
+ * 3 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.
+ */
+
+#include "strings.h"
+
+/**
+* Replaces an n-th string in place from given character vector with `replacement`.
+* Is a wrapper for SET_STRING_ELT
+* @param n Index of the string to replace.
+* @param replacement Replacement for the string.
+* @returns New string vector with the replacement.
+*/
+SEXP replace_nth_str(SEXP str, SEXP n, SEXP replacement) {
+    if (TYPEOF(str) != STRSXP || LENGTH(str) == 0) {
+        error("`str` expected STRSXP type with length greater than zero");
+    }
+    if (TYPEOF(n) != INTSXP || LENGTH(n) != 1) {
+        error("`n` expected integer of length 1");
+    }
+    if (TYPEOF(replacement) != STRSXP || LENGTH(replacement) != 1) {
+        error("`replacement` expected STRSXP of length 1");
+    }
+    const char *replacement_char = CHAR(STRING_ELT(replacement, 0));
+    int idx = INTEGER_ELT(n, 0);
+    if (LENGTH(str) < idx) {
+        error("Trying to replace a string outside of bounds");
+    }
+    for (int i = 0; i < LENGTH(str); i++) {
+        if (i == idx) {
+            SET_STRING_ELT(str, i, mkChar(replacement_char));
+        }
+    }
+    return str;
+}
+
+/**
+* A wrapper for STRING_ELT.
+*/
+SEXP nth_str(SEXP str, SEXP n) {
+    int idx = INTEGER_ELT(n, 0);
+    return ScalarString(STRING_ELT(str, idx));
+}
+
+/**
+* Creates a native empty character vector. For the purpose of demonstration that we
+* can create a native character vector, and then modify it in R code.
+*/
+SEXP create_empty_str(SEXP n) {
+    int n_int = INTEGER_ELT(n, 0);
+    SEXP str = PROTECT(allocVector(STRSXP, n_int));
+    for (int i = 0; i < n_int; i++) {
+        SET_STRING_ELT(str, i, mkChar(""));
+    }
+    UNPROTECT(1);
+    return str;
+}
+
+/**
+* Runs all other native tests
+*/
+SEXP str_tests() {
+    SEXP str = PROTECT(allocVector(STRSXP, 1));
+    SEXP elem = mkChar("Hello");
+    SET_STRING_ELT(str, 0, elem);
+    SEXP elem_from_elt = STRING_ELT(str, 0);
+    if (elem != elem_from_elt) {
+        error("elem != elem_from_elt");
+    }
+    // TODO: Add some more tests?
+    // ...
+
+    UNPROTECT(1);
+    return R_NilValue;
+}

com.oracle.truffle.r.test.native/packages/testrffi/testrffi/src/strings.h

@@ -0,0 +1,28 @@
+/*
+ * Copyright (c) 2021, 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 3 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 3 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
+ * 3 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.
+ */
+#include <Rinternals.h>
+
+SEXP replace_nth_str(SEXP str, SEXP n, SEXP replacement);
+SEXP nth_str(SEXP str, SEXP n);
+SEXP create_empty_str(SEXP n);
+SEXP str_tests();

com.oracle.truffle.r.test.native/packages/testrffi/testrffi/tests/strings.R

@@ -0,0 +1,75 @@
+# Copyright (c) 2021, 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 3 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 3 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
+# 3 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.
+
+library(testrffi)
+
+# Replace n-th string from `str` character vector with `replacement`.
+# `n` is zero-based
+replace_nth_str <- function(str, i, replacement) {
+    stopifnot(is.character(str) && length(str) > 0)
+    stopifnot(is.integer(i) && length(i) == 1)
+    stopifnot(is.character(replacement) && length(replacement) == 1)
+    .Call("replace_nth_str", str, i, replacement)
+}
+
+# Returns n-th element from `str`.
+nth_str <- function(str, i) {
+    stopifnot(is.character(str) && length(str) > 0)
+    stopifnot(is.integer(i) && length(i) == 1)
+    .Call("nth_str", str, i)
+}
+
+create_empty_str <- function(i) {
+    stopifnot(is.integer(i) && length(i) == 1)
+    .Call("create_empty_str", i)
+}
+
+# Rest of the native tests
+run_all_native_tests <- function() {
+    .Call("str_tests")
+}
+
+s <- c("a", "b", "c")
+stopifnot(nth_str(s, 0L) == "a")
+stopifnot(nth_str(s, 1L) == "b")
+stopifnot(nth_str(s, 2L) == "c")
+
+# Replace some elements of a character vector in place with wrapper functions.
+stopifnot( replace_nth_str(c("a", "b"), 0L, "foo") == c("foo", "b"))
+stopifnot( replace_nth_str(c("a", "b"), 1L, "foo") == c("a", "foo"))
+
+s <- c("a", "b", "c")
+replace_nth_str(s, 0L, "X")
+stopifnot(s == c("X", "b", "c"))
+replace_nth_str(s, 2L, "Y")
+stopifnot(s == c("X", "b", "Y"))
+
+# Create a vector in native and manipulate with it in R.
+s <- create_empty_str(3L)
+s[1] <- "X"
+stopifnot(s == c("X", "", ""))
+replace_nth_str(s, 1L, "Y")
+stopifnot(s == c("X", "Y", ""))
+s[3] <- "Z"
+stopifnot(s == c("X", "Y", "Z"))
+
+# Run rest of the native tests
+run_all_native_tests()