diff --git a/.Rbuildignore b/.Rbuildignore
new file mode 100644
index 0000000000000000000000000000000000000000..ded27b546ba12d0177d232e76fa50da13895d904
--- /dev/null
+++ b/.Rbuildignore
@@ -0,0 +1,3 @@
+benchmark
+^.*\.Rproj$
+^\.Rproj\.user$
diff --git a/DESCRIPTION b/DESCRIPTION
index 15caa2963c0e5047853c88828449a77ab08cddd5..7b48b94894ae222e04590d3a69bc44a07542d5d5 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,8 +1,8 @@
Package: dotCall64
Type: Package
-Title: Foreign Function Interface with long vector support
-Version: 1.0
-Date: 2015-08-25
+Title: Enhanced Foreign Function Interface Supporting Long Vectors
+Version: 0.9-01
+Date: xxxx-xx-xx
Authors@R: c(person("Kaspar", "Moesinger", role = c("aut", "cre"),
email = "kaspar.moesinger@gmail.com"),
person("Florian", "Gerber", role = "ctb",
@@ -11,11 +11,18 @@ Authors@R: c(person("Kaspar", "Moesinger", role = c("aut", "cre"),
email = "reinhard.furrer@math.uzh.ch"))
Author: Kaspar Moesinger [aut, cre], Florian Gerber [ctb], Reinhard Furrer [ctb]
Maintainer: Kaspar Moesinger <kaspar.moesinger@gmail.com>
-Description: Foreign Function Interface with long vector support
-License: GPL
+Description:
+ An alternative version of .C() and .Fortran() supporting long vectors and 64-bit integer type arguments. The provided interface .C64() features mechanisms the avoid unnecessary copies of read-only or write-only arguments. This makes it a convenient and fast interface to C/C++ and Fortran code.
+License: GPL (>= 2)
+Depends: R (>= 3.1)
+Suggests:
+ microbenchmark,
+ OpenMPController,
+ RColorBrewer,
+ roxygen2,
+ spam,
+ testthat,
Collate:
'vector_dc.R'
'dotCall64.R'
- 'dotCall2.R'
- 'integer_dc.R'
- 'numeric_dc.R'
+ 'zzz.R'
diff --git a/R/dotCall2.R b/R/dotCall2.R
deleted file mode 100644
index 1ff2a8e1b1db15de66c7cc1d6cadf4767ff8b0f5..0000000000000000000000000000000000000000
--- a/R/dotCall2.R
+++ /dev/null
@@ -1,54 +0,0 @@
-
-#' @export
-arg <- function(type, intent = ifelse(is.null(object),"w", "rw"), object = NULL, length = NULL) {
- if(!is.null(object) && !is.null(length))
- stop("Either object or length must be NULL.")
- if(is.null(object) && is.null(length))
- stop("Either object or length must be a specified.")
-
- list(type=type, object = object, intent = intent, length = length)
-}
-
-
-#' @include vector_dc.R dotCall64.R
-#' @export
-dotCall2 <- function(name, ..., PACKAGE="") {
-
- args.given <- list(...)
- intent <- character(length(args.given))
- signature <- character(length(args.given))
- args.new <- list()
-
- for (i in 1:length(args.given)) {
- o <- args.given[[i]]
-
- intent[i] <- o$intent
- signature[i] <- o$type
-
- if(is.null(o$len)) {
- args.new[i] <- o$object
- }else{
- mode <- o$type
- if(mode == "int64") {
- mode <- "double"
- }
- args.new[[i]] <- vector_dc(mode=mode, length=o$length)
- }
- }
- names(args.new) <- names(args.given)
-
- li <- c(
- list(
- name=name,
- SIGNATURE = signature
- ),
- args.new,
- list(INTENT=intent),
- PACKAGE=PACKAGE
- )
-
- do.call(.C64, li)
-}
-
-
-
diff --git a/R/dotCall64.R b/R/dotCall64.R
index 66099e45f9c3d4d5c72000c4e83facd35130fde3..2ce360cb5aa07e111797c43604fef8e393820d51 100644
--- a/R/dotCall64.R
+++ b/R/dotCall64.R
@@ -1,57 +1,123 @@
-
#' dotCall64 - Extended Foreign Function Interface
#'
-#' \code{.C64} is a function to make calls to compiled code that has been loaded into R.
-#' The function works similar to the ones of the Foreign Function Interface but it
+#' \code{.C64} can be used to call compiled and loaded C functions and Fortran subroutines.
+#' It works similar to \code{\link{.C}} and \code{\link{.Fortran}}, and
#' \enumerate{
-#' \item supports long vectors.
-#' \item supports int64_t as argument for compiled code.
-#' \item duplicates objects if necessary to not corrupt another variable.
-#' \item casts objects to the expected argument.
+#' \item supports long vectors, i.e., vectors with more than \code{2^31-1} elements,
+#' \item does the necessary castings to expose the R represantation of "64-bit integers" (numeric vectors)
+#' to 64-bit integers arguments of the compiled function; int64_t types in C and integer (kind = 8) in Fortran,
+#' \item provides a mechanism the control the duplication of the R objects exposed to the compiled code,
+#' \item checks if the provided R objects are of the expected type and coerces the R object if necessary.
#' }
-#' This is achieved by the two addional arguments \code{INTENT} and \code{SIGNATURE}.
-#' They describe how the arguments will be used.
-#' dotCall64 will uses this information to prepare the arguments.
-#' The user just has to describe its intentions and the package will do the actual work.
-#'
-#' @param name a character string giving the name of a C function or Fortran subroutine.
-#' @param ... arguments to be passed to the foreign function. Up to 65.
-#' @param INTENT a vector of type character. For each argument, the string indicates the intent of the function.
-#' The accepted values are \code{"r"}, \code{"w" }or \code{"rw"} for indicating read, write respectively read/write.
-#' Additionally, the modifiers speed \code{"s"} and copy \code{"c"} can be added.
-#' If this argument is missing, it is assumed that all arguments are \code{"rw"}.
-#' See details.
-#' @param SIGNATURE a vector of type character.
-#' It describes the signature of the C/Fortran function.
-#' It accepts \code{"double"}, \code{"integer"}, \code{"int64"}.
-#' @param PACKAGE if supplied, confine the search for a character string .NAME to the DLL given by this argument (plus the conventional extension, '.so', '.dll', ...).
-#' This is intended to add safety for packages, which can ensure by using this argument that no other package can override their external symbols, and also speeds up the search (see 'Note').
-#'
-#' @return A list similar to the \code{...} list of arguments passed in (including any names given to the arguments), but reflecting any changes made by the C or Fortran code.
-#'
-#' @details
-#' DotCall64 prioritizes memory efficiency over speed.
-#' If we have an argument of signature \code{int64_t} and intent \code{"r"},
-#' then before calling the function, \code{dotCall64} casts the double array in place
-#' (meaning it overwrites the memory of the double object) into \code{int64_t} and casts them back after the call, such that the original object is still readable.
-#' If the modifier speed is set, then instead of reusing the memory, it allocates new memory and casts the values into this new memory.
-#' After the call, it just discards the memory as there is no need to cast it back.
-#'
-#' @section Warning:
-#' If intent is set to \code{"w"}, then the function \emph{must not} assume that the elements are initialized to zero.
-#' If this should be the case, use \code{"rw"} and pass a zero initialized vector.
+#' 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" the R objects passed
+#' to the compiled function. This is then used to duplicates R objects if (and only if) necessary.
#'
+#' @param .NAME a character vector of length 1. Specifies the name of the compiled function to be called.
+#' @param SIGNATURE a character vector of the same length as the number of arguments of the compiled function.
+#' Accepted strings are \code{"double"}, \code{"integer"}, \code{"int64"} describing 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 a character vector of the same length as the number of arguments of the compiled code.
+#' Accepted strings are \code{"rw"}, \code{"r"} or \code{"w"} indicating
+#' 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} or \code{NaN} or \code{Inf}
+#' in the R objects passed through \code{...} results in an error.
+#' If \code{TRUE}, any \code{NA} or \code{NaN} or \code{Inf} values in the
+#' arguments are passed on to the compiled function.
+#' The used time to check arguments (if \code{FALSE}) maybe 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 may 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 A list similar to the \code{...} list of arguments passed in (including
+#' any names given to the arguments), but reflecting any changes made
+#' by the compiled C or Fortran code.
+#'
+#' @references
+#' F. Gerber, K. Moesinger, and R. Furrer,
+#' "dotCall64: An efficient interface to compiled C/C++ and Fortran code
+#' supporting long vectors", submitted to the Rjournal, 2016.
+#'
+#' F. Gerber, K. Moesinger, and R. Furrer,
+#' "Extending R packages to support 64-bit compiled code: An illustration
+#' with spam64 and GIMMS NDVI 3g data", submitted to Computers & Geoscience, 2015.
+#'
#' @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() the call it from R:
+#' .C64("get_c", SIGNATURE = c("double", "integer", "double"),
+#' input = 1:10, index = 9, output = double(1))$output
+#'
#' \dontrun{
-#' TODO: Demo aus Paper nehmen
-#' }
+#' ## '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' resulting in a 32-bit integer,
+#' ## it can only capture integers op to 2^31-1. To extend this,
+#' ## we define the C function as follows:
+#' ## #include <stdint.h> // defines the int64_t type
+#' ## void get64_c(double *input, int64_t *index, double *output) {
+#' ## output[0] = input[index[0] - 1];
+#' ## }
#'
+#' ## We can use .C64() to call the function from R.
+#' .C64("get64_c", SIGNATURE = c("double", "int64", "double"),
+#' input = x_long, index = 2^31, output = double(1))$output
+#'
+#' ## Note that .C64() takes 2^31 as double and casts it to int64_t
+#' ## before calling the C function get64_c().
+#'
+#' ## The performance of the previous call can be improved with
+#' ## additional options:
+#' .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
#' @export
#' @name dotCall64
-.C64 <- function(name, SIGNATURE, ..., INTENT=NULL, PACKAGE = "") {
- .External("dC64", name, SIGNATURE=SIGNATURE, ..., INTENT=INTENT, f.PACKAGE=PACKAGE)
+.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")
}
-#.External("dC64", name, SIGNATURE=SIGNATURE, ..., INTENT=INTENT, f.PACKAGE=PACKAGE, PACKAGE="dotCall64")
diff --git a/R/integer_dc.R b/R/integer_dc.R
deleted file mode 100644
index 9d1648ace6824f23a84253833631fb5741d5829f..0000000000000000000000000000000000000000
--- a/R/integer_dc.R
+++ /dev/null
@@ -1,4 +0,0 @@
-
-#' @include vector_dc.R
-#' @export
-integer_dc <- function(length = 0) vector_dc(mode = "integer", length = length)
\ No newline at end of file
diff --git a/R/numeric_dc.R b/R/numeric_dc.R
deleted file mode 100644
index 75e543b9da0566ae54931fa00eddfb9a5d7da7fa..0000000000000000000000000000000000000000
--- a/R/numeric_dc.R
+++ /dev/null
@@ -1,4 +0,0 @@
-
-#' @include vector_dc.R
-#' @export
-numeric_dc <- function(length = 0) vector_dc(mode = "numeric", length = length)
\ No newline at end of file
diff --git a/R/vector_dc.R b/R/vector_dc.R
index 8a24f4174d53dccd13db7ed5fb64a2499437c3eb..77c2e92827a01b515767944fb9d172d07208c233 100644
--- a/R/vector_dc.R
+++ b/R/vector_dc.R
@@ -1,6 +1,34 @@
+#' Allocate vectors in .C64()
+#'
+#' Helper functions to be used in calls to \code{\link{.C64}}.
+#' The function \code{vector_dc} and its shortcuts \code{numeric_dc} and
+#' \code{integer_dc} return a R object of class \code{c("vector_dc", "list")}
+#' containing the necessary information (type and length) to allocate the
+#' vector (initialized with 0) inside the call to \code{\link{.C64}}.
+#' 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 to allocate.
+#' @param length Numeric vector of length 1. Length of the vector to allocate.
+#' @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)
-#' dfg
+#' @name integer_dc
+#' @rdname vector_dc
#' @export
-vector_dc <- function(mode = "logical", length = 0) {
- list(mode=mode, length=length)
-}
\ No newline at end of file
+integer_dc <- function(length = 0) vector_dc(mode = "integer", length = length)
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000000000000000000000000000000000000..377f9dfb03cca0e67c73e921dfe35b2aef285eeb
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,5 @@
+.onLoad <- function(libname, pkgname)
+{
+ if(is.null(getOption("dotCall64.verbose", NULL)))
+ options("dotCall64.verbose" = 0L)
+}
diff --git a/benchmark/benchmark_memory.R b/benchmark/benchmark_memory.R
new file mode 100644
index 0000000000000000000000000000000000000000..249ed21b2062a603b8707f0979c10ebc76383f77
--- /dev/null
+++ b/benchmark/benchmark_memory.R
@@ -0,0 +1,112 @@
+rm(list = ls(all = TRUE))
+require("dotCall64")
+require("microbenchmark")
+require("xtable"); options(xtable.NA.string = "--")
+require("OpenMPController"); omp_set_num_threads(1)
+mem <- function(...){
+ ## measure peak memory usage with gctorture()
+
+ exprs <- c(as.list(match.call(expand.dots = FALSE)$...))
+ exprnm <- sapply(exprs, function(e) paste(deparse(e), collapse = " "))
+
+ ## give names
+ nm <- names(exprs)
+ if (is.null(nm))
+ nm <- exprnm
+ else nm[nm == ""] <- exprnm[nm == ""]
+
+ n <- length(exprs)
+
+ out <- data.frame(expr = rep(NA, n), mem.peak = rep(NA, n),
+ mem.end = rep(NA, n))
+ out[, "expr"] <- nm
+ for(i in 1:n){
+ mem.before <- gc(reset=TRUE)[2,2]
+ gctorture(TRUE)
+ eval(exprs[[i]])
+ gctorture(FALSE)
+ gc.report <- gc()
+ mem.max <- gc.report[2,6]
+ mem.after <- gc.report[2,2]
+ out[i, "mem.peak"] <- mem.max - mem.before
+ out[i, "mem.end"]<- mem.after - mem.before
+ }
+ out
+}
+
+## table memory usage ---
+len <- 2^27
+num <- numeric(len)
+int <- integer(len)
+
+
+mfd0 <- expression({
+ .C("BENCHMARK", a = num, NAOK = FALSE, PACKAGE = "dotCall64")
+})
+mfd_rw <- expression({
+ .C64("BENCHMARK", "double", a = num, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+mfd_r <- expression({
+ .C64("BENCHMARK", "double", a = num, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+mfd0C <- expression({
+ .C("BENCHMARK", a = numeric(len), NAOK = FALSE, PACKAGE = "dotCall64")
+})
+mfd_w <- expression({
+ .C64("BENCHMARK", "double", a = numeric_dc(len), INTENT = "w",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+fd_mm <- mem(eval(mfd0), eval(mfd_rw), eval(mfd_r), eval(mfd0C), eval(mfd_w))
+
+
+mfi0 <- expression({
+ .C("BENCHMARK", a = int, NAOK = FALSE, PACKAGE = "dotCall64")
+})
+mfi_rw <- expression({
+ .C64("BENCHMARK", "integer", a = int, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+mfi_r <- expression({
+ .C64("BENCHMARK", "integer", a = int, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+mfi0C <- expression({
+ .C("BENCHMARK", a = integer(len), NAOK = FALSE, PACKAGE = "dotCall64")
+})
+mfi_w <- expression({
+ .C64("BENCHMARK", "integer", a = integer_dc(len), INTENT = "w",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+fi_mm <- mem(eval(mfi0), eval(mfi_rw), eval(mfi_r), eval(mfi0C), eval(mfi_w))
+
+
+mfi64_rw <- expression({
+ .C64("BENCHMARK", "int64", a = num, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+mfi64_r <- expression({
+ .C64("BENCHMARK", "int64", a = num, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+mfi64_w <- expression({
+ .C64("BENCHMARK", "int64", a = numeric_dc(len), INTENT = "w",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0)
+})
+
+fi64_mm <- mem(eval(mfi64_rw), eval(mfi64_r), eval(mfi64_w))
+
+
+tab_mem <- rbind(fd_mm$mem.peak / mem(double(len))$mem.peak,
+ fi_mm$mem.peak / mem(integer(len))$mem.peak,
+ c(fi64_mm$mem.peak / mem(double(len))$mem.peak)[c(NA,1,2,NA,3)])
+tab_mem <- data.frame(tab_mem)
+colnames(tab_mem) <- c(".C()", ".C64(rw)", ".C64(r)",
+ ".C()", ".C64(w NAOK)")
+tab_mem
+
+xtable(tab_mem, digits = 0)
+
+sessionInfo()
+system("head -n25 /proc/cpuinfo") ## works on Linux
diff --git a/benchmark/benchmark_n1.R b/benchmark/benchmark_n1.R
new file mode 100644
index 0000000000000000000000000000000000000000..1459b5762adab63736d5a5bd4ea469357e542ba0
--- /dev/null
+++ b/benchmark/benchmark_n1.R
@@ -0,0 +1,90 @@
+rm(list = ls(all = TRUE))
+require("dotCall64")
+require("microbenchmark")
+require("OpenMPController"); omp_set_num_threads(1)
+mb <- microbenchmark
+
+## functions to print latex tables with brackets
+Round <- function(x, k) format(round(x, k), nsmall=k)
+xxtab <- function(x, b, digits){
+ x <- Round(x, digits)
+ b <- paste0(" (", Round(b, digits), ") ", c(rep("& ", length(b)-1), "\\\\"))
+ paste(c(rbind(x, b)), collapse = "")
+}
+xxxtab <- function(xmat, bmat, digits = 1){
+ for(i in 1:nrow(xmat))
+ cat(xxtab(xmat[i,], bmat[i,], digits = digits) , "\n")
+}
+## xxtab(1:5, 6:10, 3)
+## xxxtab(array(1:4, c(2,2))/7,array(1:4, c(2,2))+10 /7, 2)
+
+
+## read / read and write -------------------------------------------
+times <- 10000
+len <- 1
+num <- numeric(len)
+#num_dc <- numeric_dc(2^10)
+int <- integer(len)
+
+fd_mb <- mb(
+ .C("BENCHMARK", a = num, NAOK = FALSE, PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "double", a = num, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "double", a = num, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C("BENCHMARK", a = num, NAOK = TRUE, PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "double", a = num, INTENT = "rw",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "double", a = num, INTENT = "r",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+
+fd_df <- as.data.frame(fd_mb)
+levels(fd_df$expr) <- c(".C", ".C64", ".C64r", ".CNA", ".C64NA", ".C64NAr")
+fd_median <- c(unlist(by(fd_df[[2]], fd_df[[1]], median)))
+fd_IQR <- c(unlist(by(fd_df[[2]], fd_df[[1]], IQR)))
+
+
+fi_mb <- mb(
+ .C("BENCHMARK", a = int, NAOK = FALSE, PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = int, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = int, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C("BENCHMARK", a = int, NAOK = TRUE, PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = int, INTENT = "rw",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = int, INTENT = "r",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+fi_df <- as.data.frame(fi_mb)
+levels(fi_df$expr) <- c(".C", ".C64", ".C64r", ".CNA", ".C64NA", ".C64NAr")
+fi_median <- c(unlist(by(fi_df[[2]], fi_df[[1]], median)))
+fi_IQR <- c(unlist(by(fi_df[[2]], fi_df[[1]], IQR)))
+
+fi64_mb <- mb(
+ .C64("BENCHMARK", SIGNATURE = "int64", a = num, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "int64", a = num, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "int64", a = num, INTENT = "rw",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "int64", a = num, INTENT = "r",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+fi64_df <- as.data.frame(fi64_mb)
+levels(fi64_df$expr) <- c(".C64", ".C64r", ".C64NA", ".C64NAr")
+fi64_median <- c(unlist(by(fi64_df[[2]], fi64_df[[1]], median)))
+fi64_IQR <- c(unlist(by(fi64_df[[2]], fi64_df[[1]], IQR)))
+
+
+tab <- round(rbind(fd_median, fi_median, fi64_median = fi64_median[c(NA,1,2,NA,3,4)]) / 1e3, 2)
+tabIQR <- round(rbind(fd_IQR, fi_IQR, fi64_IQR = fi64_IQR[c(NA,1,2,NA,3,4)]) / 1e3, 2)
+tab
+tabIQR
+
+## unit is microseconds
+xxxtab(tab, tabIQR, 2)
+
+sessionInfo()
+system("head -n25 /proc/cpuinfo") ## works on Linux
diff --git a/benchmark/benchmark_n2_28.R b/benchmark/benchmark_n2_28.R
new file mode 100644
index 0000000000000000000000000000000000000000..7f18521b356393da517fcff3fc07a339bcb35436
--- /dev/null
+++ b/benchmark/benchmark_n2_28.R
@@ -0,0 +1,89 @@
+rm(list = ls(all = TRUE))
+require("dotCall64")
+require("microbenchmark")
+require("OpenMPController"); omp_set_num_threads(1)
+mb <- microbenchmark
+
+## functions to print latex tables with brackets
+Round <- function(x, k) format(round(x, k), nsmall=k)
+xxtab <- function(x, b, digits){
+ x <- Round(x, digits)
+ b <- paste0(" (", Round(b, digits), ") ", c(rep("& ", length(b)-1), "\\\\"))
+ paste(c(rbind(x, b)), collapse = "")
+}
+xxxtab <- function(xmat, bmat, digits = 1){
+ for(i in 1:nrow(xmat))
+ cat(xxtab(xmat[i,], bmat[i,], digits = digits) , "\n")
+}
+## xxtab(1:5, 6:10, 3)
+## xxxtab(array(1:4, c(2,2))/7,array(1:4, c(2,2))+10 /7, 2)
+
+
+## read / read and write -------------------------------------------
+times <- 100
+len <- 2^28
+num <- numeric(len)
+int <- integer(len)
+
+fd_mb <- mb(
+ .C("BENCHMARK", a = num, NAOK = FALSE, PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "double", a = num, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "double", a = num, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C("BENCHMARK", a = num, NAOK = TRUE, PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "double", a = num, INTENT = "rw",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "double", a = num, INTENT = "r",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+
+fd_df <- as.data.frame(fd_mb)
+levels(fd_df$expr) <- c(".C", ".C64", ".C64r", ".CNA", ".C64NA", ".C64NAr")
+fd_median <- c(unlist(by(fd_df[[2]], fd_df[[1]], median)))
+fd_IQR <- c(unlist(by(fd_df[[2]], fd_df[[1]], IQR)))
+
+
+fi_mb <- mb(
+ .C("BENCHMARK", a = int, NAOK = FALSE, PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = int, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = int, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C("BENCHMARK", a = int, NAOK = TRUE, PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = int, INTENT = "rw",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = int, INTENT = "r",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+fi_df <- as.data.frame(fi_mb)
+levels(fi_df$expr) <- c(".C", ".C64", ".C64r", ".CNA", ".C64NA", ".C64NAr")
+fi_median <- c(unlist(by(fi_df[[2]], fi_df[[1]], median)))
+fi_IQR <- c(unlist(by(fi_df[[2]], fi_df[[1]], IQR)))
+
+fi64_mb <- mb(
+ .C64("BENCHMARK", SIGNATURE = "int64", a = num, INTENT = "rw",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "int64", a = num, INTENT = "r",
+ NAOK = FALSE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "int64", a = num, INTENT = "rw",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "int64", a = num, INTENT = "r",
+ NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+fi64_df <- as.data.frame(fi64_mb)
+levels(fi64_df$expr) <- c(".C64", ".C64r", ".C64NA", ".C64NAr")
+fi64_median <- c(unlist(by(fi64_df[[2]], fi64_df[[1]], median)))
+fi64_IQR <- c(unlist(by(fi64_df[[2]], fi64_df[[1]], IQR)))
+
+
+tab <- round(rbind(fd_median, fi_median, fi64_median = fi64_median[c(NA,1,2,NA,3,4)]) / 1e9, 2)
+tabIQR <- round(rbind(fd_IQR, fi_IQR, fi64_IQR = fi64_IQR[c(NA,1,2,NA,3,4)]) / 1e9, 2)
+tab
+tabIQR
+
+## units: seconds
+xxxtab(tab, tabIQR, 2)
+
+sessionInfo()
+system("head -n25 /proc/cpuinfo") ## works on Linux
diff --git a/benchmark/benchmark_n2_28_w.R b/benchmark/benchmark_n2_28_w.R
new file mode 100644
index 0000000000000000000000000000000000000000..cc9fdf57f15a3c802938cb4a6b6517bb3d1a560e
--- /dev/null
+++ b/benchmark/benchmark_n2_28_w.R
@@ -0,0 +1,75 @@
+rm(list = ls(all = TRUE))
+require("dotCall64")
+require("microbenchmark"); mb <- microbenchmark
+require("OpenMPController"); omp_set_num_threads(1)
+
+
+## functions to print latex tables with brackets
+Round <- function(x, k) format(round(x, k), nsmall=k)
+xxtab <- function(x, b, digits){
+ x <- Round(x, digits)
+ b <- paste0(" (", Round(b, digits), ") ", c(rep("& ", length(b)-1), "\\\\"))
+ paste(c(rbind(x, b)), collapse = "")
+}
+xxxtab <- function(xmat, bmat, digits = 1){
+ for(i in 1:nrow(xmat))
+ cat(xxtab(xmat[i,], bmat[i,], digits = digits) , "\n")
+}
+## xxtab(1:5, 6:10, 3)
+## xxxtab(array(1:4, c(2,2))/7,array(1:4, c(2,2))+10 /7, 2)
+
+
+## read / read and write -------------------------------------------
+times <- 100
+len <- 2^28
+
+fd_mb <- mb(
+ .C("BENCHMARK", a = numeric(len), NAOK = TRUE,
+ PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "double", a = numeric(len),
+ INTENT = "rw", NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "double", a = numeric_dc(len),
+ INTENT = "w", NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+fd_df <- as.data.frame(fd_mb)
+levels(fd_df$expr) <- c(".C", ".C64", ".C64w")
+fd_median <- c(unlist(by(fd_df[[2]], fd_df[[1]], median)))
+fd_IQR <- c(unlist(by(fd_df[[2]], fd_df[[1]], IQR)))
+
+
+fi_mb <- mb(
+ .C("BENCHMARK", a = integer(len), NAOK = TRUE,
+ PACKAGE = "dotCall64"),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = integer(len),
+ INTENT = "rw", NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "integer", a = integer_dc(len),
+ INTENT = "w", NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+fi_df <- as.data.frame(fi_mb)
+levels(fi_df$expr) <- c(".C", ".C64", ".C64w")
+fi_median <- c(unlist(by(fi_df[[2]], fi_df[[1]], median)))
+fi_IQR <- c(unlist(by(fi_df[[2]], fi_df[[1]], IQR)))
+
+fi64_mb <- mb(
+ .C64("BENCHMARK", SIGNATURE = "int64", a = numeric(len),
+ INTENT = "rw", NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ .C64("BENCHMARK", SIGNATURE = "int64", a = numeric_dc(len),
+ INTENT = "w", NAOK = TRUE, PACKAGE = "dotCall64", VERBOSE = 0),
+ times = times)
+fi64_df <- as.data.frame(fi64_mb)
+levels(fi64_df$expr) <- c(".C64", ".C64w")
+fi64_median <- c(unlist(by(fi64_df[[2]], fi64_df[[1]], median)))
+fi64_IQR <- c(unlist(by(fi64_df[[2]], fi64_df[[1]], IQR)))
+
+
+tab <- round(rbind(fd_median, fi_median,
+ fi64_median = fi64_median[c(NA,1,2)]) / 1e9, 2)
+tabIQR <- round(rbind(fd_IQR, fi_IQR, fi64_IQR = fi64_IQR[c(NA,1,2)]) / 1e9, 2)
+tab
+tabIQR
+
+## units: seconds
+xxxtab(tab, tabIQR, 2)
+
+sessionInfo()
+system("head -n25 /proc/cpuinfo") ## works on Linux
diff --git a/benchmark/benchmark_openMP.R b/benchmark/benchmark_openMP.R
new file mode 100644
index 0000000000000000000000000000000000000000..85b5c0d2692612fa7e599dab59b2dbb53c451207
--- /dev/null
+++ b/benchmark/benchmark_openMP.R
@@ -0,0 +1,35 @@
+rm(list = ls(all = TRUE))
+require("dotCall64")
+require("microbenchmark")
+require("OpenMPController"); omp_set_num_threads(1)
+mb <- microbenchmark
+
+times <- 5
+gg <- expand.grid(rep = 1:times, length = seq(34, 16, -6),
+ threads = 1:10)
+gg$res <- NA
+dimnames(gg)[[1]] <- paste(1:nrow(gg))
+ggg <- gg[!duplicated(gg[,c("length", "threads")]),
+ c("length", "threads")]
+rownames(ggg) <- 1:nrow(ggg)
+for(i in 1:nrow(ggg)){
+ cat(i, "\n")
+ gc()
+ a <- numeric(2^ggg[i,"length"]-1)
+ omp_set_num_threads(ggg[i,"threads"])
+ gc()
+ mm <- mb(.C64("BENCHMARK", SIGNATURE = "int64", a = a,
+ INTENT = "rw", NAOK = TRUE, PACKAGE = "dotCall64",
+ VERBOSE = 0), times = times)
+ rm(a)
+ gc()
+ gg[gg$length == ggg[i,"length"] & gg$threads == ggg[i,"threads"], "res"] <- as.data.frame(mm)$time
+}
+
+gg$res <- gg$res / 1e9 # seconds
+ggg$res <- c(unlist(by(gg$res, gg[,c("length", "threads")], mean)))
+
+save(gg, ggg, file = "benchmark_openMP.RData")
+
+sessionInfo()
+system("head -n25 /proc/cpuinfo") # works on linux
diff --git a/benchmark/benchmark_openMP_figure.R b/benchmark/benchmark_openMP_figure.R
new file mode 100644
index 0000000000000000000000000000000000000000..bd27d1146baffcc9cde639a29af3a0fac9557dfc
--- /dev/null
+++ b/benchmark/benchmark_openMP_figure.R
@@ -0,0 +1,76 @@
+rm(list = ls(all = TRUE))
+require(RColorBrewer)
+require(scales)
+require(plyr)
+load("benchmark_openMP.RData")
+colo <- rev(brewer.pal(5, "Set1"))[-4]
+gg$col <- colo[((gg$length-min(gg$length)))/6 +1]
+
+mat <- array(ggg$res, c(4, 10))
+pch <- c(0, 1, 4, 5)
+pdf("benchmark_openMP.pdf", 4.3, 4)
+par(mai = c(.6, .97, 0.2, 0.2))
+plot(gg$threads, log(gg$res, 2), col = "white",
+ xaxt = "n", yaxt = "n",
+ xlab = "", ylab = "", pch = 1, cex= 1.2,
+ xlim = c(.9, 10.1))
+mtext("Number of threads", 1, 2)
+mtext("Elapsed time [s]", 2, 2.8)
+abline(v = seq(1, 9, 2), col = "gray90")
+# abline(v = seq(1, 9, 4), col = "gray80")
+abline(h = seq(-8,8,2), col = "gray90")
+# abline(h = seq(-8,8,4), col = "gray80")
+points(gg$threads, log(gg$res, 2), col = alpha(gg$col, .5),
+ pch = rep(pch, each = 5), cex = 1)
+matplot(t(log(mat, 2)), type = "l", col = colo, add = TRUE,
+ lty =1, lwd = 1.5)
+axis(1, at = seq(1, 12, 4))
+axis(2, at = seq(-8, 8, 4),
+ lab = expression(frac(1, 256), frac(1, 16), 1, 16, 256),
+ las = 2)
+box()
+dev.off()
+
+pdf("benchmark_openMP_legend.pdf", 9, 6)
+frame()
+legend(x=.3, y = 1,
+ legend = expression(2^34*phantom(A)~128~Gb,
+ 2^28*phantom(oorr)~2~Gb,
+ 2^22*phantom(Ao)~32~Mb,
+ 2^16*phantom(A)~512*phantom(ji)*Kb),
+ lty = 1, pch = pch, title.adj = 0,
+ col = rev(colo), title = "Vector length / size",
+ bg = "white", box.lwd=0, box.col="white", cex = 2.5, pt.cex = 3.5,
+ lwd = 3)
+dev.off()
+
+gg <- ddply(gg, c("length"), function(x){
+ mean0 <- rep(x[x$threads == 1, "res"], length(unique(x$threads)))
+ x$rel <- x$res / mean0
+ x
+})
+mat1 <- mat / array(mat[,1], dim = dim(mat))
+round(mat1[,10]*100)
+
+pdf("benchmark_openMP_relative.pdf", 4.3, 4)
+par(mai = c(.6, .97, 0.2, 0.2))
+plot(gg$threads, log(gg$rel, 2), col = "white",
+ xaxt = "n", yaxt = "n", xlim = c(.9, 10.1),
+ xlab = "", ylab = "", pch = 1, cex= 1)
+mtext("Number of threads", 1, 2)
+mtext("Relative elapsed time", 2, 3.6)
+abline(v = seq(1, 9, 2), col = "gray90")
+# abline(v = seq(1, 9, 4), col = "gray80")
+abline(h = seq(-1, 4, 0.5), col = "gray90")
+# abline(h = seq(-2, 4, 1), col = "gray90")
+abline(h = 0, col = "black", lty = 2)
+points(gg$threads, log(gg$rel, 2), col = alpha(gg$col, .5),
+ pch = rep(rev(pch), each = 50), cex = 1)
+matplot(log(t(mat1), 2), type = "l", col = colo, add = TRUE,
+ lty = 1, lwd = 1.5)
+axis(1, at = seq(1, 12, 4))
+axis(2, at = seq(-2, 4, 1),
+ lab = paste0(2**(seq(-2, 4, 1)) * 100, "%"),
+ las = 2)
+box()
+dev.off()
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000000000000000000000000000000000000..046385e42388fe87945e4fbb5872d758baa4257c
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,40 @@
+citHeader("To cite gapfill in publications use:")
+
+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 = "R journal",
+ year = "2016",
+ volume = "",
+ number = "",
+ pages = "",
+ url = "",
+ note = "submitted",
+
+ textVersion =
+ paste("F. Gerber, K. Moesinger, R. Furrer (2016),",
+ "\"dotCall64: An efficient interface to compiled C/C++ and Fortran code supporting long vectors\",",
+ "submitted to the R Journal.")
+)
+
+
+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 = "2015",
+ volume = "",
+ number = "",
+ pages = "",
+ url = "",
+ note = "submitted",
+
+ textVersion =
+ paste("F. Gerber, K. Moesinger, R. Furrer (2016),",
+ "\"Extending R packages to support 64-bit compiled code: An illustration with spam64 and GIMMS NDVI3g data\",",
+ "submitted to Computer & Geoscience.")
+)
diff --git a/inst/include/dotCall64.h b/inst/include/dotCall64.h
index 68ba6fed78b351f2ee70845fa9c5cb1fd3644c4a..c26bebd13b6adf7d6f82f64d864e00636a4e6df1 100644
--- a/inst/include/dotCall64.h
+++ b/inst/include/dotCall64.h
@@ -48,15 +48,16 @@
/*
* 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 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 flags If set to 1, then the function is verbose.
+ * \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
@@ -64,10 +65,10 @@
* against the garbage collector.
*
*/
-void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_intent, int flags);
+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) dotCall64(a,b,c,d,e,f)
+#define DOT_CALL64(a,b,c,d,e,f,g) dotCall64(a,b,c,d,e,f,g)
diff --git a/man/dotCall64.Rd b/man/dotCall64.Rd
index 00bfad9179c63dbc051b7dcc96e3e8228d7c56b5..001baf75488b54311d681081a64355ba8cb236ef 100644
--- a/man/dotCall64.Rd
+++ b/man/dotCall64.Rd
@@ -17,8 +17,7 @@ It accepts \code{"double"}, \code{"integer"}, \code{"int64"}.}
\item{...}{arguments to be passed to the foreign function. Up to 65.}
\item{INTENT}{a vector of type character. For each argument, the string indicates the intent of the function.
-The accepted values are \code{"r"}, \code{"w" }or \code{"rw"} for indicating read, write respectively read/write.
-Additionally, the modifiers speed \code{"s"} and copy \code{"c"} can be added.
+The accepted values are \code{"r"}, \code{"w"} or \code{"rw"} for indicating read, write respectively read/write.
If this argument is missing, it is assumed that all arguments are \code{"rw"}.
See details.}
@@ -47,13 +46,13 @@ DotCall64 prioritizes memory efficiency over speed.
If we have an argument of signature \code{int64_t} and intent \code{"r"},
then before calling the function, \code{dotCall64} casts the double array in place
(meaning it overwrites the memory of the double object) into \code{int64_t} and casts them back after the call, such that the original object is still readable.
-If the modifier speed is set, then instead of reusing the memory, it allocates new memory and casts the values into this new memory.
-After the call, it just discards the memory as there is no need to cast it back.
}
\section{Warning}{
If intent is set to \code{"w"}, then the function \emph{must not} assume that the elements are initialized to zero.
If this should be the case, use \code{"rw"} and pass a zero initialized vector.
+If intent is set to \code{"r"}, then the function \emph{must not} modify the corresponding argument.
+Because the corresponding argument is not copied and hence may have side effects on other R objects.
}
\examples{
\dontrun{
diff --git a/man/vector_dc.Rd b/man/vector_dc.Rd
index 73df0705a38ec91b98aac2eaa098a9e05b4336ea..cd5a0de68e362a7d43379f8715f5a4d560cb6a69 100644
--- a/man/vector_dc.Rd
+++ b/man/vector_dc.Rd
@@ -1,12 +1,26 @@
% Generated by roxygen2 (4.1.1): do not edit by hand
% Please edit documentation in R/vector_dc.R
\name{vector_dc}
+\alias{integer_dc}
+\alias{numeric_dc}
\alias{vector_dc}
-\title{dfg}
+\title{Allocate vectors in dotCall64}
\usage{
-vector_dc(mode = "logical", length = 0)
+vector_dc(mode = "logical", length = 0L)
+
+numeric_dc(length = 0)
+
+integer_dc(length = 0)
+}
+\arguments{
+\item{mode}{Character. Storage mode of the created vector.}
+
+\item{length}{Integer of length 1. The length of the created vector.}
+}
+\value{
+Obect of class vector_dc and list.
}
\description{
-dfg
+Allocate vectors in dotCall64
}
diff --git a/src/Makevars b/src/Makevars
index 4036fa4f6b1bd10e3c2d07eda26f9857ec158da1..6ba17c064957dbab9060d3e58bfa4a88faa1bb12 100644
--- a/src/Makevars
+++ b/src/Makevars
@@ -1,5 +1,7 @@
# C-Flags
-PKG_CFLAGS = -I../inst/include/ -DDOTCAL64_PRIVATE
-PKG_LIBS =
+# PKG_CFLAGS = -I../inst/include/ -DDOTCAL64_PRIVATE
+# PKG_LIBS =
+PKG_CFLAGS = $(SHLIB_OPENMP_CFLAGS) -I../inst/include/ -DDOTCAL64_PRIVATE
+PKG_LIBS = $(SHLIB_OPENMP_CFLAGS)
diff --git a/src/dotCall64.c b/src/dotCall64.c
index 9a69973ee1a8128cff853ba9c440f751b5e3b0b0..fe49354de8d086cc32d34c44d1e787a8ec39655c 100644
--- a/src/dotCall64.c
+++ b/src/dotCall64.c
@@ -1,4 +1,3 @@
-
#include "dotCall64.h"
// MAYBE_SHARED is not available in R 3.0.1
@@ -12,8 +11,7 @@
/* See http://cran.r-project.org/doc/manuals/R-exts.html#C_002dlevel-messages */
#ifdef ENABLE_NLS
#include <libintl.h>
-#define _(String) dgettext ("pkg", String)
-/* replace pkg as appropriate */
+#define _(String) dgettext ("dotCall64", String)
#else
#define _(String) (String)
#endif
@@ -35,10 +33,10 @@
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);
+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 *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);
@@ -50,12 +48,8 @@ static SEXP allocInitializedVector(int type, R_xlen_t length);
static SEXP PkgSymbol = NULL;
static SEXP SignatureSymbol = NULL;
static SEXP IntentSymbol = NULL;
-
-
-
-void test() {
-
-}
+static SEXP NaokSymbol = NULL;
+static SEXP VerboseSymbol = NULL;
int str2intent(SEXP str) {
@@ -63,13 +57,13 @@ int str2intent(SEXP str) {
const char *p = CHAR(str);
int x = 0; // Clear any bits
- for(int i=0; i<strlen(p);i++) {
+ for(int i=0; i<strlen(p); i++) {
switch(p[i]) {
case('r'): x |= INTENT_READ; break;
case('w'): x |= INTENT_WRITE; break;
// case('c'): x |= INTENT_COPY; break; // disabled
// case('s'): x |= INTENT_SPEED; break;
- default: error("Unknown intent '%c'", p[i]);
+ default: error(_("unknown intent '%c'"), p[i]);
}
}
return x;
@@ -80,13 +74,12 @@ int str2intent(SEXP str) {
SEXP dC64(SEXP args_in) {
- SEXP s, signature, intent, answer;
- int na;
+ SEXP s, signature, intent, naok, verbose, answer;
+ int na, flag_naok, flag_verbose;
const char *p;
- Rboolean verbose_messages = 0;
-
DL_FUNC fun = NULL;
+
// Contains the number of arguments to be passed.
int nargs;
// Contains the name of the function
@@ -99,40 +92,45 @@ SEXP dC64(SEXP args_in) {
int n_protect = 0; // counts the number of times that PROTECT has been called.
- // Check if we should be verbose:
- s = GetOption1(install("dotCall64.verbose"));
- if(s && length(s)) {
- verbose_messages = asLogical(s);
- }
-
-
// The first argument contains the value "dotCall64", as it is the first argument given to .External(...).
args_in = CDR(args_in);
// Check if the required first argument .NAME is available:
if (length(args_in) < 1)
- error(_("'.NAME' is missing"));
+ error(_("argument '.NAME' is missing (dotCall64)"));
if (TAG(args_in) != R_NilValue) {
if(TAG(args_in) != install("name")) {
- error(_("The first argument should have name 'name' or should not be named. (dotCall64) "));
+ error(_("the argument '.NAME' should have name \"name\" or should not be named (dotCall64)"));
}
}
-
// Copy the symbol Name:
p = translateChar(STRING_ELT(CAR(args_in), 0));
if(strlen(p) > PATH_MAX - 1)
- error(_(".NAME is too long"));
+ 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);
+ argsfind(args_in, args, args_names, &nargs, packageName, &signature, &intent, &naok, &verbose);
// We don't need to PROTECT args and args_names, because they are protected by being a subobject of args_in.
+ // Check the NAOK argument
+ if(LENGTH(naok) != 1)
+ error(_("argument 'NAOK' has to be of length 1 (dotCall64)"));
+ flag_naok = asInteger(naok);
+
+
+ // Check the VERBOSE argument
+ if(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) {
@@ -143,28 +141,23 @@ SEXP dC64(SEXP args_in) {
fun = R_FindSymbol(symName, packageName, NULL);
if(!fun)
- error(_("Symbol '%s' not found in package '%s'."), symName, packageName);
+ 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 private API.
-
-
-
- // Any argument given as list must be expanded to the correct type
+ // Any argument of class "vector_dc" must be expanded to the correct type
for(na = 0; na < nargs; na++) {
s = args[na];
-
- if(isNewList(s)) {
+ 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"));
-
-// Rprintf("Replace argument %d: %s - %d, len:%d\n", na, CHAR(STRING_ELT(getListElement(s, "mode"), 0)), type, len);
-
+ 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++;
}
@@ -177,32 +170,29 @@ SEXP dC64(SEXP args_in) {
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("SIGNATURE is missing.");
+ error(_("argument 'SIGNATURE' is missing (dotCall64)"));
}
if(LENGTH(signature) != nargs)
- error(_("Length of SIGNATURE does not equal to the number of arguments."));
+ 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)."), na +1, CHAR(STRING_ELT(signature, na)));
-
+ 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 INTENT does not equal to the number of arguments."));
+ error(_("length of argument 'INTENT' does not equal to the number of arguments (dotCall64)"));
for(na = 0; na < LENGTH(intent); na++) {
switch(TYPEOF(intent)) {
@@ -212,7 +202,6 @@ SEXP dC64(SEXP args_in) {
args_intent[na] = str2intent(STRING_ELT(intent, na));
}
break;
-
}
}
}
@@ -236,19 +225,10 @@ SEXP dC64(SEXP args_in) {
}
-
// Finally, call the function
- dotCall64(fun, nargs, sexpargs, args_type, args_intent, verbose_messages);
+ dotCall64(fun, nargs, sexpargs, args_type, args_intent, flag_naok, flag_verbose);
-#ifdef TEST_FLOWCHART
- // Force the first 6 arguments to have INTENT_WRITE, such that they are returned
- nargs = 6;
- for (na = 0 ; na < nargs; na++) {
- args_intent[na] = INTENT_WRITE;
- }
-#endif
-
// First, protect every 'write' argument returned by dotCall64
for (na = 0 ; na < nargs; na++) {
if(!HAS_INTENT_WRITE(args_intent[na]))
@@ -258,20 +238,6 @@ SEXP dC64(SEXP args_in) {
n_protect++;
}
-#ifdef TEST_FLOWCHART
-
- PROTECT(names = allocVector(STRSXP, nargs));
- n_protect++;
- SET_STRING_ELT(names, 0, CREATE_STRING_VECTOR("type"));
- SET_STRING_ELT(names, 1, CREATE_STRING_VECTOR("alloc"));
- SET_STRING_ELT(names, 2, CREATE_STRING_VECTOR("coerce"));
- SET_STRING_ELT(names, 3, CREATE_STRING_VECTOR("duplicate"));
- SET_STRING_ELT(names, 4, CREATE_STRING_VECTOR("cast.in"));
- SET_STRING_ELT(names, 5, CREATE_STRING_VECTOR("cast.back"));
-
-#endif
-
-
PROTECT(answer = allocVector(VECSXP, nargs));
n_protect++;
@@ -290,16 +256,14 @@ SEXP dC64(SEXP args_in) {
SET_VECTOR_ELT(answer, na, sexpargs[na]);
}
-
UNPROTECT(n_protect);
return(answer);
}
-void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_intent_in, int flags) {
- int na;
- int verbose_messages = flags & 1; // Flags might contain more options in future. (31-bits left).
+void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_intent_in, int flag_naok, int flag_verbose) {
+ int na;
// The do_ variables contain the instructions that will applied by the function 'prepareArguments(...)'.
SEXPTYPE do_type[MAX_ARGS]; //
int do_alloc[MAX_ARGS]; //
@@ -307,15 +271,10 @@ void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_int
int do_duplicate[MAX_ARGS];
int do_cast_in[MAX_ARGS];
int do_cast_back[MAX_ARGS];
-
int args_intent[MAX_ARGS]; // We duplicate args_intent_in, as we have to modify it if an argument is given multiple times
-
-
if(nargs > MAX_ARGS)
- error("dotCall64 only supports up to 64 arguments.");
-
-
+ 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 it's INTENT is write.
@@ -352,29 +311,6 @@ void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_int
int maybe_shared = MAYBE_SHARED(s); // Unused
-#ifdef DEBUG
- {
- // TODO: Write about it
- // Allows to overwrite the named state of the arguments
- SEXP debug_option = GetOption1(install("dotCall64.debug.named"));
- if(debug_option != R_NilValue) {
- if(TYPEOF(debug_option) == INTSXP && length(debug_option)==nargs) {
- int state = INTEGER(debug_option)[na];
-
- // If the element is set to NA, we don't overwrite the named state of this argument.
- if(state != NA_INTEGER) {
- maybe_referenced = state > 0;
- maybe_shared = (state == 2);
- }
- }else{
- error("dotCall64-Debug: dotCall64.debug.named not of type integer or length \
- does not equal the number of arguments.");
- }
- }
- }
-#endif
-
-
// First, determine the expected R type of the object
if(args_type[na] == INT64_TYPE) {
// int64 is based on the double type
@@ -384,9 +320,8 @@ void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_int
}
// Check if we should raise a warning, because we didn't get the expected type:
- // TODO: Write about the min length for the warning
- if(verbose_messages && TYPEOF(s)!=do_type[na] && XLENGTH(s) > 1000) {
- warning(_("Expected argument %d to be of type '%s' but got '%s': Coerce it."),
+ 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))));
}
@@ -394,12 +329,15 @@ void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_int
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) {
+ 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:
- do_alloc[na] = 1;
+ 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:
@@ -424,11 +362,9 @@ void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_int
do_cast_back[na] = 1;
}
-
}else{
// Center part of the flowchart
// argument of native type:
-
if(TYPEOF(s)!=do_type[na]) {
// Well, we got the wrong type:
do_coerce[na] = 1;
@@ -438,68 +374,23 @@ void dotCall64(DL_FUNC fun, int nargs, SEXP *args, int *args_type, int *args_int
}
}
-
-#ifdef DEBUG
- {
- // Print the parser result:
- SEXP debug_option = GetOption1(install("dotCall64.debug.print.do.vars"));
- if(debug_option != R_NilValue) {
- if(asInteger(debug_option) == 1) {
- Rprintf("arg %d: type %s (%d) - alloc %d - coerce %d - dup %d - cast.in %d - cast.back %d (named: %d, mb-ref: %d, mb-shared: %d)\n",
- na, 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
- );
-
- }
- }
+ 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);
}
-#endif
-
-
}
-#ifndef TEST_FLOWCHART
prepareArguments(fun, nargs, args,
do_type, do_alloc, do_coerce,
- do_duplicate, do_cast_in, do_cast_back);
-#else
-
- // DIY dependency injection:
- // return the do_ variables to check them.
-
- args[0] = PROTECT(allocVector(INTSXP, nargs));
- for(na = 0; na < nargs; na++)
- INTEGER(args[0])[na] = do_type[na];
-
- args[1] = PROTECT(allocVector(INTSXP, nargs));
- for(na = 0; na < nargs; na++)
- INTEGER(args[1])[na] = do_alloc[na];
-
- args[2] = PROTECT(allocVector(INTSXP, nargs));
- for(na = 0; na < nargs; na++)
- INTEGER(args[2])[na] = do_coerce[na];
-
- args[3] = PROTECT(allocVector(INTSXP, nargs));
- for(na = 0; na < nargs; na++)
- INTEGER(args[3])[na] = do_duplicate[na];
-
- args[4] = PROTECT(allocVector(INTSXP, nargs));
- for(na = 0; na < nargs; na++)
- INTEGER(args[4])[na] = do_cast_in[na];
-
- args[5] = PROTECT(allocVector(INTSXP, nargs));
- for(na = 0; na < nargs; na++)
- INTEGER(args[5])[na] = do_cast_back[na];
-
- UNPROTECT(6);
-#endif
+ 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 *do_duplicate, int *do_cast_in, int *do_cast_back, int *flag_naok) {
int na;
void **cargs[MAX_ARGS]; // pointers for the actual function
@@ -529,6 +420,28 @@ static void prepareArguments(DL_FUNC fun, int nargs, SEXP *args,
// 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)) {
@@ -546,8 +459,7 @@ static void prepareArguments(DL_FUNC fun, int nargs, SEXP *args,
break;
default:
- error(_("Cannot (yet) handle type '%s' (arg %d)"), type2char(TYPEOF(s)), na + 1);
-
+ error(_("cannot yet handle type '%s' (arg %d) (dotCall64)"), type2char(TYPEOF(s)), na + 1);
}
}
@@ -558,6 +470,7 @@ static void prepareArguments(DL_FUNC fun, int nargs, SEXP *args,
for(na = 0; na < nargs; na++) {
SEXP s = args[na];
+
// double -> int64_t
if(do_cast_in[na]) {
R_xlen_t i, len;
@@ -586,7 +499,7 @@ static void prepareArguments(DL_FUNC fun, int nargs, SEXP *args,
}
}else{
// We should never get here.
- error("dotCall64: Internal error (do_cast_in).");
+ error(_("should not happen: internal error (do_cast_in) (dotCall64)"));
}
}
}
@@ -624,10 +537,10 @@ static void prepareArguments(DL_FUNC fun, int nargs, SEXP *args,
// 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)
+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;
+ int nargs=0, pkgused=0, sigused=0, intused=0, naokused=0, verbused=0;
const char *p;
// Attribute containing the
@@ -635,6 +548,8 @@ static void argsfind(SEXP args_in, SEXP *args, SEXP *names,int *len, char *packa
PkgSymbol = install("f.PACKAGE");
SignatureSymbol = install("SIGNATURE");
IntentSymbol = install("INTENT");
+ NaokSymbol = install("NAOK");
+ VerboseSymbol = install("VERBOSE");
}
// Initialize it to an empty string
@@ -648,21 +563,21 @@ static void argsfind(SEXP args_in, SEXP *args, SEXP *names,int *len, char *packa
if(TYPEOF(CAR(s)) == STRSXP) {
p = translateChar(STRING_ELT(CAR(s), 0));
if(strlen(p) > PATH_MAX - 1)
- error(_("DLL name is too long"));
+ error(_("DLL name is too long (dotCall64)"));
strcpy(packageName, p);
if(pkgused++ > 0)
- warning(_("'%s' used more than once"), "PACKAGE");
+ error(_("formal argument '%s' matched by multiple actual arguments (dotCall64)"), "PACKAGE");
} else {
- error("incorrect type (%s) of PACKAGE argument\n",
+ 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)
- warning(_("'%s' used more than once"), "SIGNATURE");
+ error(_("formal argument '%s' matched by multiple actual arguments (dotCall64)"), "SIGNATURE");
} else {
- error("incorrect type (%s) of SIGNATURE argument\n",
+ error(_("formal argument 'SIGNATURE' has wrong type (\"%s\"). Expected type: \"character\" (dotCall64)"),
type2char(TYPEOF(CAR(s))));
}
} else if(TAG(s) == IntentSymbol) {
@@ -670,14 +585,32 @@ static void argsfind(SEXP args_in, SEXP *args, SEXP *names,int *len, char *packa
case STRSXP:
*intent = CAR(s);
if(intused++ > 0)
- warning(_("'%s' used more than once"), "INTENT");
+ error(_("formal argument '%s' matched by multiple actual arguments (dotCall64)"), "INTENT");
break;
case NILSXP:
// behave as if no argument was given
break;
default:
- error("incorrect type (%s) of INTENT argument\n",
+ 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 {
@@ -726,28 +659,17 @@ static int dotCall64str2type(SEXP s) {
static SEXP allocInitializedVector(int type, R_xlen_t length) {
SEXP s = PROTECT(allocVector(type, length));
- R_xlen_t i;
switch(TYPEOF(s)) {
case REALSXP:
- for(i = 0; i<length(s); i++) {
- REAL(s)[i] = 0;
- }
+ Memzero(REAL(s), length);
break;
-
- case LGLSXP:
case INTSXP:
- for(i = 0; i<length(s); i++) {
- INTEGER(s)[i] = 0;
- }
+ Memzero(INTEGER(s), length);
break;
-
default:
- error("Type %s not yet supported by allocInitializedVector", type2char(TYPEOF(s)));
+ error("type \"%s\" not yet supported by allocInitializedVector (dotCall64)", type2char(TYPEOF(s)));
}
UNPROTECT(1);
return s;
}
-
-
-
diff --git a/src/testfunctions_c.c b/src/testfunctions_c.c
new file mode 100644
index 0000000000000000000000000000000000000000..1347d07dd0df1a1dd9e8cc8ae721e0dc77f76e5c
--- /dev/null
+++ b/src/testfunctions_c.c
@@ -0,0 +1,38 @@
+# include <stdint.h>
+
+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];
+}
+
+
+
diff --git a/src/testfunctions_f.f b/src/testfunctions_f.f
new file mode 100644
index 0000000000000000000000000000000000000000..88d9f860475065edc2c1b75cb896eab2ea49ed60
--- /dev/null
+++ b/src/testfunctions_f.f
@@ -0,0 +1,12 @@
+ 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
+
diff --git a/tests/run-all.R b/tests/run-all.R
new file mode 100644
index 0000000000000000000000000000000000000000..486102101b84f999068a86f3869d68d41980e667
--- /dev/null
+++ b/tests/run-all.R
@@ -0,0 +1,2 @@
+library(testthat)
+test_check('dotCall64')
diff --git a/tests/testthat/test-againstDotC.R b/tests/testthat/test-againstDotC.R
new file mode 100644
index 0000000000000000000000000000000000000000..f26a81793d1ba284c8361fc17ee4b1905377486a
--- /dev/null
+++ b/tests/testthat/test-againstDotC.R
@@ -0,0 +1,54 @@
+context("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)
+})
diff --git a/tests/testthat/test-flow-center.R b/tests/testthat/test-flow-center.R
new file mode 100644
index 0000000000000000000000000000000000000000..91f4baee7c51567f403245ecd2e7bd31ce6b8d11
--- /dev/null
+++ b/tests/testthat/test-flow-center.R
@@ -0,0 +1,181 @@
+context("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")
+})
diff --git a/tests/testthat/test-flow-left.R b/tests/testthat/test-flow-left.R
new file mode 100644
index 0000000000000000000000000000000000000000..5d0b0388a9b4c165817e51151a391f52b3adb669
--- /dev/null
+++ b/tests/testthat/test-flow-left.R
@@ -0,0 +1,137 @@
+context("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")
+
+})
+
+
+
+
+
+
+
diff --git a/tests/testthat/test-flow-right.R b/tests/testthat/test-flow-right.R
new file mode 100644
index 0000000000000000000000000000000000000000..3715ae3151c980c5a4236c3ec19075c4eef69d73
--- /dev/null
+++ b/tests/testthat/test-flow-right.R
@@ -0,0 +1,97 @@
+context("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)
+ }
+})
+}
+
diff --git a/tests/testthat/test-long_int64.R b/tests/testthat/test-long_int64.R
new file mode 100644
index 0000000000000000000000000000000000000000..4fe0bbb0d8c1dae4021631c79b9f52107f063fc5
--- /dev/null
+++ b/tests/testthat/test-long_int64.R
@@ -0,0 +1,15 @@
+library(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)
+})
diff --git a/tests/testthat/test-vector_dc.R b/tests/testthat/test-vector_dc.R
new file mode 100644
index 0000000000000000000000000000000000000000..4162a35ca1e0d6067e45491d10a170235a625334
--- /dev/null
+++ b/tests/testthat/test-vector_dc.R
@@ -0,0 +1,105 @@
+context("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]")
+})
+
+
+
+
+