[r-cran-dotcall64] 01/02: New upstream version 0.9-04
Andreas Tille
tille at debian.org
Thu Sep 7 20:28:38 UTC 2017
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository r-cran-dotcall64.
commit 60c619d5f19895135ebab3333361822cb1a86250
Author: Andreas Tille <tille at debian.org>
Date: Thu Sep 7 22:21:27 2017 +0200
New upstream version 0.9-04
---
DESCRIPTION | 26 ++
MD5 | 22 ++
NAMESPACE | 7 +
NEWS.md | 3 +
R/dotCall64.R | 123 +++++++
R/vector_dc.R | 34 ++
R/zzz.R | 5 +
inst/CITATION | 40 +++
inst/include/dotCall64.h | 80 +++++
man/dotCall64.Rd | 133 ++++++++
man/vector_dc.Rd | 35 ++
src/Makevars | 7 +
src/dotCall64.c | 677 ++++++++++++++++++++++++++++++++++++++
src/dotCall64helpers.c | 619 ++++++++++++++++++++++++++++++++++
src/testfunctions_c.c | 38 +++
src/testfunctions_f.f | 12 +
tests/run-all.R | 2 +
tests/testthat/test-againstDotC.R | 54 +++
tests/testthat/test-flow-center.R | 181 ++++++++++
tests/testthat/test-flow-left.R | 137 ++++++++
tests/testthat/test-flow-right.R | 97 ++++++
tests/testthat/test-long_int64.R | 15 +
tests/testthat/test-vector_dc.R | 105 ++++++
23 files changed, 2452 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..90e32f5
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,26 @@
+Package: dotCall64
+Type: Package
+Title: Enhanced Foreign Function Interface Supporting Long Vectors
+Version: 0.9-04
+Date: 2016-10-03
+Authors at R: c(person("Kaspar", "Moesinger", role = c("aut", "cre"),
+ email = "kaspar.moesinger at gmail.com"),
+ person("Florian", "Gerber", role = "ctb",
+ email = "florian.gerber at math.uzh.ch"),
+ person("Reinhard", "Furrer", role = "ctb",
+ email = "reinhard.furrer at math.uzh.ch"))
+Author: Kaspar Moesinger [aut, cre], Florian Gerber [ctb], Reinhard Furrer [ctb]
+Maintainer: Kaspar Moesinger <kaspar.moesinger at gmail.com>
+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)
+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'
+NeedsCompilation: yes
+Packaged: 2016-10-06 20:49:44 UTC; moe
+Repository: CRAN
+Date/Publication: 2016-10-07 09:19:26
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..ec4b9d7
--- /dev/null
+++ b/MD5
@@ -0,0 +1,22 @@
+bb9658cd9b919b602b6dd780117de4e6 *DESCRIPTION
+5ecae9e999f7d9a791dda6059ff99459 *NAMESPACE
+d63df473072cc85e7ad20d472e48114f *NEWS.md
+348f28da309d88d4df9cf7b7510c6c07 *R/dotCall64.R
+a0f4b3a03d134e8516714968c6cdb5f8 *R/vector_dc.R
+6ce69e2ecaa6aafccc57181a7bc52836 *R/zzz.R
+925c93f8b7afa048eafb1f2296f52a25 *inst/CITATION
+065858e22b509b800788b11a16c24469 *inst/include/dotCall64.h
+024bc9e50267a3e99b47ce54358cd22f *man/dotCall64.Rd
+fa197f82b993deebe4441b037fc8c5bc *man/vector_dc.Rd
+356b809b916a94506bcdde171e6e4cfc *src/Makevars
+542435e461765df5e414b5d94885f122 *src/dotCall64.c
+20ff6f909591b7aed0035f7fd7c2e684 *src/dotCall64helpers.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
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..e9c15bc
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,7 @@
+# Generated by roxygen2 (4.1.1): do not edit by hand
+
+export(.C64)
+export(integer_dc)
+export(numeric_dc)
+export(vector_dc)
+useDynLib(dotCall64)
diff --git a/NEWS.md b/NEWS.md
new file mode 100644
index 0000000..17a16a6
--- /dev/null
+++ b/NEWS.md
@@ -0,0 +1,3 @@
+# dotCall64 0.9-04
+
+* CRAN release.
\ No newline at end of file
diff --git a/R/dotCall64.R b/R/dotCall64.R
new file mode 100644
index 0000000..7c054d4
--- /dev/null
+++ b/R/dotCall64.R
@@ -0,0 +1,123 @@
+#' dotCall64 - Extended Foreign Function Interface
+#'
+#' \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, 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 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.
+#' }
+#' 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{
+#' ## '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, NAOK = FALSE,
+ PACKAGE = "", VERBOSE = getOption("dotCall64.verbose")) {
+ .External("dC64", name = .NAME, SIGNATURE = SIGNATURE, ..., INTENT = INTENT, NAOK = NAOK,
+ f.PACKAGE = PACKAGE, VERBOSE = VERBOSE, PACKAGE = "dotCall64")
+ }
+
diff --git a/R/vector_dc.R b/R/vector_dc.R
new file mode 100644
index 0000000..77c2e92
--- /dev/null
+++ b/R/vector_dc.R
@@ -0,0 +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)
+
+#' @name integer_dc
+#' @rdname vector_dc
+#' @export
+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 0000000..377f9df
--- /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/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000..046385e
--- /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
new file mode 100644
index 0000000..27085c9
--- /dev/null
+++ b/inst/include/dotCall64.h
@@ -0,0 +1,80 @@
+#ifndef DOTCALL64_H
+#define DOTCALL64_H
+
+#include <R.h>
+#include <Rdefines.h>
+
+// Defines DL_FUNC.
+#include <R_ext/Rdynload.h>
+
+// Defines INTSXP and REALSXP to be used in the args_type array.
+#include<Rinternals.h>
+
+// Defines int64_t on windows
+#include <stdint.h>
+
+/*
+ * Because R does not define an int64 type, this pseudo type should be used to
+ * indicate an int64_t argument type:
+ * Currently, R only uses 4 bits for it's 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"
+
+
+/*
+ * TODO: Maybe, this should be defined as an enum?
+ */
+#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 may have:
+#define MAX_ARGS 65
+
+#endif
diff --git a/man/dotCall64.Rd b/man/dotCall64.Rd
new file mode 100644
index 0000000..5e337b9
--- /dev/null
+++ b/man/dotCall64.Rd
@@ -0,0 +1,133 @@
+% Generated by roxygen2 (4.1.1): do not edit by hand
+% Please edit documentation in R/dotCall64.R
+\name{dotCall64}
+\alias{.C64}
+\alias{dotCall64}
+\title{dotCall64 - Extended Foreign Function Interface}
+\usage{
+.C64(.NAME, SIGNATURE, ..., INTENT = NULL, NAOK = FALSE, PACKAGE = "",
+ VERBOSE = getOption("dotCall64.verbose"))
+}
+\arguments{
+\item{.NAME}{a character vector of length 1. Specifies the name of the compiled function to be called.}
+
+\item{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.}
+
+\item{...}{arguments passed to the compiled function. One R object for each argument. Up to 65 arguments are supported.}
+
+\item{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"}.}
+
+\item{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.}
+
+\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 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.}
+}
+\value{
+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.
+}
+\description{
+\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, 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 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.
+}
+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.
+}
+\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{
+## '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
+
+}
+}
+\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.
+}
+
diff --git a/man/vector_dc.Rd b/man/vector_dc.Rd
new file mode 100644
index 0000000..9d40c4c
--- /dev/null
+++ b/man/vector_dc.Rd
@@ -0,0 +1,35 @@
+% 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{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 to allocate.}
+
+\item{length}{Numeric vector of length 1. Length of the vector to allocate.}
+}
+\value{
+Object of class \code{vector_dc} and \code{list}.
+}
+\description{
+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.
+}
+\examples{
+vector_dc("integer", 20)
+}
+
diff --git a/src/Makevars b/src/Makevars
new file mode 100644
index 0000000..6ba17c0
--- /dev/null
+++ b/src/Makevars
@@ -0,0 +1,7 @@
+
+
+# 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)
diff --git a/src/dotCall64.c b/src/dotCall64.c
new file mode 100644
index 0000000..445fddd
--- /dev/null
+++ b/src/dotCall64.c
@@ -0,0 +1,677 @@
+#include "dotCall64.h"
+
+// MAYBE_SHARED is not available in R 3.0.1
+// TODO: find out when introduced
+#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 <libintl.h>
+#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
+
+
+
+/* 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<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]);
+ }
+ }
+ return x;
+}
+
+
+
+
+SEXP dC64(SEXP args_in) {
+
+ SEXP s, signature, intent, naok, verbose, answer;
+ int na, flag_naok, flag_verbose;
+ const char *p;
+
+ DL_FUNC fun = NULL;
+
+ // Contains the number of arguments to be passed.
+ int nargs;
+ // Contains the name of the function
+ char symName[MaxSymbolBytes];
+ // Contains the name of the package defining the function
+ char packageName[PATH_MAX];
+
+ SEXP args[MAX_ARGS];
+ SEXP args_names[MAX_ARGS];
+
+ int n_protect = 0; // counts the number of times that PROTECT has been called.
+
+ // 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(_("argument '.NAME' is missing (dotCall64)"));
+ if (TAG(args_in) != R_NilValue) {
+ if(TAG(args_in) != install("name")) {
+ 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(_("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 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(!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 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 type of the vectors, as they represent the default type:
+ 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 were 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]));
+ }
+ }
+
+
+ // Finally, call the function
+ dotCall64(fun, nargs, sexpargs, args_type, args_intent, flag_naok, flag_verbose);
+
+
+ // First, 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<nargs; na++) {
+ if(!HAS_INTENT_WRITE(args_intent[na])) {
+ // Only write-arguments are returned
+ SET_VECTOR_ELT(answer, na, R_NilValue);
+ continue;
+ }
+ 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 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]; //
+ int do_coerce[MAX_ARGS];
+ 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 (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.
+ // If the type is of 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_<XXX> 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
+
+
+ // First, 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 we should raise a warning, because we didn't get 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 with the 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]) {
+ // Well, we got the 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 arguments given
+
+ int n_protect = 0; // contains the number of times that PROTECT has been called.
+
+ // Copy the the argument: Used 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 we coerce, we pretend that we were given that object
+ }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);
+ }
+ }
+
+
+ // We do coerce any argument of type int64 (from double -> int64_t).
+ // We cannot do this earlier. We might overwrite the memory of the object and so 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, as this can happen in spam.
+ 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++) {
+ // TODO: Check if value is too high -> raise warning
+ 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++) {
+ // TODO: Check if value is too high -> raise warning
+ iptr[i] = (int64_t) in_ptr[i];
+ }
+ }else{
+ // We should never get here.
+ error(_("should not happen: internal error (do_cast_in) (dotCall64)"));
+ }
+ }
+ }
+
+ // Finally, call the function
+ dotCall64_callFunction(fun, nargs, (void**)cargs);
+
+
+ // The values of every argument of type int64 has to be cast back:
+ 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++) {
+// TODO: If value cannot be cast precisely -> raise warning
+// if(iptr[i] > R_XLEN_T_MAX && ((int64_t)((double)iptr[i])) - iptr[i] != 0 )
+// warning(_("Element %d of argument %d cannot be cast from int64_t to double precisely (difference %d)."),
+// i+1, na+1, ((int64_t)((double)iptr[i])) - iptr[i]);
+ 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 it 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;
+
+ // just for convenience:
+ }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;
+}
diff --git a/src/dotCall64helpers.c b/src/dotCall64helpers.c
new file mode 100644
index 0000000..8b329c5
--- /dev/null
+++ b/src/dotCall64helpers.c
@@ -0,0 +1,619 @@
+#include<R.h>
+#include<Rinternals.h>
+#include<R_ext/Rdynload.h>
+#include<stdio.h>
+
+
+/* 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 */
+#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"));
+ }
+}
diff --git a/src/testfunctions_c.c b/src/testfunctions_c.c
new file mode 100644
index 0000000..1347d07
--- /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 0000000..88d9f86
--- /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 0000000..4861021
--- /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 0000000..f26a817
--- /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 0000000..91f4bae
--- /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 0000000..5d0b038
--- /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 0000000..3715ae3
--- /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 0000000..4fe0bbb
--- /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 0000000..4162a35
--- /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]")
+})
+
+
+
+
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-science/packages/r-cran-dotcall64.git
More information about the debian-science-commits
mailing list