-
Miloslav Metelka authoredMiloslav Metelka authored
testrffi.c 15.54 KiB
/*
* 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
* 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.
*/
// A very simple test of the R FFI interface
#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>
#include <string.h>
#include "testrffi.h"
void dotCModifiedArguments(int* len, int* idata, double* rdata, int* ldata, char** cdata) {
for (int i = 0; i < len[0]; i++) {
idata[i] ++;
}
for (int i = 0; i < len[0]; i++) {
rdata[i] *= 0.2;
}
for (int i = 0; i < len[0]; i++) {
ldata[i] = ldata[i] == 0 ? 1 : 0;
}
for (int i = 0; i < len[0]; i++) {
for (int j = 0; cdata[i][j] != 0; j++) {
char c = cdata[i][j];
cdata[i][j] = (c >= '0' && c <= '9') ? c - '0' + 'a' : 'r';
}
}
}
SEXP addInt(SEXP a, SEXP b) {
int aInt = INTEGER_VALUE(a);
int bInt = INTEGER_VALUE(b);
return ScalarInteger(aInt + bInt);
}
SEXP addDouble(SEXP a, SEXP b) {
double aDouble = NUMERIC_VALUE(a);
double bDouble = NUMERIC_VALUE(b);
return ScalarReal(aDouble + bDouble);
}
SEXP populateIntVector(SEXP n) {
SEXP v;
int intN = INTEGER_VALUE(n);
PROTECT(v = allocVector(INTSXP, intN)); int i;
for (i = 0; i < intN; i++) {
INTEGER(v)[i] = i;
}
UNPROTECT(1);
return v;
}
SEXP populateLogicalVector(SEXP n) {
SEXP v;
int intN = INTEGER_VALUE(n);
PROTECT(v = allocVector(LGLSXP, intN));
int i;
for (i = 0; i < intN; i++) {
LOGICAL(v)[i] = i == 0 ? TRUE : i == 1 ? NA_INTEGER : FALSE;
}
UNPROTECT(1);
return v;
}
SEXP createExternalPtr(SEXP addr, SEXP tag, SEXP prot) {
return R_MakeExternalPtr((void *) (long) INTEGER_VALUE(addr), tag, prot);
}
SEXP getExternalPtrAddr(SEXP eptr) {
return ScalarInteger((int) R_ExternalPtrAddr(eptr));
}
SEXP invoke_TYPEOF(SEXP x) {
return ScalarInteger(TYPEOF(x));
}
SEXP invoke_error(SEXP msg) {
error(R_CHAR(STRING_ELT(msg, 0)));
}
// returns a
SEXP dot_external_access_args(SEXP args) {
args = CDR(args);
int index = 0;
SEXP list;
PROTECT(list = allocVector(VECSXP, length(args)));
for (; args != R_NilValue; args = CDR(args)) {
SEXP tag = TAG(args);
SEXP value = CAR(args);
SEXP listElement;
PROTECT(listElement = allocVector(VECSXP, 2));
SET_VECTOR_ELT(listElement, 0, tag);
SEXP firstValue = R_NilValue;
if (length(value) == 0) {
firstValue = PROTECT(R_NilValue);
} else {
switch (TYPEOF(value)) {
case LGLSXP:
case INTSXP:{
PROTECT(firstValue = allocVector(INTSXP, 1));
INTEGER(firstValue)[0] = INTEGER(value)[0];
break;
}
case REALSXP: {
PROTECT(firstValue = allocVector(REALSXP, 1));
REAL(firstValue)[0] = REAL(value)[0];
break;
}
case STRSXP:
PROTECT(firstValue = ScalarString(STRING_ELT(value, 0)));
break;
case RAWSXP: {
PROTECT(firstValue = allocVector(RAWSXP, 1));
RAW(firstValue)[0] = RAW(value)[0]; break;
}
default:
firstValue = PROTECT(R_NilValue);
}
}
SET_VECTOR_ELT(listElement, 1, firstValue);
SET_VECTOR_ELT(list, index, listElement);
UNPROTECT(1); // firstValue
UNPROTECT(1); // listElement
index++;
}
UNPROTECT(1); // list
return list;
}
SEXP invoke_isString(SEXP s) {
return ScalarLogical(isString(s));
}
SEXP invoke12(SEXP a1, SEXP a2, SEXP a3, SEXP a4, SEXP a5, SEXP a6, SEXP a7, SEXP a8, SEXP a9, SEXP a10, SEXP a11, SEXP a12) {
return a12;
}
SEXP interactive(void) {
return ScalarLogical(R_Interactive);
}
SEXP tryEval(SEXP expr, SEXP env) {
int error = 0;
SEXP r = R_tryEval(expr, env, &error);
SEXP v;
PROTECT(v = allocVector(VECSXP, 2));
if (error) {
r = R_NilValue;
}
SET_VECTOR_ELT(v, 0, r);
SET_VECTOR_ELT(v, 1, ScalarLogical(error));
UNPROTECT(1);
return v;
}
SEXP rHomeDir() {
char *dir = R_HomeDir();
return ScalarString(mkChar(dir));
}
SEXP nestedCall1(SEXP upcall, SEXP env) {
SEXP vec;
PROTECT(vec = allocVector(INTSXP, 10));
int *vecstar = INTEGER(vec);
for (int i = 0; i < 10; i++) {
vecstar[i] = i + 1;
}
SEXP upcallResult = tryEval(upcall, env);
int *vecstar2 = INTEGER(vec);
int ok = vecstar == vecstar2;
if (ok) {
for (int i = 0; i < 10; i++) {
if (vecstar[i] != i + 1) {
ok = 0;
break;
}
}
}
SEXP result;
PROTECT(result = allocVector(VECSXP, 2));
SET_VECTOR_ELT(result, 0, upcallResult);
SET_VECTOR_ELT(result, 1, ScalarLogical(ok)); UNPROTECT(2);
return result;
}
SEXP nestedCall2(SEXP v) {
SEXP sumVec;
PROTECT(sumVec = allocVector(INTSXP, 1));
int len = Rf_length(v);
int sum = 0;
for (int i = 0; i < len; i++) {
sum += INTEGER(v)[i];
}
INTEGER(sumVec)[0] = sum;
UNPROTECT(1);
return sumVec;
}
SEXP r_home(void) {
return mkString(R_Home);
}
SEXP char_length(SEXP x) {
const char *cx = R_CHAR(STRING_ELT(x, 0));
int count = 0;
while (*cx++ != 0) {
count++;
}
return ScalarInteger(count);
}
SEXP mkStringFromChar(void) {
return mkString("hello");
}
SEXP mkStringFromBytes(void) {
char *helloworld = "hello world";
return ScalarString(mkCharLen(helloworld, 5));
}
SEXP null(void) {
return R_NilValue;
}
SEXP iterate_iarray(SEXP x) {
int *cx = INTEGER(x);
int len = LENGTH(x);
SEXP v;
PROTECT(v = allocVector(INTSXP, len));
int *iv = INTEGER(v);
int i;
for (i = 0; i < len; i++) {
iv[i] = cx[i];
}
UNPROTECT(1);
return v;
}
SEXP iterate_iptr(SEXP x) {
int *cx = INTEGER(x);
int len = LENGTH(x);
SEXP v;
PROTECT(v = allocVector(INTSXP, len));
int *iv = INTEGER(v);
int i;
for (i = 0; i < len; i++) {
*iv++ = *cx++;
}
UNPROTECT(1);
return v;
}
SEXP preserve_object(SEXP val) {
SEXP v;
v = allocVector(INTSXP, 1);
int *iv = INTEGER(v);
if(LENGTH(val) > 0) {
int *ival = INTEGER(val);
iv[0] = ival[0];
} else {
iv[0] = 1234;
}
R_PreserveObject(v);
return v;
}
SEXP release_object(SEXP x) {
R_ReleaseObject(x);
return R_NilValue;
}
SEXP findvar(SEXP x, SEXP env) {
SEXP v = Rf_findVar(x, env);
if (v == R_UnboundValue) {
Rf_error("'%s' not found", R_CHAR(PRINTNAME(x)));
} else {
return v;
}
}
SEXP test_asReal(SEXP x) {
return Rf_ScalarReal(Rf_asReal(x));
}
SEXP test_asInteger(SEXP x) {
return Rf_ScalarInteger(Rf_asInteger(x));
}
SEXP test_asLogical(SEXP x) {
return Rf_ScalarLogical(Rf_asLogical(x));
}
SEXP test_asChar(SEXP x) {
return Rf_ScalarString(Rf_asChar(x));
}
SEXP test_CAR(SEXP x) {
return CAR(x);
}
SEXP test_CDR(SEXP x) {
return CDR(x);
}
SEXP test_LENGTH(SEXP x) {
return ScalarInteger(LENGTH(x));
}
SEXP test_inlined_length(SEXP x) {
return ScalarInteger(length(x));
}
SEXP test_coerceVector(SEXP x, SEXP mode) {
int intMode = INTEGER_VALUE(mode);
return Rf_coerceVector(x, intMode);
}
SEXP test_ATTRIB(SEXP x) {
return ATTRIB(x);
}
SEXP test_getAttrib(SEXP source, SEXP name) {
return Rf_getAttrib(source, name);
}
SEXP test_stringNA(void) {
SEXP x = allocVector(STRSXP, 1);
SET_STRING_ELT(x, 0, NA_STRING);
return x;
}
SEXP test_setStringElt(SEXP vec, SEXP elt) {
SET_STRING_ELT(vec, 0, STRING_ELT(elt, 0));
return vec;
}
SEXP test_isNAString(SEXP vec) {
if (STRING_ELT(vec, 0) == NA_STRING) {
return ScalarLogical(1);
} else {
return ScalarLogical(0);
}
}
SEXP test_getBytes(SEXP vec) {
char* bytes = R_CHAR(STRING_ELT(vec, 0));
SEXP result;
PROTECT(result = allocVector(RAWSXP, Rf_length(STRING_ELT(vec, 0))));
unsigned char* resData = RAW(result);
int i = 0;
while (*bytes != '\0') {
resData[i++] = (unsigned char) *bytes;
bytes++;
}
UNPROTECT(1);
return result;
}
// This function is expected to be called only with environment that has single
// promise value in the '...' variable and this is asserted inside this function.
// The return value is list with the promises' expression and environment.
SEXP test_captureDotsWithSingleElement(SEXP env) {
SEXP dots = findVarInFrame3(env, R_DotsSymbol, TRUE);
int n_dots = length(dots);
if (n_dots != 1) {
printf("Error: test_captureDotsWithSingleElement expectes single promise in ...\n");
return R_NilValue;
}
SEXP promise = CAR(dots);
if (TYPEOF(promise) != PROMSXP) {
printf("Error: test_captureDotsWithSingleElement expectes a promise in ...\n");
return R_NilValue;
}
SEXP info = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(info, 0, R_PromiseExpr(promise));
SET_VECTOR_ELT(info, 1, PRENV(promise));
UNPROTECT(1);
return info;
}
SEXP test_evalAndNativeArrays(SEXP vec, SEXP expr, SEXP env) {
SEXP symbolValue;
int *idata;
double *ddata;
unsigned char *bdata;
// note: we want to evaluate PROTECT(symbolValue = Rf_eval(expr, env)); after we take the pointer to data...
switch (TYPEOF(vec)) {
case INTSXP:
idata = INTEGER(vec);
PROTECT(symbolValue = Rf_eval(expr, env));
idata[0] = 42; idata[1] = Rf_asInteger(symbolValue);
break;
case REALSXP:
ddata = REAL(vec);
PROTECT(symbolValue = Rf_eval(expr, env));
ddata[0] = 42;
ddata[1] = Rf_asReal(symbolValue);
break;
case RAWSXP:
bdata = RAW(vec);
PROTECT(symbolValue = Rf_eval(expr, env));
bdata[0] = 42;
bdata[1] = Rf_asInteger(symbolValue); // there is no asRaw, we expect to get symbol with integer value
break;
case LGLSXP:
idata = LOGICAL(vec);
PROTECT(symbolValue = Rf_eval(expr, env));
idata[0] = 1;
idata[1] = Rf_asLogical(symbolValue);
break;
default:
printf("Error: unexpected type");
}
// max of the vector could now be 42/TRUE or symbolValue
SEXP maxSymbol, call, maxVec;
int uprotectCount = 1;
if (TYPEOF(vec) != RAWSXP) {
// note: max does not support raws
PROTECT(maxSymbol = install("max"));
PROTECT(call = lang2(maxSymbol, vec));
PROTECT(maxVec = eval(call, R_GlobalEnv));
uprotectCount = 4;
}
switch (TYPEOF(vec)) {
case INTSXP:
idata[length(vec) - 1] = Rf_asInteger(maxVec);
break;
case REALSXP:
ddata[length(vec) - 1] = Rf_asReal(maxVec);
break;
case RAWSXP:
bdata[length(vec) - 1] = 42;
break;
case LGLSXP:
idata[length(vec) - 1] = Rf_asLogical(maxVec);
break;
default:
printf("Error: unexpected type");
}
UNPROTECT(uprotectCount);
return vec;
}
SEXP test_writeConnection(SEXP connVec) {
Rconnection connection = R_GetConnection(connVec);
char* greeting = "Hello from R_WriteConnection";
R_WriteConnection(connection, greeting, strlen(greeting));
return R_NilValue;
}
SEXP test_readConnection(SEXP connVec) {
Rconnection connection = R_GetConnection(connVec);
unsigned char buffer[255];
int size = R_ReadConnection(connection, buffer, 255);
SEXP result;
PROTECT(result = allocVector(RAWSXP, size));
unsigned char* resultData = RAW(result); for (int i = 0; i < size; ++i) {
resultData[i] = buffer[i];
}
UNPROTECT(1);
return result;
}
static Rconnection customConn;
static void printNow(const char* message) {
puts(message);
fflush(stdout);
}
static void testrfficonn_destroy(Rconnection conn) {
if (conn != customConn) {
printNow("ERROR: destroy function did not receive expected argument\n");
} else {
printNow("Custom connection destroyed\n");
}
}
static Rboolean testrfficonn_open(Rconnection conn) {
if (conn != customConn) {
printNow("ERROR: open function did not receive expected argument\n");
return 0;
} else {
printNow("Custom connection opened\n");
return 1;
}
}
static void testrfficonn_close(Rconnection conn) {
if (conn != customConn) {
printNow("ERROR: close function did not receive expected argument\n");
} else {
printNow("Custom connection closed\n");
}
}
static size_t testrfficonn_write(const void * message, size_t size, size_t nitems, Rconnection conn) {
if (conn != customConn) {
printNow("ERROR: write function did not receive expected argument\n");
return 0;
} else {
printf("Custom connection printing: %.*s\n", (int) (size * nitems), (char*) message);
fflush(stdout);
return size * nitems;
}
}
static size_t testrfficonn_read(void *buffer, size_t size, size_t niterms, Rconnection conn) {
if (conn != customConn) {
printNow("ERROR: read function did not receive expected argument\n");
return 0;
} else if (size * niterms > 0) {
((char *)buffer)[0] = 'Q';
return 1;
}
return 0;
}
SEXP test_createNativeConnection() {
SEXP newConnSEXP = R_new_custom_connection("Connection for testing purposes", "w", "testrfficonn", &customConn);
customConn->isopen = 0;
customConn->canwrite = 1;
customConn->destroy = &testrfficonn_destroy;
customConn->open = &testrfficonn_open;
customConn->close = &testrfficonn_close;
customConn->write = &testrfficonn_write; // customConn->read = &testrfficonn_read; TODO: read test
return newConnSEXP;
}
SEXP test_ParseVector(SEXP src) {
ParseStatus status;
SEXP parseResult, result;
PROTECT(parseResult = R_ParseVector(src, 1, &status, R_NilValue));
PROTECT(result = allocVector(VECSXP, 2));
SET_VECTOR_ELT(result, 0, ScalarInteger(status));
SET_VECTOR_ELT(result, 1, parseResult);
UNPROTECT(2);
return result;
}
SEXP test_RfEvalWithPromiseInPairList() {
SEXP fun = Rf_findVarInFrame(R_FindNamespace(ScalarString(mkChar("stats"))), Rf_install("runif"));
if (TYPEOF(fun) != PROMSXP) {
printf("ERROR: Rf_findVarInFrame evaluated the promise!");
}
SEXP e, ptr;
PROTECT(e = Rf_allocVector(LANGSXP, 2));
SETCAR(e, fun); ptr = CDR(e);
SETCAR(ptr, ScalarInteger(5));
SEXP result = Rf_eval(e, R_GlobalEnv);
UNPROTECT(1);
return result;
}
SEXP test_RfRandomFunctions() {
SEXP v;
PROTECT(v = allocVector(REALSXP, 12));
int n = 0;
REAL(v)[n++] = Rf_dunif(1, 0, 1, FALSE);
REAL(v)[n++] = Rf_qunif(1, 0, 1, TRUE, FALSE);
REAL(v)[n++] = Rf_punif(1, 0, 1, TRUE, FALSE);
REAL(v)[n++] = Rf_runif(0, 1);
REAL(v)[n++] = Rf_dchisq(0, 1, FALSE);
REAL(v)[n++] = Rf_pchisq(0, 1, TRUE, FALSE);
REAL(v)[n++] = Rf_qchisq(0, 1, TRUE, FALSE);
REAL(v)[n++] = Rf_rchisq(1);
REAL(v)[n++] = Rf_dnchisq(1, 0, 1, FALSE);
REAL(v)[n++] = Rf_pnchisq(1, 0, 1, TRUE, FALSE);
REAL(v)[n++] = Rf_qnchisq(1, 0, 1, TRUE, FALSE);
REAL(v)[n++] = Rf_rnchisq(0, 1);
UNPROTECT(1);
return v;
}