dotCall64/0000755000176200001440000000000013225754343012016 5ustar liggesusersdotCall64/inst/0000755000176200001440000000000013224667210012766 5ustar liggesusersdotCall64/inst/CITATION0000644000176200001440000000312413224667210014123 0ustar liggesuserscitHeader("To cite dotCall64 in publications use:") citEntry(entry = "Article", title = "Extending {R} packages to support 64-bit compiled code: An illustration with spam64 and {GIMMS} {NDVI3g} data", author = personList(as.person("Florian Gerber"), as.person("Kaspar Moesinger"), as.person("Reinhard Furrer")), journal = "Computer & Geoscience", year = "2017", volume = "104", number = "", pages = "109--119", issn = "0098-3004", doi = "10.1016/j.cageo.2016.11.015", textVersion = paste("F. Gerber, K. Moesinger, R. Furrer (2017),", "Extending R packages to support 64-bit compiled code: An illustration with spam64 and GIMMS NDVI3g data,", "Computer & Geoscience 104, 109-119, https://doi.org/10.1016/j.cageo.2016.11.015.") ) citEntry(entry = "Article", title = "{dotCall64}: An efficient interface to compiled {C/C++} and {F}ortran code supporting long vectors", author = personList(as.person("Florian Gerber"), as.person("Kaspar Moesinger"), as.person("Reinhard Furrer")), journal = "arXiv", year = "2017", volume = "", number = "", pages = "", url = "https://arxiv.org/abs/1702.08188", note = "", textVersion = paste("F. Gerber, K. Moesinger, R. Furrer (2017),", "dotCall64: An efficient interface to compiled C/C++ and Fortran code supporting long vectors,", "https://arxiv.org/abs/1702.08188.") ) dotCall64/inst/include/0000755000176200001440000000000013224667210014411 5ustar liggesusersdotCall64/inst/include/dotCall64.h0000644000176200001440000000443613224667210016325 0ustar liggesusers#ifndef DOTCALL64_H #define DOTCALL64_H #include #include // Definition of DL_FUNC. #include // Definition of INTSXP and REALSXP. #include // Definition of int64_t #include /* * Because R does not define an int64 type, this pseudo type is used to * indicate an int64_t argument type: * Currently, R only uses 4 bits for types. Therefore, this value will not * clash. */ #define INT64_TYPE 9999 /* * String representing an int64_t argument used in the R-API: */ #define INT64_STRING "int64" #define INTENT_READ 0x1 #define INTENT_WRITE 0x2 #define INTENT_COPY 0x4 #define INTENT_SPEED 0x8 /* * Helpers to read out the bits of the 'intent'. */ #define HAS_INTENT_READ(x) (((x) & INTENT_READ ) != 0) #define HAS_INTENT_WRITE(x) (((x) & INTENT_WRITE) != 0) #define HAS_INTENT_COPY(x) (((x) & INTENT_COPY) != 0) #define HAS_INTENT_SPEED(x) (((x) & INTENT_SPEED) != 0) /* * C-API of the dotCall64 package: * * \param fun pointer to the function that should be called * \param nargs number of arguments * \param args array of type SEXP containing the 'nargs' arguments. * \param args_type array of int indicating the signature of the function. * Currently INT64_TYPE, INTSXP and REALSXP are supported. * \param args_intent_in array of type int, indicating the intent of each argument. * The INTENT_* macros defined above have to be used. * Multiple intents can be combined using the OR operator '|'. * \param flag_naok 0: do not accept NAs, 1: accept NAs * \param flag_verbose 0: no warnings, 1: warnings, or 2: diagnostic messages as warnings. * * The function returns the result by modifying the 'args' array. All arguments that don't * have INTENT_WRITE will be set to R_NilValue. If INTENT_WRITE is set, then the array * contains the object containing the value. As usual, any element must be PROTECT'ed * against the garbage collector. * */ void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_intent_in, int flag_naok, int flag_verbose); #define DOT_CALL64(a,b,c,d,e,f,g) dotCall64(a,b,c,d,e,f,g) // The maximum number of arguments that a function can have. #define MAX_ARGS 65 #endif dotCall64/tests/0000755000176200001440000000000013224667210013153 5ustar liggesusersdotCall64/tests/run-all.R0000644000176200001440000000005213224667210014645 0ustar liggesuserslibrary(testthat) test_check('dotCall64') dotCall64/tests/testthat/0000755000176200001440000000000013224667210015013 5ustar liggesusersdotCall64/tests/testthat/test-flow-left.R0000644000176200001440000001204313224667210020012 0ustar liggesuserscontext("test-flow-left") test_that("int64-double-rw", { a <- 2**32 dc <- .C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2, PACKAGE = "dotCall64", VERBOSE = 1) dc_e <- list(a = 2**33, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 2**32, label = "[modified R object]") expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2, PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 1; coerce 0; dup 0;\ncast.in 1; cast.back 1") }) test_that("int64-double-r", { a <- 2**32 dc <- .C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 1) dc_e <- list(a = NULL, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 2**32, label = "[modified R object]") ## a not modified, because not in place double -> long int transition expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 1; coerce 0; dup 0;\ncast.in 1; cast.back 0") expect_warning(eval(expr), "alloc 1; coerce 0; dup 0;\ncast.in 1; cast.back 1") }) test_that("int64-integer-rw", { a <- 5L expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2L, PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) dc_e <- list(a = 10, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 5L, label = "[modified R object]") expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2L, PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 1; coerce 0; dup 0;\ncast.in 1; cast.back 1") }) test_that("int64-integer-r", { a <- 5L expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2L, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) dc_e <- list(a = NULL, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 5L, label = "[modified R object]") ## a not modified, because not in place double -> long int transition expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2L, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 1; coerce 0; dup 0;\ncast.in 1; cast.back 0") expect_warning(eval(expr), "alloc 1; coerce 0; dup 0;\ncast.in 1; cast.back 1") }) test_that("int64-complex-rw", { a <- 5+5i expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2+2i, PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) dc_e <- list(a = 10, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 5+5i, label = "[modified R object]") expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2+2i, PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 1; dup 0;\ncast.in 1; cast.back 1") }) test_that("int64-complex-r", { a <- 5+5i expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2+2i, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) dc_e <- list(a = NULL, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 5+5i, label = "[modified R object]") ## a not modified, because not in place double -> long int transition expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expr <- expression(.C64("TEST_prod_int64", c("int64", "int64"), a = a, b = 2+2i, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 1; dup 0;\ncast.in 1; cast.back 0") }) dotCall64/tests/testthat/test-flow-center.R0000644000176200001440000001504613224667210020346 0ustar liggesuserscontext("test-flow-center") test_that("double-double", { a <- 3.3 dc <- .C64("TEST_prod_double", c("double", "double"), a = a, b = 2, PACKAGE = "dotCall64", VERBOSE = 1) dc_e <- list(a = 6.6, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 3.3, label = "[modified R object]") expr <- expression(.C64("TEST_prod_double", c("double", "double"), a = a, b = 2, PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 0; dup 1;\ncast.in 0; cast.back 0;") }) test_that("double-double-modifiedRead", { a <- 3.3 dc <- .C64("TEST_prod_double", c("double", "double"), a = a, b = 2, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 1) dc_e <- list(a = NULL, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 6.6, label = "[modified R object]") expr <- expression(.C64("TEST_prod_double", c("double", "double"), a = a, b = 2, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 0; dup 1;\ncast.in 0; cast.back 0;") expect_warning(eval(expr), "alloc 0; coerce 0; dup 0;\ncast.in 0; cast.back 0;") }) test_that("int-int", { a <- 3L dc <- .C64("TEST_prod_int", c("int", "int"), a = a, b = 2L, PACKAGE = "dotCall64", VERBOSE = 1) dc_e <- list(a = 6L, b = 2L) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 3L, label = "[modified R object]") expr <- expression(.C64("TEST_prod_int", c("int", "int"), a = a, b = 2L, PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 0; dup 1;\ncast.in 0; cast.back 0") }) test_that("int-int-modifiedRead", { a <- 3L dc <- .C64("TEST_prod_int", c("int", "int"), a = a, b = 2L, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 1) dc_e <- list(a = NULL, b = 2L) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 6L, label = "[modified R object]") expr <- expression(.C64("TEST_prod_int", c("int", "int"), a = a, b = 2L, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 0; dup 0;\ncast.in 0; cast.back 0") expect_warning(eval(expr), "alloc 0; coerce 0; dup 1;\ncast.in 0; cast.back 0") }) test_that("int-double-rw", { a <- 3 expr <- expression(.C64("TEST_prod_int", c("int", "int"), a = a, b = 2, PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) dc_e <- list(a = 6L, b = 2L) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 3, label = "[modified R object]") expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expr <- expression(.C64("TEST_prod_int", c("int", "int"), a = a, b = 2, PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 1; dup 0;\ncast.in 0; cast.back 0") }) test_that("int-double-r", { a <- 3 expr <- expression(.C64("TEST_prod_int", c("int", "int"), a = a, b = 2, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) dc_e <- list(a = NULL, b = 2L) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 3, label = "[modified R object]") expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expr <- expression(.C64("TEST_prod_int", c("int", "int"), a = a, b = 2, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 1; dup 0;\ncast.in 0; cast.back 0") }) test_that("double-int-rw", { a <- 3L expr <- expression(.C64("TEST_prod_double", c("double", "double"), a = a, b = 2L, PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) dc_e <- list(a = 6, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 3L, label = "[modified R object]") expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expr <- expression(.C64("TEST_prod_double", c("double", "double"), a = a, b = 2L, PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 1; dup 0;\ncast.in 0; cast.back 0") }) test_that("double-int-r", { a <- 3L expr <- expression(.C64("TEST_prod_double", c("double", "double"), a = a, b = 2L, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) dc_e <- list(a = NULL, b = 2) expect_equal(lapply(dc, typeof), lapply(dc_e, typeof)) expect_equal(dc, dc_e) expect_identical(a, 3L, label = "[modified R object]") expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expr <- expression(.C64("TEST_prod_double", c("double", "double"), a = a, b = 2L, INTENT = c("r", "rw"), PACKAGE = "dotCall64", VERBOSE = 2)) expect_warning(eval(expr), "alloc 0; coerce 1; dup 0;\ncast.in 0; cast.back 0") }) dotCall64/tests/testthat/test-againstDotC.R0000644000176200001440000000355313224667210020321 0ustar liggesuserscontext("test-againstDotC") test_that("int", { cc <- .C("TEST_times2_int", a = 2L, r = integer(1), PACKAGE = "dotCall64") dc <- .C64("TEST_times2_int", c("int", "int"), a = 2L, r = integer(1), INTENT = c("rw", "rw"), PACKAGE = "dotCall64") expect_equal(cc, dc, label = "[values]") expect_equal(lapply(cc, typeof), lapply(dc, typeof), label = "[types]") }) test_that("double", { cc <- .C("TEST_times2_double", a = 2.2, r = double(1), PACKAGE = "dotCall64") dc <- .C64("TEST_times2_double", c("double", "double"), a = 2.2, r = double(1), INTENT = c("rw", "rw"), PACKAGE = "dotCall64") expect_equal(cc, dc, label = "[values]") expect_equal(lapply(cc, typeof), lapply(dc, typeof), label = "[types]") }) ## -------------------- test_that("referenced-integer", { input <- 2L cc <- .C("TEST_times2_int", a = input, r = input, PACKAGE = "dotCall64") dc <- .C64("TEST_times2_int", c("int", "int"), a = input, r = input, INTENT = c("rw", "rw"), PACKAGE = "dotCall64") expect_equal(cc, dc, label = "[values]") expect_equal(lapply(cc, typeof), lapply(dc, typeof), label = "[types]") expect_identical(input, 2L) }) test_that("referenced-double", { input <- 2.2 cc <- .C("TEST_times2_double", a = input, r = input, PACKAGE = "dotCall64") dc <- .C64("TEST_times2_double", c("double", "double"), a = input, r = input, INTENT = c("rw", "rw"), PACKAGE = "dotCall64") expect_equal(cc, dc, label = "[values]") expect_equal(lapply(cc, typeof), lapply(dc, typeof), label = "[types]") expect_identical(input, 2.2) }) dotCall64/tests/testthat/test-long_int64.R0000644000176200001440000000067113224667210020102 0ustar liggesuserslibrary(dotCall64) context("test-local-tests") test_that("pass-long-int64_t", { skip_on_cran() a <- numeric(2^31) expect_identical(.C64("BENCHMARK", SIGNATURE = "int64", a = a, INTENT = "rw", NAOK = TRUE, VERBOSE = 1, PACKAGE = "dotCall64")$a, a) }) dotCall64/tests/testthat/test-flow-right.R0000644000176200001440000000613313224667210020200 0ustar liggesuserscontext("test-flow-right") ## test right side of flow chart ## consider the 'r' variable intent <- c("r", "w") tg <- expand.grid(signature = c("int", "double", "int64"), type = c("int", "double"), referenced = c("ref", "notRef"), stringsAsFactors = FALSE) for(i in 1:nrow(tg)){ test_that(paste0("right-", paste0(tg[i,], collapse = "-")), { signature <- tg[i, "signature"] type <- tg[i, "type"] referenced <- if(tg[i, "referenced"] == "ref") TRUE else FALSE info <- paste0("signature:", signature, ", type:", type, ", i:", i) a <- switch(type, int = 5L, double = 7.6, int64 = 2^32) if(referenced){ b <- switch(type, int = 1L, double = 1.0, int64 = 1.0) } else b <- switch(type, int = integer_dc(1), double = numeric_dc(1), int64 = numeric_dc(1)) expr <- expression( .C64(paste0("TEST_times2_", signature), c(signature, signature), a = a, r = b, INTENT = intent, PACKAGE = "dotCall64", VERBOSE = 1)) dc <- suppressWarnings(eval(expr)) a_out <- if(signature %in% c("int", "int64")) as.integer(a) else a r_out <- 2L * a_out ## currently returned objects are of type "signature" r_out <- if(signature == "int") as.integer(r_out) else as.double(r_out) dc_e <- list(a = NULL, r = r_out) expect_equal(dc, dc_e, info = info) expect_equal(typeof(dc$r), typeof(dc_e$r), info = info) ## test for corrupted R objects expect_identical(a, switch(type, int = 5L, double = 7.6, int64 = 2^32), label = "[corrupt R object]", info = info) if(referenced) expect_identical(b, switch(type, int = 1L, double = 1.0, int64 = 1.0), label = "[corrupt R object]", info = info) ## test warnings if(referenced){ expect_warning(eval(expr), "[dotCall64|referenced R object]", label = "[dotCall64|referenced R object]", info = info) } else { ## expect_that(eval(expr), ## not(gives_warning("[dotCall64|referenced R object]")), ## label = "[dotCall64|referenced R object]", ## info = info) } if(signature != type && !(signature == "int64" && type == "double")) { expect_warning(eval(expr), "[dotCall64|wrong R object type]", info = info, label = "[dotCall64|wrong R object type]") } else { ## expect_that(eval(expr), ## not(gives_warning("[dotCall64|wrong R object type]")), ## info = info) } }) } dotCall64/tests/testthat/test-vector_dc.R0000644000176200001440000000736313224667210020074 0ustar liggesuserscontext("test-vector_dc") test_that("int", { expr <- expression( .C64("TEST_times2_int", c("int", "int"), a = 2L, r = integer(1), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) expr_list <- expression( .C64("TEST_times2_int", c("int", "int"), a = 2L, r = list(mode = "integer", length = 1L), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) expr_dc <- expression( .C64("TEST_times2_int", c("int", "int"), a = 2L, r = integer_dc(1), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) ## warnings expect_warning(eval(expr), "[dotCall64|referenced 'w' argument]", label = "[dotCall64|referenced 'w' argument]") expect_warning(eval(expr_list), "[dotCall64|referenced 'w' argument]", label = "[dotCall64|referenced 'w' argument]") expect_warning(eval(expr_list), "[dotCall64|referenced 'w' argument]", label = "[dotCall64|referenced 'w' argument]") expect_silent(eval(expr_dc)) }) test_that("numeric", { expr <- expression( .C64("TEST_times2_double", c("double", "double"), a = 2, r = numeric(1), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) expr_list <- expression( .C64("TEST_times2_double", c("double", "double"), a = 2, r = list(mode = "integer", length = 1L), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) expr_dc <- expression( .C64("TEST_times2_double", c("double", "double"), a = 2, r = numeric_dc(1), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) ## warnings expect_warning(eval(expr), "[dotCall64|referenced 'w' argument]", label = "[dotCall64|referenced 'w' argument]") expect_warning(eval(expr_list), "[dotCall64|referenced 'w' argument]", label = "[dotCall64|referenced 'w' argument]") expect_warning(eval(expr_list), "[dotCall64|referenced 'w' argument]", label = "[dotCall64|referenced 'w' argument]") expect_silent(eval(expr_dc)) }) test_that("wrong type", { expr <- expression( .C64("TEST_times2_double", c("double", "double"), a = 2L, r = character(1), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) expr_list <- expression( .C64("TEST_times2_double", c("double", "double"), a = 2L, r = list(mode = "character", length = 1L), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) expr_dc <- expression( .C64("TEST_times2_double", c("double", "double"), a = 2L, r = vector_dc("character", 1L), INTENT = c("rw", "w"), PACKAGE = "dotCall64", VERBOSE = 1)) ## warnings expect_warning(eval(expr), "[dotCall64|referenced 'w' argument]", label = "[dotCall64|referenced 'w' argument]") expect_warning(eval(expr), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expect_warning(eval(expr_list), "[dotCall64|referenced 'w' argument]", label = "[dotCall64|referenced 'w' argument]") expect_warning(eval(expr_list), "[dotCall64|wrong R object type]", label = "[dotCall64|wrong R object type]") expect_error(eval(expr_dc), "not yet supported by allocInitializedVector", label = "[error allocInitializedVector]") }) dotCall64/src/0000755000176200001440000000000013225704312012574 5ustar liggesusersdotCall64/src/Makevars0000644000176200001440000000027213225707635014304 0ustar liggesusers # C-Flags # PKG_CFLAGS = -I../inst/include/ -DDOTCAL64_PRIVATE # PKG_LIBS = PKG_CFLAGS = $(SHLIB_OPENMP_CFLAGS) -I../inst/include/ -DDOTCAL64_PRIVATE PKG_LIBS = $(SHLIB_OPENMP_CFLAGS) dotCall64/src/dotCall64helpers.c0000644000176200001440000006534113225707635016103 0ustar liggesusers#include #include #include #include /* See http://cran.r-project.org/doc/manuals/R-exts.html#C_002dlevel-messages */ #ifdef ENABLE_NLS #include #define _(String) dgettext ("pkg", String) /* replace pkg as appropriate */ #else #define _(String) (String) #endif /* The following lines are copied from R source: src/main/dotcode.c:1685-2277 */ void dotCall64_callFunction(DL_FUNC fun, int nargs, void **cargs) { switch (nargs) { case 0: /* Silicon graphics C chokes here */ /* if there is no argument to fun. */ fun(0); break; case 1: fun(cargs[0]); break; case 2: fun(cargs[0], cargs[1]); break; case 3: fun(cargs[0], cargs[1], cargs[2]); break; case 4: fun(cargs[0], cargs[1], cargs[2], cargs[3]); break; case 5: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4]); break; case 6: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5]); break; case 7: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6]); break; case 8: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7]); break; case 9: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8]); break; case 10: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9]); break; case 11: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10]); break; case 12: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11]); break; case 13: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12]); break; case 14: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13]); break; case 15: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14]); break; case 16: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15]); break; case 17: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16]); break; case 18: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17]); break; case 19: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18]); break; case 20: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19]); break; case 21: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20]); break; case 22: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21]); break; case 23: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22]); break; case 24: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23]); break; case 25: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24]); break; case 26: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25]); break; case 27: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26]); break; case 28: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27]); break; case 29: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28]); break; case 30: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29]); break; case 31: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30]); break; case 32: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31]); break; case 33: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32]); break; case 34: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33]); break; case 35: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34]); break; case 36: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35]); break; case 37: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36]); break; case 38: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37]); break; case 39: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38]); break; case 40: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39]); break; case 41: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40]); break; case 42: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41]); break; case 43: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42]); break; case 44: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43]); break; case 45: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44]); break; case 46: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45]); break; case 47: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46]); break; case 48: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47]); break; case 49: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48]); break; case 50: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49]); break; case 51: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50]); break; case 52: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51]); break; case 53: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52]); break; case 54: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53]); break; case 55: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54]); break; case 56: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55]); break; case 57: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56]); break; case 58: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56], cargs[57]); break; case 59: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56], cargs[57], cargs[58]); break; case 60: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56], cargs[57], cargs[58], cargs[59]); break; case 61: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56], cargs[57], cargs[58], cargs[59], cargs[60]); break; case 62: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56], cargs[57], cargs[58], cargs[59], cargs[60], cargs[61]); break; case 63: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56], cargs[57], cargs[58], cargs[59], cargs[60], cargs[61], cargs[62]); break; case 64: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56], cargs[57], cargs[58], cargs[59], cargs[60], cargs[61], cargs[62], cargs[63]); break; case 65: fun(cargs[0], cargs[1], cargs[2], cargs[3], cargs[4], cargs[5], cargs[6], cargs[7], cargs[8], cargs[9], cargs[10], cargs[11], cargs[12], cargs[13], cargs[14], cargs[15], cargs[16], cargs[17], cargs[18], cargs[19], cargs[20], cargs[21], cargs[22], cargs[23], cargs[24], cargs[25], cargs[26], cargs[27], cargs[28], cargs[29], cargs[30], cargs[31], cargs[32], cargs[33], cargs[34], cargs[35], cargs[36], cargs[37], cargs[38], cargs[39], cargs[40], cargs[41], cargs[42], cargs[43], cargs[44], cargs[45], cargs[46], cargs[47], cargs[48], cargs[49], cargs[50], cargs[51], cargs[52], cargs[53], cargs[54], cargs[55], cargs[56], cargs[57], cargs[58], cargs[59], cargs[60], cargs[61], cargs[62], cargs[63], cargs[64]); break; default: error(_("too many arguments, sorry")); } } dotCall64/src/testfunctions_f.f0000644000176200001440000000060413225707635016173 0ustar liggesusers subroutine get_f(input, index, output) double precision :: input(*), output(*) integer :: index output(1) = input(index) end subroutine get64_f(input, index, output) double precision :: input(*), output(*) integer (kind = 8) :: index ! 64-bit integer on GFortran, differs with other compilers output(1) = input(index) end dotCall64/src/init.c0000644000176200001440000000357513225707635013730 0ustar liggesusers#include #include // for NULL #include /* to get all functions: nm -g lib/dotCall64/libs/dotCall64.so | grep " T " */ // C extern void BENCHMARK ( void *); extern void dC64 ( void *); extern void get64_c ( void *, void *, void *); extern void get_c ( void *, void *, void *); extern void TEST_prod_double ( void *, void *); extern void TEST_prod_int ( void *, void *); extern void TEST_prod_int64 ( void *, void *); extern void TEST_times2_double ( void *, void *); extern void TEST_times2_int ( void *, void *); extern void TEST_times2_int64 ( void *, void *); // Fortran extern void F77_NAME(get_f) ( void *, void *, void *); extern void F77_NAME(get64_f) ( void *, void *, void *); static const R_CallMethodDef CEntries[] = { {"BENCHMARK", (DL_FUNC)&BENCHMARK, 1}, {"dC64", (DL_FUNC)&dC64, 1}, {"get64_c", (DL_FUNC)&get64_c, 3}, {"get_c", (DL_FUNC)&get_c, 3}, {"TEST_prod_double", (DL_FUNC)&TEST_prod_double, 2}, {"TEST_prod_int", (DL_FUNC)&TEST_prod_int, 2}, {"TEST_prod_int64", (DL_FUNC)&TEST_prod_int64, 2}, {"TEST_times2_double", (DL_FUNC)&TEST_times2_double, 2}, {"TEST_prod_int", (DL_FUNC)&TEST_prod_int, 2}, {"TEST_prod_int64", (DL_FUNC)&TEST_prod_int64, 2}, {NULL, NULL, 0} }; static const R_FortranMethodDef FortranEntries[] = { {"get_f", (DL_FUNC)&F77_NAME(get_f ), 3}, {"get64_f", (DL_FUNC)&F77_NAME(get64_f), 3}, {NULL, NULL, 0} }; void R_init_spam(DllInfo *dll) { R_registerRoutines(dll, NULL, NULL, FortranEntries, NULL); R_registerRoutines(dll, NULL, CEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } dotCall64/src/testfunctions_c.c0000644000176200001440000000123313225707635016164 0ustar liggesusers# include void TEST_times2_double ( double* a, double* r ) { *r = *a * 2.0 ; } void TEST_times2_int ( int* a, int* r ) { *r = *a * 2 ; } void TEST_times2_int64 ( int64_t* a, int64_t* r ) { *r = *a * 2 ; } void TEST_prod_double ( double* a, double* b) { *a = *a * *b ; } void TEST_prod_int ( int* a, int* b) { *a = *a * *b ; } void TEST_prod_int64 ( int64_t* a, int64_t* b) { *a = *a * *b ; } void BENCHMARK (void *x) { } void get_c(double *input, int *index, double *output) { output[0] = input[index[0] - 1]; } void get64_c(double *input, int64_t *index, double *output) { output[0] = input[index[0] - 1]; } dotCall64/src/dotCall64.c0000644000176200001440000004550413225707635014517 0ustar liggesusers#include "dotCall64.h" // MAYBE_SHARED is not available in R 3.0.1 #ifndef MAYBE_SHARED #define MAYBE_SHARED(x) (NAMED(x) > 1) #define NO_REFERENCES(x) (NAMED(x) == 0) #define MAYBE_REFERENCED(x) (! NO_REFERENCES(x)) #endif /* See http://cran.r-project.org/doc/manuals/R-exts.html#C_002dlevel-messages */ #ifdef ENABLE_NLS #include #define _(String) dgettext ("dotCall64", String) #else #define _(String) (String) #endif /* Maximum length of entry-point name, including null terminator */ // copied from dotcode.c:69 #define MaxSymbolBytes 1024 /* Define PATH_MAX for GNU/Hurd */ #ifndef PATH_MAX #define PATH_MAX 4096 #endif /* Attributes like PACKAGE have to be prefixed in order to not get interpreted by .External(...) */ #define SYMBOL_PREFIX "dotCall64" extern void dotCall64_callFunction(DL_FUNC fun, int nargs, void **cargs); static void argsfind(SEXP args_in, SEXP *args, SEXP *names,int *len, char *packageName, SEXP *signature, SEXP *intent, SEXP *naok, SEXP *verbose); static void prepareArguments(DL_FUNC fun, int nargs, SEXP *args, SEXPTYPE *do_type, int *do_alloc, int *do_coerce, int *do_duplicate, int *do_cast_in, int *do_cast_back, int* flag_naok); static SEXP getListElement(SEXP list, const char *str); static int dotCall64str2type(SEXP s); static SEXP allocInitializedVector(int type, R_xlen_t length); /* These are set during the first call to do_dotCode() below. */ static SEXP PkgSymbol = NULL; static SEXP SignatureSymbol = NULL; static SEXP IntentSymbol = NULL; static SEXP NaokSymbol = NULL; static SEXP VerboseSymbol = NULL; int str2intent(SEXP str) { const char *p = CHAR(str); int x = 0; // Clear any bits for(int i=0; i MaxSymbolBytes - 1) error(_("argument '.NAME' is too long (dotCall64)")); strcpy(symName, p); // Move to the next argument: args_in = CDR(args_in); // Get the effective arguments: argsfind(args_in, args, args_names, &nargs, packageName, &signature, &intent, &naok, &verbose); // We do not need to PROTECT args and args_names, because they are protected by being a subobject of args_in. // Check the NAOK argument if(!naok || LENGTH(naok) != 1) error(_("argument 'NAOK' has to be of length 1 (dotCall64)")); flag_naok = asInteger(naok); // Check the VERBOSE argument if(!verbose || LENGTH(verbose) != 1) error(_("argument 'VERBOSE' has to be of length 1 (dotCall64)")); flag_verbose = asInteger(verbose); if(!(flag_verbose == 0 || flag_verbose == 1 || flag_verbose == 2)) error(_("agrument 'VERBOSE' has to be one of 0, 1, or 2 (dotCall64)")); // Find the function fun = R_FindSymbol(symName, packageName, NULL); if(!fun) { // Check if we find the symbol with an appended '_' for Fortran: int symlength = strlen(symName); symName[symlength] = '_'; symName[symlength+1] = 0; fun = R_FindSymbol(symName, packageName, NULL); if(!fun) error(_("symbol '%s' not found in package '%s' (dotCall64)"), symName, packageName); } // We cannot check if the number of given arguments equals to the number of expected arguments because // R_RegisteredNativeSymbol is declared as private API. // Any argument of class "vector_dc" must be expanded to the correct type for(na = 0; na < nargs; na++) { s = args[na]; if(Rf_inherits(s, "vector_dc")) { R_xlen_t len = 0; int type = dotCall64str2type(STRING_ELT(getListElement(s, "mode"), 0)); len = asReal(getListElement(s, "length")); if(flag_verbose == 2) warning(_("[dotCall64|vector_dc] argument %d; allocate vector of type %s (%d); length %d"), na+1, CHAR(STRING_ELT(getListElement(s, "mode"), 0)), type, len); args[na] = PROTECT(allocInitializedVector(type, len)); n_protect++; } } // First we determine the current types of the vectors, as they represent the default types: int args_type[MAX_ARGS]; int args_intent[MAX_ARGS]; SEXP sexpargs[MAX_ARGS]; for(na = 0; na < nargs; na++) { s = args[na]; args_type[na] = TYPEOF(s); args_intent[na] = INTENT_READ | INTENT_WRITE; // Default intent is {write, read} sexpargs[na] = s; } // Second, adjust the arguments that are overwritten by SIGNATURE if(!signature) { error(_("argument 'SIGNATURE' is missing (dotCall64)")); } if(LENGTH(signature) != nargs) error(_("length of argument 'SIGNATURE' does not equal to the number of arguments (dotCall64)")); for(na = 0; na < LENGTH(signature); na++) { int type = dotCall64str2type(STRING_ELT(signature, na)); if(type < 0) error(_("signature of argument %d not recognized (%s) (dotCall64)"), na+1, CHAR(STRING_ELT(signature, na))); args_type[na] = type; } // Third, adjust the intents that are overwritten by INTENT: if(intent) { if(LENGTH(intent) != nargs) error(_("length of argument 'INTENT' does not equal to the number of arguments (dotCall64)")); for(na = 0; na < LENGTH(intent); na++) { switch(TYPEOF(intent)) { case STRSXP: { args_intent[na] = str2intent(STRING_ELT(intent, na)); } break; } } } // Determine if the arguments are named and keep the names if true. SEXP names = NULL; Rboolean havenames = FALSE; for(na = 0; na < nargs; na++) { if (args_names[na] != R_NilValue) havenames = TRUE; } if (havenames) { PROTECT(names = allocVector(STRSXP, nargs)); n_protect++; for (na = 0; na < nargs; na++) { if (args_names[na] == R_NilValue) SET_STRING_ELT(names, na, R_BlankString); else SET_STRING_ELT(names, na, PRINTNAME(args_names[na])); } } // Call the function. dotCall64(fun, nargs, sexpargs, args_type, args_intent, flag_naok, flag_verbose); // Protect every 'write' argument returned by dotCall64. for (na = 0 ; na < nargs; na++) { if(!HAS_INTENT_WRITE(args_intent[na])) continue; PROTECT(sexpargs[na]); n_protect++; } PROTECT(answer = allocVector(VECSXP, nargs)); n_protect++; // Add the argument names, if available. if (names) { setAttrib(answer, R_NamesSymbol, names); } // Add the arguments to the answer // Only the arguments that have INTENT_WRITE will be added to the answer environment. for(na = 0; na MAX_ARGS) error(_("dotCall64 only supports up to 64 arguments (dotCall64)")); // When an object is given multiple times as an argument, we have to be careful. // To exclude any side effects, we duplicate every object when its INTENT is write. // If the type is int64, we duplicate it in every case. for(na = 0; na < nargs; na++) { args_intent[na] = args_intent_in[na]; } for(na = 0; na < nargs; na++) { for(int nb = na+1; nb < nargs; nb++) { if(args[na] == args[nb]) { args_intent[na] |= INTENT_SPEED | INTENT_COPY; args_intent[nb] |= INTENT_SPEED | INTENT_COPY; break; } } } // Populate the do_ variables by the rules defined in the flowchart: for(na = 0; na < nargs; na++) { SEXP s = args[na]; // Initialize the do_ variables: do_type[na] = -1; do_alloc[na] = 0; do_coerce[na] = 0; do_duplicate[na] = 0; do_cast_in[na] = 0; do_cast_back[na] = 0; int maybe_referenced = MAYBE_REFERENCED(s); int maybe_shared = MAYBE_SHARED(s); // Unused // Determine the expected R type of the object. if(args_type[na] == INT64_TYPE) { // int64 is based on the double type. do_type[na] = REALSXP; }else{ do_type[na] = args_type[na]; } // Check if a warning should be raised in case the provided argument type dose not match the expected type. if(flag_verbose >= 1 && TYPEOF(s)!=do_type[na]) { warning(_("[dotCall64|wrong R object type] argument %d; expected type '%s'; got type '%s'; argument coerced"), na+1, type2char(do_type[na]), CHAR(type2str(TYPEOF(s)))); } // Start flowchart. if(HAS_INTENT_WRITE(args_intent[na]) && !HAS_INTENT_READ(args_intent[na])) { // Right part of the flowchart. // Intent = w if(TYPEOF(s) == do_type[na] && !maybe_referenced) { // We can just pass the object as argument. }else{ // We need a new object for the return value. if(flag_verbose >= 1 && maybe_referenced) { warning(_("[dotCall64|referenced 'w' argument] argument %d has 'INTENT' 'w' and is referenced.\nConsider using vector_dc() to avoid copying."), na+1); } do_alloc[na] = 1; } // Check if we have to cast back. if(args_type[na] == INT64_TYPE) { do_cast_back[na] = 1; } }else if(args_type[na] == INT64_TYPE) { // Left part of the flowchart. // Argument of type int_64 with intents r, rw. if(TYPEOF(s) == INTSXP || TYPEOF(s) == REALSXP) { do_alloc[na] = 1; }else{ do_coerce[na] = 1; } // As the argument is read, we have to cast from double->int64. do_cast_in[na] = 1; if(HAS_INTENT_WRITE(args_intent[na])) { do_cast_back[na] = 1; } }else{ // Center part of the flowchart // Argument of native type. if(TYPEOF(s)!=do_type[na]) { // wrong type. do_coerce[na] = 1; }else if(HAS_INTENT_WRITE(args_intent[na])) { // intent= rw. do_duplicate[na] = 1; } } if(flag_verbose == 2){ warning(_("[dotCall64|flags] arg %d: type %s (%d); alloc %d; coerce %d; dup %d;\ncast.in %d; cast.back %d; named: %d, mb-ref %d; mb-shared %d\n"), na+1, type2char(do_type[na]), do_type[na], do_alloc[na], do_coerce[na], do_duplicate[na], do_cast_in[na], do_cast_back[na], NAMED(s), maybe_referenced, maybe_shared); } } prepareArguments(fun, nargs, args, do_type, do_alloc, do_coerce, do_duplicate, do_cast_in, do_cast_back, &flag_naok); } static void prepareArguments(DL_FUNC fun, int nargs, SEXP *args, SEXPTYPE *do_type, int *do_alloc, int *do_coerce, int *do_duplicate, int *do_cast_in, int *do_cast_back, int *flag_naok) { int na; void **cargs[MAX_ARGS]; // pointers for the actual function. SEXP args_in[MAX_ARGS]; // contains a copy of the given arguments. int n_protect = 0; // counts how many times PROTECT has been called. // Copy the argument (for efficient int64 casting). for(na=0; na < nargs; na++) args_in[na] = args[na]; for(na = 0; na < nargs; na++) { SEXP s = args[na]; R_xlen_t len = (R_xlen_t) XLENGTH(s); if(do_alloc[na]) { args[na] = PROTECT(allocInitializedVector(do_type[na], len)); n_protect++; }else if(do_coerce[na]) { args[na] = PROTECT(coerceVector(s, do_type[na])); n_protect++; args_in[na] = args[na]; // If coerce, pretend that this object was provided }else if(do_duplicate[na]) { args[na] = PROTECT(duplicate(s)); n_protect++; } // We will now work on the new object. s = args[na]; // NAOK if(*flag_naok == 0){ if(TYPEOF(args_in[na]) == REALSXP) { double *rptr = REAL(args_in[na]); //#pragma omp parallel for default(none) shared(len, rptr) private(i) for(int i=0; i < len; i++) { if(!R_FINITE(rptr[i])) error(_("NAs in argument %d and 'NAOK = FALSE' (dotCall64)"), na + 1); } } else if(TYPEOF(args_in[na]) == INTSXP) { int *iptr = INTEGER(args_in[na]); //#pragma omp parallel for default(none) shared(len, iptr) private(i) for(int i=0; i < len; i++) { if(iptr[i] == NA_INTEGER) error(_("NAs in argument %d and 'NAOK = FALSE' (dotCall64)"), na + 1); } } } // prepare the pointers switch(TYPEOF(s)) { case REALSXP: cargs[na] = (void*) REAL(s); break; case LGLSXP: case INTSXP: cargs[na] = (void*) INTEGER(s); break; case RAWSXP: cargs[na] = (void*) RAW(s); break; default: error(_("cannot yet handle type '%s' (arg %d) (dotCall64)"), type2char(TYPEOF(s)), na + 1); } } // Coerce arguments of type int64 (from double -> int64_t). // We cannot do this earlier as the memory of the object might be overwritten, and hence, any call to 'error()' would // destroy the object. for(na = 0; na < nargs; na++) { SEXP s = args[na]; // double -> int64_t if(do_cast_in[na]) { R_xlen_t i, len; len = XLENGTH(s); // We will cast into this pointer. int64_t *iptr = (int64_t*) REAL(s); // All other types have been coerced to REALSXP. // We handle INTSXP separately if(TYPEOF(args_in[na]) == REALSXP) { double *in_ptr = REAL(args_in[na]); #pragma omp parallel for default(none) shared(len, iptr, in_ptr) private(i) for(i=0; i < len; i++) { // #1 iptr[i] = (int64_t) in_ptr[i]; } }else if(TYPEOF(args_in[na]) == INTSXP) { int *in_ptr = INTEGER(args_in[na]); #pragma omp parallel for default(none) shared(len, iptr, in_ptr) private(i) for(i=0; i < len; i++) { // #1 iptr[i] = (int64_t) in_ptr[i]; } }else{ error(_("should not happen: internal error (do_cast_in) (dotCall64)")); } } } // Finally, call the function. dotCall64_callFunction(fun, nargs, (void**)cargs); // Back cast the values of all arguments of type int64. for(na = 0; na < nargs; na++) { SEXP s = args[na]; if(do_cast_back[na]) { R_xlen_t i, len; len = XLENGTH(s); int64_t *iptr = (int64_t*) cargs[na]; double *dptr = (double*) cargs[na]; #pragma omp parallel for default(none) shared(len, iptr, dptr) private(i) for(i=0; i < len; i++) { // #2 dptr[i] = (double) iptr[i]; } } } UNPROTECT(n_protect); } // Inspired by static SEXP naokfind(SEXP args, int * len, int *naok, int *dup, DllReference *dll) static void argsfind(SEXP args_in, SEXP *args, SEXP *names,int *len, char *packageName, SEXP *signature, SEXP *intent, SEXP *naok, SEXP *verbose) { SEXP s; int nargs=0, pkgused=0, sigused=0, intused=0, naokused=0, verbused=0; const char *p; // Attribute containing the if (PkgSymbol == NULL || SignatureSymbol == NULL) { PkgSymbol = install("f.PACKAGE"); SignatureSymbol = install("SIGNATURE"); IntentSymbol = install("INTENT"); NaokSymbol = install("NAOK"); VerboseSymbol = install("VERBOSE"); } // Initialize to an empty string strcpy(packageName, ""); *signature = NULL; *intent = NULL; *naok = NULL; *verbose = NULL; for(s = args_in; s != R_NilValue;) { if(TAG(s) == PkgSymbol) { if(TYPEOF(CAR(s)) == STRSXP) { p = translateChar(STRING_ELT(CAR(s), 0)); if(strlen(p) > PATH_MAX - 1) error(_("DLL name is too long (dotCall64)")); strcpy(packageName, p); if(pkgused++ > 0) error(_("formal argument '%s' matched by multiple actual arguments (dotCall64)"), "PACKAGE"); } else { error(_("formal argument 'PACKAGE' has wrong type (\"%s\"). Expected type: \"character\" (dotCall64)"), type2char(TYPEOF(CAR(s)))); } } else if(TAG(s) == SignatureSymbol) { if(TYPEOF(CAR(s)) == STRSXP) { *signature = CAR(s); if(sigused++ > 0) error(_("formal argument '%s' matched by multiple actual arguments (dotCall64)"), "SIGNATURE"); } else { error(_("formal argument 'SIGNATURE' has wrong type (\"%s\"). Expected type: \"character\" (dotCall64)"), type2char(TYPEOF(CAR(s)))); } } else if(TAG(s) == IntentSymbol) { switch(TYPEOF(CAR(s))) { case STRSXP: *intent = CAR(s); if(intused++ > 0) error(_("formal argument '%s' matched by multiple actual arguments (dotCall64)"), "INTENT"); break; case NILSXP: // behave as if no argument was given break; default: error(_("formal argument 'INTENT' has wrong type ('%s'). Expected type: \"character\" (dotCall64)"), type2char(TYPEOF(CAR(s)))); } } else if(TAG(s) == NaokSymbol) { if(TYPEOF(CAR(s)) == LGLSXP) { *naok = CAR(s); if(naokused++ > 0) error(_("formal argument '%s' matched by multiple actual arguments (dotCall64)"), "VERBOSE"); } else { error(_("formal argument 'NAOK' has wrong type (\"%s\"). Expected type: \"logical\" (dotCall64)"), type2char(TYPEOF(CAR(s)))); } } else if(TAG(s) == VerboseSymbol) { if(TYPEOF(CAR(s)) == INTSXP || TYPEOF(CAR(s)) == REALSXP) { *verbose = CAR(s); if(verbused++ > 0) error(_("formal argument '%s' matched by multiple actual arguments (dotCall64)"), "VERBOSE"); } else { error(_("formal argument 'VERBOSE' has wrong type (\"%s\"). Expected type: \"numeric\" or \"integer\" (dotCall64)"), type2char(TYPEOF(CAR(s)))); } } else { args[nargs] = CAR(s); names[nargs] = TAG(s); nargs++; } s = CDR(s); } *len = nargs; } static SEXP getListElement(SEXP list, const char *str) { SEXP elmt = R_NilValue, names = getAttrib(list, R_NamesSymbol); for (int i = 0; i < length(list); i++) { if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) { elmt = VECTOR_ELT(list, i); break; } } return elmt; } static int dotCall64str2type(SEXP s) { const char *str = CHAR(s); if(strcmp(str, INT64_STRING) == 0) { return INT64_TYPE; }else if(strcmp(str, "int") == 0) { return INTSXP; }else if(strcmp(str, "int32") == 0) { return INTSXP; } return str2type(str); } static SEXP allocInitializedVector(int type, R_xlen_t length) { SEXP s = PROTECT(allocVector(type, length)); switch(TYPEOF(s)) { case REALSXP: Memzero(REAL(s), length); break; case INTSXP: Memzero(INTEGER(s), length); break; default: error("type \"%s\" not yet supported by allocInitializedVector (dotCall64)", type2char(TYPEOF(s))); } UNPROTECT(1); return s; } dotCall64/NAMESPACE0000644000176200001440000000023613224667210013231 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(.C64) export(integer_dc) export(numeric_dc) export(vector_dc) useDynLib(dotCall64, .registration = TRUE) dotCall64/NEWS.md0000644000176200001440000000064613225707603013117 0ustar liggesusers# dotCall64 # 0.9-5.2 commit c184c8a9e883ccc3b5afe3d5639d689724f71176 Author: Florian Gerber Date: Thu Jan 11 17:14:48 2018 +0100 * improve documentation # 0.9-5 commit 1cfc4937b52fcad0ce6bf28b246cec289c15d07d Author: Florian Gerber Date: Tue Dec 5 21:37:52 2017 +0100 * debian patch * update references * register native routines # 0.9-4 * CRAN release. dotCall64/R/0000755000176200001440000000000013225705535012216 5ustar liggesusersdotCall64/R/vector_dc.R0000644000176200001440000000234013225704312014300 0ustar liggesusers#' Allocate vectors in .C64() #' #' \code{vector_dc} and its shortcuts \code{numeric_dc} and #' \code{integer_dc} are helper functions used in calls to \code{\link{.C64}}. #' They return an R object of class \code{c("vector_dc", "list")}, #' which contains information on the type and length of the vector to allocate. #' Using \code{vector_dc} together with \code{INTENT = "w"} argument of \code{\link{.C64}} #' leads to performance gains by avoiding unnecessary castings and copies. #' #' @param mode character vector of length 1. Storage mode of the vector. #' @param length numeric vector of length 1. Length of the vector. #' @return object of class \code{vector_dc} and \code{list}. #' @name vector_dc #' @rdname vector_dc #' @examples #' vector_dc("integer", 20) #' @export vector_dc <- function(mode = "logical", length = 0L) { r <- list(mode = as.character(mode), length = as.numeric(length)) class(r) <- c("vector_dc", "list") r } #' @name numeric_dc #' @rdname vector_dc #' @export numeric_dc <- function(length = 0) vector_dc(mode = "numeric", length = length) #' @name integer_dc #' @rdname vector_dc #' @export integer_dc <- function(length = 0) vector_dc(mode = "integer", length = length) dotCall64/R/dotCall64.R0000644000176200001440000001562313225706065014103 0ustar liggesusers#' dotCall64 - Extended Foreign Function Interface #' #' \code{.C64} can be used to call compiled and loaded C/C++ functions and Fortran subroutines. #' \code{.C64} is similar to \code{\link{.C}} and \code{\link{.Fortran}}, but #' \enumerate{ #' \item supports long vectors, i.e., vectors with more than \code{2^31-1} elements #' \item does the necessary castings to expose the R representation of "64-bit integers" (numeric vectors) #' to 64-bit integer arguments of the compiled function. The latter are int64_t in C code and integer (kind = 8) in Fortran code #' \item provides a mechanism the control duplication of the R objects exposed to the compiled code #' \item checks if the provided R objects are of the expected types and coerces them if necessary #' } #' Compared to \code{\link{.C}}, \code{.C64} has the additional arguments \code{SIGNATURE}, \code{INTENT} and \code{VERBOSE}. #' \code{SIGNATURE} specifies the types of the arguments of the compiled function. #' \code{INTENT} indicates whether the compiled function "reads", "writes", #' or "read and writes" to the R objects passed to the compiled function. #' This information is then used to duplicate R objects if and only if necessary. #' #' @param .NAME character vector of length 1. Name of the compiled function to be called. #' @param SIGNATURE character vector of the same length as the number of arguments of the compiled function. #' Accepted strings are \code{"double"}, \code{"integer"}, and \code{"int64"}. #' They describe the signature of each argument of the compiled function. #' @param ... arguments passed to the compiled function. One R object for each argument. Up to 65 arguments are supported. #' @param INTENT character vector of the same length as the number of arguments of the compiled function. #' Accepted strings are \code{"rw"}, \code{"r"}, and \code{"w"}, which indicate #' whether the intent of the argument is "read and write", "read", or "write", respectively. #' If the INTENT of an argument is \code{"rw"}, the R object is copied and the #' compiled function receives a pointer to that copy. #' If the INTENT of an R object is \code{"r"}, the compiled #' function receives a pointer to the R object itself. #' While this avoids copying and hence is more efficient in terms of speed and memory usage, #' it is absolutely necessary that the compiled function does not alter the object, #' since this corrupts the R object in the current R session. #' When the INTENT is \code{"w"}, the corresponding input argument can be specified #' with the function \code{\link{vector_dc}} or its shortcuts \code{\link{integer_dc}} and \code{\link{numeric_dc}}. #' This avoids copying the passed R objects and hence is more efficient in terms of speed and memory usage. #' By default, all arguments have INTENT \code{"rw"}. #' @param NAOK logical vector of length 1. If \code{FALSE} (default), the presence of \code{NA}, \code{NaN}, and \code{Inf} #' in the R objects passed through \code{...} results in an error. #' If \code{TRUE}, \code{NA}, \code{NaN}, and \code{Inf} values are passed to the compiled function. #' The used time to check arguments (if \code{FALSE}) is considerable for large vectors. #' @param PACKAGE character vector of length 1. Specifies where to search for the function given in \code{.NAME}. #' This is intended to add safety for packages, #' which can use this argument to ensure that no other package can override their external symbols, #' and also speeds up the search. #' @param VERBOSE numeric vector of length 1. If \code{0}, no warnings are printed. #' If \code{1}, warnings are printed, which help to improve the performance of the call. #' If \code{2}, additional debug information is given as warnings. #' The default value can be changed via the \code{dotCall64.verbose} option, which is set to \code{0} by default. #' #' @return list of R objects similar to the list of arguments specified as \code{...} arguments. #' The objects of the list reflect the changes made by the compiled C or Fortran function. #' #' @references #' F. Gerber, K. Moesinger, and R. Furrer (2017), #' Extending R packages to support 64-bit compiled code: An illustration with spam64 and GIMMS NDVI3g data, #' Computer & Geoscience 104, 109-119, #' https://doi.org/10.1016/j.cageo.2016.11.015. #' #' F. Gerber, K. Moesinger, and R. Furrer (2017), #' dotCall64: An efficient interface to compiled C/C++ and Fortran code supporting long vectors, #' https://arxiv.org/abs/1702.08188. #' #' @examples #' ## Consider the following C function, which is included #' ## in the dotCall64 package: #' ## void get_c(double *input, int *index, double *output) { #' ## output[0] = input[index[0] - 1]; #' ## } #' ## #' ## We can use .C64() to call get_c() from R: #' .C64("get_c", SIGNATURE = c("double", "integer", "double"), #' input = 1:10, index = 9, output = double(1))$output #' #' \dontrun{ #' ## 'input' can be a long vector #' x_long <- double(2^31) ## requires 16 GB RAM #' x_long[9] <- 9; x_long[2^31] <- -1 #' .C64("get_c", SIGNATURE = c("double", "integer", "double"), #' input = x_long, index = 9, output = double(1))$output #' #' ## Since 'index' is of type 'signed int' (a 32-bit integer), #' ## it can only address the first 2^31-1 elements of 'input'. #' ## To also address elements beyond 2^31-1, we change the #' ## definition of the C function as follows: #' ## #include // for int64_t #' ## void get64_c(double *input, int64_t *index, double *output) { #' ## output[0] = input[index[0] - 1]; #' ## } #' #' ## Now, we can use .C64() to call get64_c() from R. #' .C64("get64_c", SIGNATURE = c("double", "int64", "double"), #' input = x_long, index = 2^31, output = double(1))$output #' ## Note that 2^31 is of type double and .C64() casts it into an #' ## int64_t type before calling the C function get64_c(). #' #' ## The performance of the previous call can be improved by #' ## setting additional arguments: #' .C64("get64_c", SIGNATURE = c("double", "int64", "double"), #' x = x_long, i = 2^31, r = numeric_dc(1), INTENT = c("r", "r", "w"), #' NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0)$r #' #' #' ## Consider the same function defined in Fortran: #' ## subroutine get64_f(input, index, output) #' ## double precision :: input(*), output(*) #' ## integer (kind = 8) :: index ! specific to GFortran #' ## output(1) = input(index) #' ## end #' #' ## The function is provided in dotCall64 and can be called with #' .C64("get64_f", SIGNATURE = c("double", "int64", "double"), #' input = x_long, index = 2^31, output = double(1))$output #' } #' @useDynLib dotCall64, .registration = TRUE #' @export #' @name dotCall64 .C64 <- function(.NAME, SIGNATURE, ..., INTENT = NULL, NAOK = FALSE, PACKAGE = "", VERBOSE = getOption("dotCall64.verbose")) { .External("dC64", name = .NAME, SIGNATURE = SIGNATURE, ..., INTENT = INTENT, NAOK = NAOK, f.PACKAGE = PACKAGE, VERBOSE = VERBOSE, PACKAGE = "dotCall64") } dotCall64/R/zzz.R0000644000176200001440000000021213224667210013165 0ustar liggesusers.onLoad <- function(libname, pkgname) { if(is.null(getOption("dotCall64.verbose", NULL))) options("dotCall64.verbose" = 0L) } dotCall64/MD50000644000176200001440000000233213225754343012326 0ustar liggesusers0754dee2fca84c8680471efb375f08fc *DESCRIPTION 1ba18d2efda06ab031f178ca7e736a01 *NAMESPACE 2c68f04593e39af2bef7f419be05e13c *NEWS.md 8b51f3d261ad6f14bce13b6967ad569f *R/dotCall64.R 9979be048884f10640063c09d1b00878 *R/vector_dc.R 6ce69e2ecaa6aafccc57181a7bc52836 *R/zzz.R 2eaf60d9a55612cb6fd2528002cf0213 *inst/CITATION 013a77abf97cc8a7237c37e5ff9af37a *inst/include/dotCall64.h bc39e8bd582afbbb7ccf09d735417ed5 *man/dotCall64.Rd d96db3736e853f2eadce547224a297c6 *man/vector_dc.Rd 356b809b916a94506bcdde171e6e4cfc *src/Makevars 8ea93cdb08279ce23b8209f4dfa0bf5c *src/dotCall64.c 20ff6f909591b7aed0035f7fd7c2e684 *src/dotCall64helpers.c dad049af9ed37d954f4959b54a1cfe4e *src/init.c 4b772404f987db420fd647b31e159fb6 *src/testfunctions_c.c 1b0b68eab1e335c1aba9588886f4b480 *src/testfunctions_f.f 4b8524917a613bc864ba74a64b2e61a4 *tests/run-all.R dbc63fbcfec07edb4aa156b7006047cb *tests/testthat/test-againstDotC.R 6a553a88c246cddc8162f5d670d72a4e *tests/testthat/test-flow-center.R 270ec62a84ce15cbd3eb078000be7fc3 *tests/testthat/test-flow-left.R da9cbd48d318a59ffce13f8548f95f21 *tests/testthat/test-flow-right.R 5a3ac7afdb14a272d933d6798f5c2bd4 *tests/testthat/test-long_int64.R 8e08d43b49a64a53ad6d264374be7794 *tests/testthat/test-vector_dc.R dotCall64/DESCRIPTION0000644000176200001440000000253713225754343013533 0ustar liggesusersPackage: dotCall64 Type: Package Title: Enhanced Foreign Function Interface Supporting Long Vectors Version: 0.9-5.2 Date: 2018-01-11 Authors@R: c(person("Kaspar", "Moesinger", role = c("aut"), email = "kaspar.moesinger@gmail.com"), person("Florian", "Gerber", role = c("cre", "ctb"), email = "florian.gerber@math.uzh.ch"), person("Reinhard", "Furrer", role = "ctb", email = "reinhard.furrer@math.uzh.ch")) Description: Provides .C64(), which is an enhanced version of .C() and .Fortran() from the foreign function interface. .C64() supports long vectors, arguments of type 64-bit integer, and provides a mechanism to avoid unnecessary copies of read-only and write-only arguments. This makes it a convenient and fast interface to C/C++ and Fortran code. License: GPL (>= 2) URL: https://git.math.uzh.ch/reinhard.furrer/dotCall64 BugReports: https://git.math.uzh.ch/reinhard.furrer/dotCall64/issues Depends: R (>= 3.1) Suggests: microbenchmark, OpenMPController, RColorBrewer, roxygen2, spam, testthat, Collate: 'vector_dc.R' 'dotCall64.R' 'zzz.R' RoxygenNote: 6.0.1 NeedsCompilation: yes Packaged: 2018-01-11 16:23:57 UTC; floger Author: Kaspar Moesinger [aut], Florian Gerber [cre, ctb], Reinhard Furrer [ctb] Maintainer: Florian Gerber Repository: CRAN Date/Publication: 2018-01-11 21:36:35 UTC dotCall64/man/0000755000176200001440000000000013225704312012560 5ustar liggesusersdotCall64/man/vector_dc.Rd0000644000176200001440000000174513225704312015026 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/vector_dc.R \name{vector_dc} \alias{vector_dc} \alias{numeric_dc} \alias{integer_dc} \title{Allocate vectors in .C64()} \usage{ vector_dc(mode = "logical", length = 0L) numeric_dc(length = 0) integer_dc(length = 0) } \arguments{ \item{mode}{character vector of length 1. Storage mode of the vector.} \item{length}{numeric vector of length 1. Length of the vector.} } \value{ object of class \code{vector_dc} and \code{list}. } \description{ \code{vector_dc} and its shortcuts \code{numeric_dc} and \code{integer_dc} are helper functions used in calls to \code{\link{.C64}}. They return an R object of class \code{c("vector_dc", "list")}, which contains information on the type and length of the vector to allocate. Using \code{vector_dc} together with \code{INTENT = "w"} argument of \code{\link{.C64}} leads to performance gains by avoiding unnecessary castings and copies. } \examples{ vector_dc("integer", 20) } dotCall64/man/dotCall64.Rd0000644000176200001440000001476313225706155014625 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dotCall64.R \name{dotCall64} \alias{dotCall64} \alias{.C64} \title{dotCall64 - Extended Foreign Function Interface} \usage{ .C64(.NAME, SIGNATURE, ..., INTENT = NULL, NAOK = FALSE, PACKAGE = "", VERBOSE = getOption("dotCall64.verbose")) } \arguments{ \item{.NAME}{character vector of length 1. Name of the compiled function to be called.} \item{SIGNATURE}{character vector of the same length as the number of arguments of the compiled function. Accepted strings are \code{"double"}, \code{"integer"}, and \code{"int64"}. They describe the signature of each argument of the compiled function.} \item{...}{arguments passed to the compiled function. One R object for each argument. Up to 65 arguments are supported.} \item{INTENT}{character vector of the same length as the number of arguments of the compiled function. Accepted strings are \code{"rw"}, \code{"r"}, and \code{"w"}, which indicate whether the intent of the argument is "read and write", "read", or "write", respectively. If the INTENT of an argument is \code{"rw"}, the R object is copied and the compiled function receives a pointer to that copy. If the INTENT of an R object is \code{"r"}, the compiled function receives a pointer to the R object itself. While this avoids copying and hence is more efficient in terms of speed and memory usage, it is absolutely necessary that the compiled function does not alter the object, since this corrupts the R object in the current R session. When the INTENT is \code{"w"}, the corresponding input argument can be specified with the function \code{\link{vector_dc}} or its shortcuts \code{\link{integer_dc}} and \code{\link{numeric_dc}}. This avoids copying the passed R objects and hence is more efficient in terms of speed and memory usage. By default, all arguments have INTENT \code{"rw"}.} \item{NAOK}{logical vector of length 1. If \code{FALSE} (default), the presence of \code{NA}, \code{NaN}, and \code{Inf} in the R objects passed through \code{...} results in an error. If \code{TRUE}, \code{NA}, \code{NaN}, and \code{Inf} values are passed to the compiled function. The used time to check arguments (if \code{FALSE}) is considerable for large vectors.} \item{PACKAGE}{character vector of length 1. Specifies where to search for the function given in \code{.NAME}. This is intended to add safety for packages, which can use this argument to ensure that no other package can override their external symbols, and also speeds up the search.} \item{VERBOSE}{numeric vector of length 1. If \code{0}, no warnings are printed. If \code{1}, warnings are printed, which help to improve the performance of the call. If \code{2}, additional debug information is given as warnings. The default value can be changed via the \code{dotCall64.verbose} option, which is set to \code{0} by default.} } \value{ list of R objects similar to the list of arguments specified as \code{...} arguments. The objects of the list reflect the changes made by the compiled C or Fortran function. } \description{ \code{.C64} can be used to call compiled and loaded C/C++ functions and Fortran subroutines. \code{.C64} is similar to \code{\link{.C}} and \code{\link{.Fortran}}, but \enumerate{ \item supports long vectors, i.e., vectors with more than \code{2^31-1} elements \item does the necessary castings to expose the R representation of "64-bit integers" (numeric vectors) to 64-bit integer arguments of the compiled function. The latter are int64_t in C code and integer (kind = 8) in Fortran code \item provides a mechanism the control duplication of the R objects exposed to the compiled code \item checks if the provided R objects are of the expected types and coerces them if necessary } Compared to \code{\link{.C}}, \code{.C64} has the additional arguments \code{SIGNATURE}, \code{INTENT} and \code{VERBOSE}. \code{SIGNATURE} specifies the types of the arguments of the compiled function. \code{INTENT} indicates whether the compiled function "reads", "writes", or "read and writes" to the R objects passed to the compiled function. This information is then used to duplicate R objects if and only if necessary. } \examples{ ## Consider the following C function, which is included ## in the dotCall64 package: ## void get_c(double *input, int *index, double *output) { ## output[0] = input[index[0] - 1]; ## } ## ## We can use .C64() to call get_c() from R: .C64("get_c", SIGNATURE = c("double", "integer", "double"), input = 1:10, index = 9, output = double(1))$output \dontrun{ ## 'input' can be a long vector x_long <- double(2^31) ## requires 16 GB RAM x_long[9] <- 9; x_long[2^31] <- -1 .C64("get_c", SIGNATURE = c("double", "integer", "double"), input = x_long, index = 9, output = double(1))$output ## Since 'index' is of type 'signed int' (a 32-bit integer), ## it can only address the first 2^31-1 elements of 'input'. ## To also address elements beyond 2^31-1, we change the ## definition of the C function as follows: ## #include // for int64_t ## void get64_c(double *input, int64_t *index, double *output) { ## output[0] = input[index[0] - 1]; ## } ## Now, we can use .C64() to call get64_c() from R. .C64("get64_c", SIGNATURE = c("double", "int64", "double"), input = x_long, index = 2^31, output = double(1))$output ## Note that 2^31 is of type double and .C64() casts it into an ## int64_t type before calling the C function get64_c(). ## The performance of the previous call can be improved by ## setting additional arguments: .C64("get64_c", SIGNATURE = c("double", "int64", "double"), x = x_long, i = 2^31, r = numeric_dc(1), INTENT = c("r", "r", "w"), NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0)$r ## Consider the same function defined in Fortran: ## subroutine get64_f(input, index, output) ## double precision :: input(*), output(*) ## integer (kind = 8) :: index ! specific to GFortran ## output(1) = input(index) ## end ## The function is provided in dotCall64 and can be called with .C64("get64_f", SIGNATURE = c("double", "int64", "double"), input = x_long, index = 2^31, output = double(1))$output } } \references{ F. Gerber, K. Moesinger, and R. Furrer (2017), Extending R packages to support 64-bit compiled code: An illustration with spam64 and GIMMS NDVI3g data, Computer & Geoscience 104, 109-119, https://doi.org/10.1016/j.cageo.2016.11.015. F. Gerber, K. Moesinger, and R. Furrer (2017), dotCall64: An efficient interface to compiled C/C++ and Fortran code supporting long vectors, https://arxiv.org/abs/1702.08188. }