inline/0000755000176200001440000000000014055120342011524 5ustar liggesusersinline/NAMESPACE0000644000176200001440000000047314050553151012752 0ustar liggesusersimport("methods") importFrom("utils", "package.skeleton", "tail") export( "cfunction", "cxxfunction", "getPlugin", "readCFunc", "registerPlugin", "rcpp", "writeCFunc" ) exportMethods( "setCMethod", "getDynLib", "package.skeleton", "moveDLL", "print", "code" ) inline/README.md0000644000176200001440000000400713760473076013025 0ustar liggesusers## inline: Inline C, C++ and Fortran code from R [![Build Status](https://travis-ci.org/eddelbuettel/inline.png)](https://travis-ci.org/eddelbuettel/inline) [![Build Status](https://github.com/eddelbuettel/inline/workflows/ci/badge.svg)](https://github.com/eddelbuettel/inline/actions?query=workflow%3Aci) [![License](https://img.shields.io/badge/license-LGPL%20%28%3E%3D%202%29-brightgreen)](https://www.gnu.org/licenses/lgpl-3.0.html) [![CRAN](https://www.r-pkg.org/badges/version/inline)](https://cran.r-project.org/package=inline) [![CRAN use](https://jangorecki.gitlab.io/rdeps/inline/CRAN_usage.svg?sanitize=true)](https://cran.r-project.org/package=inline) [![CRAN indirect](https://jangorecki.gitlab.io/rdeps/inline/indirect_usage.svg?sanitize=true)](https://cran.r-project.org/package=inline) [![Dependencies](https://tinyverse.netlify.com/badge/inline)](https://cran.r-project.org/package=inline) [![Downloads](https://cranlogs.r-pkg.org/badges/inline?color=brightgreen)](https://www.r-pkg.org/pkg/inline) [![Debian package](https://img.shields.io/debian/v/r-cran-inline/sid?color=brightgreen)](https://packages.debian.org/sid/r-cran-inline) [![Last Commit](https://img.shields.io/github/last-commit/eddelbuettel/inline)](https://github.com/eddelbuettel/inline) ### About The inline package provides functionality to dynamically define R functions (and corresponding S4 objects) from in-line C, C++ or Fortran code. It supports the `.C`, `.Call` and `.Fortran` calling conventions. ### History The package was originally written while Oleg Sklyar was at [EMBL-EBI](https://www.ebi.ac.uk/). It was then extended by Dirk Eddelbuettel and Romain Francois for use by [Rcpp](https://dirk.eddelbuettel.com/code/rcpp.html). Years later, Karline Soetaert added support for Fortran. Johannes Ranke refactored some internals and added the ability to store and retrieve compiled code. ### Authors Oleg Sklyar, Dirk Eddelbuettel, Romain Francois, Karline Soetaert, Johannes Ranke ### Maintainer Dirk Eddelbuettel ### License LGPL (>= 2) inline/man/0000755000176200001440000000000014050723531012303 5ustar liggesusersinline/man/getDynLib.Rd0000644000176200001440000000241112377726054014466 0ustar liggesusers\name{getDynLib-methods} \docType{methods} \alias{getDynLib} \alias{getDynLib-methods} \alias{getDynLib,CFunc-method} \alias{getDynLib,character-method} \alias{getDynLib,CFuncList-method} \title{Retrieve the dynamic library (or DLL) associated with a package of a function generated by cfunction} \description{ The \code{getDynLib} function retrieves the dynamic library (or DLL) associated with a package or with a function generated by \code{\link{cfunction}} } \section{Methods}{ \describe{ \item{\code{signature(x = "CFunc")}}{Retrieves the dynamic library associated with the function generated by \code{\link{cfunction}}. The library is dynamically loaded if necessary. } \item{\code{signature(x = "CFuncList")}}{Retrieves the dynamic library associated with a set of functions generated by \code{\link{cfunction}}. The library is dynamically loaded if necessary. } \item{\code{signature(x = "character")}}{ Retrieves the dynamic library of the given name. This typically refers to package names, but can be any name of the list returned by \code{\link{getLoadedDLLs}} } }} \seealso{\code{\link{getLoadedDLLs}}, \code{\link{dyn.load}} } \examples{ \dontrun{ getDynLib( "base" ) f <- cfunction( signature() , "return R_NilValue ;" ) getDynLib( f ) }} \keyword{methods} inline/man/package.skeleton.Rd0000644000176200001440000000236613760542203016021 0ustar liggesusers\name{package.skeleton-methods} \docType{methods} \alias{package.skeleton-methods} \alias{package.skeleton,ANY,ANY-method} \alias{package.skeleton,character,CFunc-method} \alias{package.skeleton,character,CFuncList-method} \title{Generate the skeleton of a package} \description{ Generate the skeleton of a package } \section{Methods}{ \describe{ \item{\code{signature(name = "ANY", list = "ANY")}}{ Standard method. See \code{\link[utils]{package.skeleton}} } \item{\code{signature(name = "character", list = "CFunc")}}{ Method for a single generated by \code{\link{cfunction}} or \code{\link{cxxfunction}} } \item{\code{signature(name = "character", list = "CFuncList")}}{ Method for a set functions generated by \code{\link{cfunction}} or \code{\link{cxxfunction}} } }} \examples{ \dontrun{ fx <- cxxfunction(signature(x = "integer", y = "numeric"), "return ScalarReal( INTEGER(x)[0] * REAL(y)[0]);") package.skeleton("foo", fx) functions <- cxxfunction(list(ff = signature(), gg = signature(x = "integer", y = "numeric")), c("return R_NilValue ;", "return ScalarReal(INTEGER(x)[0] * REAL(y)[0]);")) package.skeleton("foobar", functions) } } \keyword{methods} inline/man/cxxfunction.Rd0000644000176200001440000000377313760465667015200 0ustar liggesusers\name{cxxfunction} \alias{cxxfunction} \alias{rcpp} \title{inline C++ function} \description{ Functionality to dynamically define an R function with inlined C++ code using the \code{\link{.Call}} calling convention. The \code{rcpp()} wrapper sets the plugin to the \dQuote{Rcpp} value suitable for using \pkg{Rcpp}. } \usage{ cxxfunction(sig = character(), body = character(), plugin = "default", includes = "", settings = getPlugin(plugin), ..., verbose = FALSE) rcpp(..., plugin="Rcpp") } \arguments{ \item{sig}{Signature of the function. A named character vector} \item{body}{A character vector with C++ code to include in the body of the compiled C++ function} \item{plugin}{Name of the plugin to use. See \code{\link{getPlugin}} for details about plugins. } \item{includes}{User includes, inserted after the includes provided by the plugin. } \item{settings}{Result of the call to the plugin} \item{\dots}{Further arguments to the plugin} \item{verbose}{verbose output} } \value{A function} \seealso{\code{\link{cfunction}}} \examples{ \dontrun{ # default plugin fx <- cxxfunction(signature(x = "integer", y = "numeric"), "return ScalarReal(INTEGER(x)[0] * REAL(y)[0]);") fx(2L, 5) # Rcpp plugin if (requireNamespace("Rcpp", quietly=TRUE)) { fx <- cxxfunction(signature(x = "integer", y = "numeric"), "return wrap( as(x) * as(y));", plugin = "Rcpp" ) fx(2L, 5) ## equivalent shorter form using rcpp() fx <- rcpp(signature(x = "integer", y = "numeric"), "return wrap(as(x) * as(y));") } # RcppArmadillo plugin if (requireNamespace(RcppArmadillo)) { fx <- cxxfunction(signature(x = "integer", y = "numeric"), "int dim = as(x); arma::mat z = as(y) * arma::eye(dim, dim); return wrap(arma::accu(z));", plugin = "RcppArmadillo") fx(2L, 5) } } } \keyword{programming} \keyword{interface} inline/man/plugins.Rd0000644000176200001440000000360112377726054014270 0ustar liggesusers\name{plugins} \alias{getPlugin} \alias{registerPlugin} \title{ Plugin system for cxxfunction } \description{ \code{\link{cxxfunction}} uses a plugin system to assembly the code that it compiles. These functions allow to register and get plugins by their name. } \usage{ getPlugin(name, ...) registerPlugin(name, plugin) } \arguments{ \item{name}{name of the plugin. } \item{\dots}{Further argments to pass to the plugin. } \item{plugin}{plugin function. } } \details{ plugins are functions that return a list with : \describe{ \item{includes}{mandatory. it is included at the top of the compiled file by \code{\link{cxxfunction}} } \item{body}{optional. a function that takes one argument (the body of the c++ function) and returned a modified version of the body. The "Rcpp" plugin uses this to surround the code with the \code{BEGIN_RCPP} and \code{END_RCPP} macros } \item{LinkingTo}{optional. character vector containing the list of packages that the code needs to link to. This adds the include path of the given packages. The "Rcpp" and "RcppArmadillo" plugins use this. } \item{env}{optional. named list of environment variables. For example, the "Rcpp" plugin uses this to add Rcpp user library to the \code{PKG_LIBS} environment variable. } } plugins can be manually registered using the \code{registerPlugin} function. Alternatively, a package may supply an inline plugin implicitely by defining a function called \code{inlineCxxPlugin}, which does not necessarily need to be exported from the namespace of the package. Known packages implementing this scheme include \code{Rcpp} and \code{RcppArmadillo}. } \value{ \code{getPlugin} retrieves the plugin and invokes it with the \dots arguments \code{registerPlugin} does not return anything. } \seealso{ \code{\link{cxxfunction}} } \examples{ \dontrun{ getPlugin( "Rcpp" ) } } \keyword{programming} \keyword{interface} inline/man/inline-package.Rd0000644000176200001440000000046713277102263015453 0ustar liggesusers\name{inline-package} \alias{inline-package} \alias{inline} \docType{package} \title{\packageTitle{inline}} \description{\packageDescription{inline}} \seealso{\code{\link{cfunction}}, \code{\link{cxxfunction}}} \author{\packageAuthor{inline}} \section{Maintainer}{\packageMaintainer{inline}} \keyword{package} inline/man/cfunction.Rd0000644000176200001440000002622513760032564014577 0ustar liggesusers\name{cfunction} \alias{cfunction} \alias{setCMethod} \concept{inline function call} \title{ Inline C, C++, Fortran function calls from R } \description{ Functionality to dynamically define R functions and S4 methods with in-lined C, C++ or Fortran code supporting .C and .Call calling conventions. } \usage{ cfunction(sig=character(), body=character(), includes=character(), otherdefs=character(), language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"), verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), Rcpp=FALSE, cppargs=character(), cxxargs=character(), libargs=character(), dim=NULL, implicit=NULL, module=NULL, name=NULL) ## S4 methods for signatures # f='character', sig='list', body='list' # f='character', sig='character', body='character' setCMethod(f, sig, body, ...) ## Further arguments: # setCMethod(f, sig, body, includes="", otherdefs="", cpp=TRUE, # verbose=FALSE, where=topenv(.GlobalEnv), ...) } \arguments{ \item{f}{A single character value if \code{sig} and \code{body} are character vectors or a character vector of the same length and the length of \code{sig} or \code{body} with the name(s) of methods to create.} \item{sig}{A match of formal argument names for the function with the character-string names of corresponding classes. Alternatively, a named list of such character vectors. The names of the list elements will be used as function names (see example). If \code{sig} is not a list, the function name used in the code can be specified by the \code{name} argument. } \item{body}{ A character vector with C, C++ or Fortran code omitting function declaration (only the body, i.e. in case of C starting after the function opening curly bracket and ending before the closing curly bracket, brackets excluded). In case of \code{setCMethod} with signature \code{list} -- a list of such character vectors. } \item{includes}{ A character vector of additional includes and preprocessor statements etc that will be put between the R includes and the user function(s).} \item{otherdefs}{ A characted vector with the code for any further definitions of functions, classes, types, forward declarations, namespace usage clauses etc which is inserted between the includes and the declarations of the functions defined in \code{sig}.} \item{language}{ A character value that specifies the source language of the inline code. The possible values for \code{language} include all those supported by \code{R CMD SHLIB} on any platform, which are currently C, C++, Fortran, F95, ObjectiveC and ObjectiveC++; they may not all be supported on your platform. One can specify the language either in full as above, or using any of the following case insensitive shortened forms: \code{c, cpp, c++, f, f95, objc, objcpp, objc++}. Defaults to \code{C++}.} \item{verbose}{ If \code{TRUE} prints the compilation output, the source code of the resulting program and the definitions of all declared methods. If \code{FALSE}, the function is silent, but it prints compiler warning and error messages and the source code if compilation fails. } \item{convention}{ Which calling convention to use? See the Details section.} \item{Rcpp}{If \code{TRUE} adds inclusion of \code{Rcpp.h} to \code{includes}, also queries the \code{Rcpp} package about the location of header and library files and sets environment variables \code{PKG_CXXFLAGS} and \code{PKG_LIBS} accordingly so that the R / C++ interface provided by the \code{Rcpp} package can be used. Default value is \code{FALSE}.} \item{cppargs}{Optional character vector of tokens to be passed to the compiler via the \code{PKG_CPPFLAGS} environment variable. Elements should be fully formed as for example \code{c("-I/usr/local/lib/foo", "-DDEBUG")} and are passed along verbatim.} \item{cxxargs}{Optional character vector of tokens to be passed to the compiler via the \code{PKG_CXXFLAGS} environment variable. Elements should be fully formed as for example \code{c("-I/usr/local/lib/foo", "-DDEBUG")} and are passed along verbatim.} \item{libargs}{Optional character vector of tokens to be passed to the compiler via the \code{PKG_LIBS} environment variable. Elements should be fully formed as for example \code{c("-L/usr/local/lib/foo -lfoo", "--lpthread")} and are passed along verbatim.} \item{dim}{Optional character vector defining the dimensionality of the function arguments. Of same length as \code{sig}. Fortran or F95 only.} \item{implicit}{A character vector defining the implicit declaration in Fortran or F95; the default is to use the implicit typing rules for Fortran, which is \code{integer} for names starting with the letters \code{I} through \code{N}, and \code{real} for names beginning with any other letter. As \code{R} passes double precision, this is not the best choice. Safest is to choose \code{implicit = "none"} which will require all names in the subroutine to be explicitly declared.} \item{module}{Name(s) of any modules to be used in the \code{Fortran} or \code{F95} subroutine.} \item{name}{Function name to be used in the code. Only used if \code{sig} is not a list. This is useful if the DLL created is to be used in conjunction with the \code{ode} function of the \code{deSolve} package. } \item{...}{ Reserved.} } \value{ If \code{sig} is a single character vector, \code{cfunction} returns a single \code{\link{function}}; if it is a list, it returns a list of functions. \code{setCMethod} declares new methods with given names and signatures and returns invisible \code{NULL}. } \details{ To declare multiple functions in the same library one can use \code{setCMethod} supplying lists of signatures and implementations. In this case, provide as many method names in \code{f} as you define methods. Avoid clashes when selecting names of the methods to declare, i.e. if you provide the same name several times you must ensure that signatures are different but can share the same generic! The source code in the \code{body} should not include the header or "front-matter" of the function or the close, e.g. in C or C++ it must start after the C-function opening curly bracket and end before the C-function closing curly bracket, brackets should not be included. The header will be automatically generated from the R-\code{signature} argument. Arguments will will carry the same name as used in the signature, so avoid variable names that are not legal in the target language (e.g. names with dots). C/C++: If \code{convention == ".Call"} (the default), the \code{\link{.Call}} mechanism is used and its result is returned directly as the result of the call of the generated function. As the last line of the generated C/C++ code a \code{return R_NilValue;} is added in this case and a warning is generated in case the user has forgotten to provide a return value. To suppress the warning and still return NULL, add \code{return R_NilValue;} explicitly. Special care is needed with types, memory allocation and protection -- exactly the same as if the code was not inline: see the Writing R Extension manual for information on \code{\link{.Call}}. If \code{convention == ".C"} or \code{convention == ".Fortran"}, the \code{\link{.C}} or \code{\link{.Fortran}} mechanism respectively is used, and the return value is a list containing all arguments. Attached R includes include \code{R.h} for \code{".C"}, and additionally \code{Rdefines.h} and \code{R_ext\\Error.h} for \code{".Call"}. } \seealso{ \code{ \link{Foreign} Function Interface }} \examples{ x <- as.numeric(1:10) n <- as.integer(10) \dontrun{ ## A simple Fortran example - n and x: assumed-size vector code <- " integer i do 1 i=1, n(1) 1 x(i) = x(i)**3 " cubefn <- cfunction(signature(n="integer", x="numeric"), code, convention=".Fortran") print(cubefn) cubefn(n, x)$x ## Same Fortran example - now n is one number code2 <- " integer i do 1 i=1, n 1 x(i) = x(i)**3 " cubefn2 <- cfunction(signature(n="integer", x="numeric"), implicit = "none", dim = c("", "(*)"), code2, convention=".Fortran") cubefn2(n, x)$x ## Same in F95, now x is fixed-size vector (length = n) code3 <- "x = x*x*x" cubefn3 <- cfunction(sig = signature(n="integer", x="numeric"), implicit = "none", dim = c("", "(n)"), code3, language="F95") cubefn3(20, 1:20) print(cubefn3) ## Same example in C code4 <- " int i; for (i = 0; i < *n; i++) x[i] = x[i]*x[i]*x[i]; " cubefn4 <- cfunction(signature(n="integer", x="numeric"), code4, language = "C", convention = ".C") cubefn4(20, 1:20) ## Give the function in the source code a name cubefn5 <- cfunction(signature(n="integer", x="numeric"), code4, language = "C", convention = ".C", name = "cubefn") code(cubefn5) } ## use of a module in F95 modct <- "module modcts double precision, parameter :: pi = 3.14159265358979 double precision, parameter :: e = 2.71828182845905 end" getconstants <- "x(1) = pi x(2) = e" cgetcts <- cfunction(getconstants, module = "modcts", implicit = "none", includes = modct, sig = c(x = "double"), dim = c("(2)"), language = "F95") cgetcts(x = 1:2) print(cgetcts) ## Use of .C convention with C code ## Defining two functions, one of which calls the other sigSq <- signature(n="integer", x="numeric") codeSq <- " for (int i=0; i < *n; i++) { x[i] = x[i]*x[i]; }" sigQd <- signature(n="integer", x="numeric") codeQd <- " squarefn(n, x); squarefn(n, x); " fns <- cfunction( list(squarefn=sigSq, quadfn=sigQd), list(codeSq, codeQd), convention=".C") squarefn <- fns[["squarefn"]] quadfn <- fns[["quadfn"]] squarefn(n, x)$x quadfn(n, x)$x ## Alternative declaration using 'setCMethod' setCMethod(c("squarefn", "quadfn"), list(sigSq, sigQd), list(codeSq, codeQd), convention=".C") squarefn(n, x)$x quadfn(n, x)$x ## Use of .Call convention with C code ## Multyplying each image in a stack with a 2D Gaussian at a given position code <- " SEXP res; int nprotect = 0, nx, ny, nz, x, y; PROTECT(res = Rf_duplicate(a)); nprotect++; nx = INTEGER(GET_DIM(a))[0]; ny = INTEGER(GET_DIM(a))[1]; nz = INTEGER(GET_DIM(a))[2]; double sigma2 = REAL(s)[0] * REAL(s)[0], d2 ; double cx = REAL(centre)[0], cy = REAL(centre)[1], *data, *rdata; for (int im = 0; im < nz; im++) { data = &(REAL(a)[im*nx*ny]); rdata = &(REAL(res)[im*nx*ny]); for (x = 0; x < nx; x++) for (y = 0; y < ny; y++) { d2 = (x-cx)*(x-cx) + (y-cy)*(y-cy); rdata[x + y*nx] = data[x + y*nx] * exp(-d2/sigma2); } } UNPROTECT(nprotect); return res; " funx <- cfunction(signature(a="array", s="numeric", centre="numeric"), code) x <- array(runif(50*50), c(50,50,1)) res <- funx(a=x, s=10, centre=c(25,15)) if (interactive()) image(res[,,1]) ## Same but done by registering an S4 method setCMethod("funy", signature(a="array", s="numeric", centre="numeric"), code, verbose=TRUE) res <- funy(x, 10, c(35,35)) if (interactive()) { x11(); image(res[,,1]) } } \author{ Oleg Sklyar, Duncan Murdoch, Mike Smith, Dirk Eddelbuettel } \keyword{file} inline/man/utilities.Rd0000644000176200001440000001004714050723531014607 0ustar liggesusers\name{utilities} \alias{utilities} \alias{moveDLL} \alias{moveDLL-methods} \alias{moveDLL,CFunc-method} \alias{writeCFunc} \alias{readCFunc} \alias{print,CFunc-method} \alias{print,CFuncList-method} \alias{code} \alias{code-methods} \alias{code,character-method} \alias{code,CFunc-method} \alias{code,CFuncList-method} \title{ Printing, reading and writing compiled function objects } \description{ \code{moveDLL} moves the DLL used by a compiled function to a user defined location. \code{writeCFunc} saves a \code{CFunc} object after the DLL has been moved to the desired location using \code{moveDLL}. \code{readCFunc} reads a \code{CFunc} object that has been saved using \code{writeCFunc}. The \code{print} and \code{code} methods respectively print the entire object or only the code parts. } \usage{ moveDLL(x, ...) \S4method{moveDLL}{CFunc}(x, name, directory, unload = FALSE, overwrite = FALSE, verbose = FALSE) writeCFunc(x, file) readCFunc(file) \S4method{print}{CFunc}(x) \S4method{print}{CFuncList}(x) \S4method{code}{CFunc}(x, linenumbers = TRUE) \S4method{code}{CFuncList}(x, linenumbers = TRUE) } \arguments{ \item{x}{A \code{CFunc} or \code{CFuncList} object as created by \code{\link{cfunction}}} \item{name}{The base of the file name that the DLL should be moved to. The file name extension will depend on the operating system used} \item{directory}{The directory that the DLL should be written to} \item{unload}{In case the new path constructed from \code{name} and \code{directory} points to a loaded DLL, should we unload it?} \item{overwrite}{In case there is a file at the new path constructed from \code{name} and \code{directory} should we overwrite that file?} \item{verbose}{Should we print a message stating where the DLL was copied if the operation was successful?} \item{file}{The file path for writing and reading the object generated by \code{\link{cfunction}}. Consider using a file name extension like \code{.rda} or \code{.RData} to indicate that this is a serialized R object. } \item{linenumbers}{If \code{TRUE} all code lines will be numbered.} \item{\dots}{May be used in future methods} } \value{ Function \code{readDynLib} returns a \code{CFunc} object. Function \code{writeDynLib} returns the name of the \code{.CFunc} file that was created. } \details{ If you move the DLL to a user defined location with \code{moveDLL}, this will keep an on-disk copy of the DLL which will prevent it from being lost at session termination - unless written to the session \code{\link{tempdir}}. Saving and reloading the \code{CFunc} object with standard tools like \code{\link{save}} or \code{\link{saveRDS}} will still loose the pointer to the DLL. However, when the DLL has been moved using \code{moveDLL}, \code{CFunc} objects can be saved by \code{writeCFunc} and restored by \code{readCFunc}. } \note{ \itemize{ \item The code of a \code{CFunc} or \code{CFuncList} object \code{x} can be extracted (rather than printed), using: \code{x@code}. \item To write the code to a file (here called \code{"fn"}), without the new-line character \code{"\n"}: \code{write (strsplit(x, "\n")[[1]], file = "fn")} } } \seealso{ \code{\link{getDynLib}} } \examples{ x <- as.numeric(1:10) n <- as.integer(10) code <- " integer i do 1 i=1, n(1) 1 x(i) = x(i)**3 " cubefn <- cfunction(signature(n="integer", x="numeric"), code, convention=".Fortran") code(cubefn) cubefn(n, x)$x \dontrun{ # The following code is exempted from the automated tests of example code, as # it writes to the users home directory. # The following writes the DLL, e.g. cubefn.so on Linux/Unix or cubefn.dll # on Windows moveDLL(cubefn, name = "cubefn", directory = "~") path <- file.path("~", "cubefn.rda") writeCFunc(cubefn, path) rm(cubefn) # Now you can start a fresh R session and load the function library(inline) path <- file.path("~", "cubefn.rda") cfn <- readCFunc(path) cfn(3, 1:3)$x } } \author{ Karline Soetaert and Johannes Ranke } \keyword{file} inline/man/internals.Rd0000644000176200001440000000060212512213336014565 0ustar liggesusers\name{internals} \alias{internals} \alias{setCMethod,character,list,list-method} \alias{setCMethod,character,character,character-method} \title{ Internals } \description{ Aliases required for 'R CMD check' but those no-one will ever search for. Here to prevent the mess of the index. The corresponding items have help aliases without method signature! } \keyword{internal} inline/DESCRIPTION0000644000176200001440000000155314055120342013236 0ustar liggesusersPackage: inline Version: 0.3.19 Date: 2021-05-25 Title: Functions to Inline C, C++, Fortran Function Calls from R Author: Oleg Sklyar, Duncan Murdoch, Mike Smith, Dirk Eddelbuettel, Romain Francois, Karline Soetaert, Johannes Ranke Maintainer: Dirk Eddelbuettel Imports: methods Suggests: Rcpp (>= 0.11.0), tinytest Description: Functionality to dynamically define R functions and S4 methods with 'inlined' C, C++ or Fortran code supporting the .C and .Call calling conventions. License: LGPL Copyright: Oleg Sklyar, 2005-2010 and other authors per their commits LazyLoad: yes URL: https://github.com/eddelbuettel/inline, https://dirk.eddelbuettel.com/code/inline.html BugReports: https://github.com/eddelbuettel/inline/issues NeedsCompilation: no Packaged: 2021-05-25 12:45:08 UTC; edd Repository: CRAN Date/Publication: 2021-05-31 08:40:02 UTC inline/build/0000755000176200001440000000000014053170524012630 5ustar liggesusersinline/build/partial.rdb0000644000176200001440000000475014053170524014763 0ustar liggesusersr|I$;MǶiH -ʎĊǕVJƓqA(Jb5~F&XÁ"ATf$w,IRVggK|Qxc=T"pްLBw;v!IgS5'nO<%v45js4 =&w5 I%g$ki+"Ku♕8kvv=O/<>Tz4Sf :@jK_xvXF;nS57j?{P QmV5lM=չi/0CID2Ӌٷ7R˿uِf1|w_ưq01r0EyO7j"'Rp)E5 ǬMC0R2Tc$fp+0I@ 1.\|9ei,[(.Ozي@\|eY3nQGWߺX%_6`T1+a|m]~0R*_@]R+8NO(YNX;SciP6e9lH=թH\c됞Uc$ۤ&! Xud6uY5(tx9/jֆGmBun#WE[lTBX |j|\L+*Wra=#%?5eIf a->q ɟw7%RK;;㧝v_R% x5s=H=#N&c_aֆ}jDI$ !Hc *=*1iRǤǨwj;z.0@a$xGzR5EBP{Ǫ i얇?ԭ]P 6>3OS4!=$h%LG45,c߀nFqC]nTʹ4b>E>E#/ t;D#tcY'cp7U3 6@I޴Lh?RJ Yv8,A$\Щf۪Qٯ1,  JirM+kXmަ^Q"K7 ժ N5@no F7P="J E%QqR.I_FB c(İlsB WmtP揖FOOSyCQjtB "9Gp>17Mdb:7#vlu803JN "nJx *v9oZ;,AL.9{m@7@c&AvYBQQ~  p_KvS-AZ3Vqg4j|FI>xH+7jk~)z~!f}׌K.G`MR]6_G2(|+5KLiS(&)x\<_G%%1(|;>S{PӐ^AxrުVD'u?=PB*&D-4=~*".P:{ME,)$pIUнOLê-aR=T-ٳtëk׏QBᏀZnT:ޫýoE!^k u!> LVCTBp%|'͗܏F+^WAJ _rb{ !{*Z$P\O=Sr=UpeYӡgIuHGAu/O~ȹ=l+H VolB9inline/tests/0000755000176200001440000000000013757455370012712 5ustar liggesusersinline/tests/tinytest.R0000644000176200001440000000031313757455370014715 0ustar liggesusers if (requireNamespace("tinytest", quietly=TRUE) && utils::packageVersion("tinytest") >= "1.1.0") { ## Set a seed to make the tests deterministic set.seed(42) tinytest::test_package("inline") } inline/R/0000755000176200001440000000000014053170524011732 5ustar liggesusersinline/R/package.skeleton.R0000644000176200001440000001075212377726054015314 0ustar liggesusers setGeneric( "package.skeleton" ) setMethod( "package.skeleton", signature( name = "character", list = "CFuncList" ), function (name = "anRpackage", list = new( "CFuncList" ), environment = .GlobalEnv, path = ".", force = FALSE, code_files = character()) { env <- environment( list[[1]]@.Data ) clean.env <- new.env( parent = environment ) functions <- names( list ) for( i in seq_along(list) ){ f <- functions[i] call <- body( list[[i]]@.Data ) call[[1L]] <- as.name( env$convention ) call[[2L]] <- names( env$sig )[i] call[["PACKAGE"]] <- name fun <- list[[i]]@.Data body( fun ) <- call environment(fun) <- clean.env assign( f, fun, clean.env ) } message( ">> standard package.skeleton from utils" ) package.skeleton( name, functions , clean.env, path, force, code_files ) if( !file.exists( R <- file.path(name, "R") ) ){ dir.create( R ) con <- file( file.path( R, sprintf("%s.R", name) ), open = "w" ) for( i in seq_along(list) ){ fun <- functions[i] writeLines( sprintf( ' %s <- %s\n' , fun, paste( deparse(clean.env[[ fun ]] ), collapse = "\n" ) ), con ) } close( con ) message( ">> added R directory with function calling compiled code" ) } Rdfiles <- file.path( name, "man", sprintf( "%s.Rd", functions ) ) sapply( Rdfiles, function( Rdfile) { if( file.exists( Rdfile ) ){ content <- readLines( Rdfile ) content <- sub( "%% ~~function to do ... ~~", "insert here the title", content ) writeLines( content, Rdfile ) } message( ">> workaround for empty title in Rd file" ) } ) package.doc <- file.path( name, "man", sprintf("%s-package.Rd", name) ) if( file.exists( package.doc) ){ lines <- readLines( package.doc ) lines <- sub( "~~ simple examples of", "%% ~~ simple examples of", lines ) writeLines( lines, package.doc ) } dir.create( file.path( name, "src" ) ) message( ">> created src directory" ) NAMESPACE <- sprintf( ' useDynLib(%s) %s ', name, paste( sprintf( 'export("%s")', functions ), collapse = "\n" ) ) writeLines( NAMESPACE, file.path( name, "NAMESPACE" ) ) language <- env$language extension <- switch(language, "C++"=".cpp", C=".c", Fortran=".f", F95=".f95", ObjectiveC=".m", "ObjectiveC++"=".mm") cfile <- file.path( name, "src", sprintf( "%s%s", name, extension ) ) writeLines( list[[1]]@code, cfile ) message( ">> added compiled code in src directory" ) settings <- env$settings if( !is.null( settings ) ){ DESCRIPTION_file <- file.path( name, "DESCRIPTION" ) DESCRIPTION <- read.dcf( DESCRIPTION_file ) depends <- settings$Depends if( !is.null( depends ) ){ DESCRIPTION <- cbind( DESCRIPTION, "Depends" = paste( depends, collapse = ", ") ) } linkingTo <- settings$LinkingTo if( !is.null( linkingTo ) ){ DESCRIPTION <- cbind( DESCRIPTION, "LinkingTo" = paste( linkingTo, collapse = ", ") ) } write.dcf( DESCRIPTION, DESCRIPTION_file ) message( ">> updated DESCRIPTION file" ) Makevars <- settings$Makevars if( !is.null( Makevars ) ){ Makevars_file <- file.path( name, "src", "Makevars" ) writeLines( Makevars, Makevars_file ) message( ">> added Makevars ") } Makevars.win <- settings$Makevars.win if( !is.null( Makevars.win ) ){ Makevars.win_file <- file.path( name, "src", "Makevars.win" ) writeLines( Makevars.win, Makevars.win_file ) message( ">> added Makevars.win" ) } configure <- settings$configure if( ! is.null( configure ) ){ configure_file <- file.path(name, "configure" ) writeLines( configure, configure_file ) Sys.chmod(configure_file, "0755") message( ">> added configure" ) } configure.win <- settings$configure.win if( ! is.null( configure.win ) ){ configure_win_file <- file.path(name, "configure.win" ) writeLines( configure.win, configure_win_file ) message( ">> added configure.win" ) } Makevars.in <- settings$Makevars.in if( ! is.null( Makevars.in ) ){ Makevars_in_file <- file.path(name, "src", "Makevars.in" ) writeLines( Makevars.in, Makevars_in_file ) message( ">> added Makevars.in" ) } } invisible(NULL) } ) setMethod( "package.skeleton", signature( name = "character", list = "CFunc" ), function (name = "anRpackage", list = new( "CFunc" ), environment = .GlobalEnv, path = ".", force = FALSE, code_files = character() ) { funclist <- new( "CFuncList", base::list( fun = list ) ) package.skeleton( name = name, list = funclist, environment = environment, path = path , force = force, code_files = code_files ) } ) inline/R/cmethods.R0000644000176200001440000000347012377726054013703 0ustar liggesusers# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - setGeneric( "setCMethod", function(f, sig, body, ...) standardGeneric("setCMethod") ) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - setMethod( "setCMethod", signature(f="character", sig="list", body="list"), function(f, sig, body, includes="", otherdefs="", language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"), verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), where=topenv(.GlobalEnv), ...) { if ( length(f) != length(sig) || length(sig) != length(body) ) stop("number of signatures does not correspond to the number of code chunks") names(sig) <- f fns <- cfunction(sig, body, includes, otherdefs, language, verbose, convention) if ( verbose ) cat("\nThe following methods are now defined:\n") ## Let's try to create generics for ( i in 1:length(f) ) { generic <- paste( "setGeneric(\"", f[i], "\", function(", paste(names(sig[[i]]),collapse=", "), ") standardGeneric(\"", f[i], "\"),where=where )", sep="") eval(parse(text=generic)) setMethod(f[i], sig[[i]], fns[[i]], where=where) if ( verbose ) showMethods(f[i]) } } ) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - setMethod( "setCMethod", signature(f="character", sig="character", body="character"), function(f, sig, body, includes="", otherdefs="", language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"), verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), where=topenv(.GlobalEnv), ...) setCMethod(f, list(sig), list(body), includes, otherdefs, language, verbose, convention, where=topenv(.GlobalEnv), ...) ) inline/R/utilities.R0000644000176200001440000000610114050562373014072 0ustar liggesuserssetGeneric("moveDLL", function(x, ...) { standardGeneric("moveDLL") } ) setMethod("moveDLL", signature(x = "CFunc"), function(x, name, directory, unload = FALSE, overwrite = FALSE, verbose = FALSE) { # Check arguments if (length(name) > 1) stop("Please supply only one name") if (length(directory) > 1) stop("Please supply only one directory name") # Obtain path to DLL old_path <- environment(x)$libLFile # Create new path if (!dir.exists(directory)) stop("There is no directory ", directory) extension <- tools::file_ext(old_path) new_path <- normalizePath(file.path(directory, paste(name, extension, sep = ".")), mustWork = FALSE) active_paths <- sapply(getLoadedDLLs()[-1], function(di) normalizePath(di[["path"]])) if (new_path %in% active_paths) { if (unload) { if (inherits(try(dyn.unload(new_path)), "try-error")) stop("Could not unload ", new_path) } else { stop("DLL from ", new_path, " is in use") } } # Copy the DLL copy_success <- file.copy(old_path, new_path, overwrite = overwrite) if (!copy_success) stop("Failed to copy DLL from ", old_path, " to ", new_path) if (verbose) message("Copied DLL from ", old_path, " to ", new_path) # Adjust the path that getDynLib uses environment(x)$libLFile <- new_path invisible() } ) writeCFunc <- function(x, file) { env <- environment(x) if (identical(env$libLFile, env$libLFile_orig)) stop("Use moveDLL to prevent losing the DLL by garbage collection or session termination") saveRDS(x, file = file) } readCFunc <- function(file) { x <- readRDS(file) if (class(x) != "CFunc") stop(file, " does not contain a serialized CFunc object") # Get code for restoring after updating the function body source_code <- x@code # Load the DLL env <- environment(x) dll_info <- dyn.load(env$libLFile) # Set the symbol info in the function body body(x)[[2]] <- getNativeSymbolInfo(env$name, dll_info[["name"]])[["address"]] x_cf <- as(x, "CFunc") x_cf@code <- source_code return(x_cf) } setGeneric("code", function(x, ...) standardGeneric("code") ) setMethod( "code", signature( x = "character" ), function( x, linenumbers = TRUE ){ lines <- strsplit(x, "\n") if (linenumbers) for (i in 1:length(lines[[1]])) cat(format(i, width = 3), ": ", lines[[1]][i], "\n", sep = "") else for (i in 1:length(lines[[1]])) cat(lines[[1]][i], "\n", sep = "") } ) setMethod( "code", signature( x = "CFunc" ), function( x, linenumbers = TRUE ) code (x@code, linenumbers)) setMethod( "code", signature( x = "CFuncList" ), function(x, linenumbers = TRUE ) code( x[[1L]], linenumbers ) ) ## Printing methods setMethod( "print", signature( x = "CFunc" ), function( x ){ cat("An object of class 'CFunc'\n") Dat <- x@.Data print(Dat) cat("code:\n") code(x) } ) setMethod( "print", signature( x = "CFuncList" ), function(x) { cat("An object of class 'CFuncList'\n") for (i in 1:length(x)) { print(names(x)[i]) print(x[[i]]@.Data ) cat("\n") } cat("code:\n") code(x) } ) inline/R/cxxfunction.R0000644000176200001440000001215513760465667014454 0ustar liggesusers plugins <- new.env() plugins[["default"]] <- function() { includes = ' #include #include #include ' list(includes = includes, body = function(x) { paste0(x, '\nRf_warning("your C++ program does not return anything");', '\nreturn R_NilValue;')}) } registerPlugin <- function(name, plugin) { plugins[[ name ]] <- plugin } getPlugin <- function(name, ...) { if (name %in% ls(plugins)) { plugins[[ name ]](...) } else if (sprintf("package:%s", name) %in% search() || requireNamespace(name, quietly = TRUE)) { plugin <- get("inlineCxxPlugin", asNamespace(name)) if (is.null(plugin)) { stop(sprintf("package '%s' does not define an inline plugin", name)) } registerPlugin(name, plugin) plugin(...) } else { stop(sprintf("could not find plugin '%s'", name)) } } paste0 <- function(...) paste(..., sep="") addLineNumbers <- function(code) { code <- strsplit(paste(code, collapse = "\n" ), "\n")[[1]] sprintf("%4d : %s", 1:length(code), code) } cxxfunction <- function(sig = character(), body = character(), plugin = "default", includes = "", settings = getPlugin(plugin), ..., verbose = FALSE) { f <- basename(tempfile()) if (!is.list(sig)) { sig <- list(sig) names(sig) <- f if (!length(body)) body <- "" names(body) <- f } if (length(sig) != length(body)) stop("mismatch between the number of functions declared in 'sig' and the number of function bodies provided in 'body'") signature <- lapply( sig, function(x) { if (!length(x)){ "" } else { paste(sprintf("SEXP %s", names(x) ), collapse = ", ") } }) decl <- lapply(1:length(sig) , function(index) { sprintf('SEXP %s( %s) ;', names(signature)[index], signature[[index]]) } ) def <- lapply(1:length(sig), function(index){ sprintf('SEXP %s(%s) {\n%s\n}', names(signature)[index], signature[[index]], if (is.null(settings$body)) body[[index]] else settings$body(body[[index]]) ) }) settings_includes <- if (is.null(settings$includes)) "" else paste(settings$includes, collapse = "\n") code <- sprintf(' // includes from the plugin %s // user includes %s // declarations extern "C" { %s } // definition %s ', settings_includes, paste(includes, collapse = "\n"), paste(decl, collapse = "\n"), paste(def, collapse = "\n")) if (!is.null(env <- settings$env)) { do.call(Sys.setenv, env) if (isTRUE(verbose)) { cat(" >> setting environment variables: \n") writeLines(sprintf("%s = %s", names(env), env)) } } LinkingTo <- settings$LinkingTo if (!is.null(LinkingTo)) { paths <- find.package(LinkingTo, quiet=TRUE) if (length(paths)) { flag <- paste(paste0('-I"', paths, '/include"'), collapse = " ") Sys.setenv(CLINK_CPPFLAGS = flag) if (isTRUE(verbose)) { cat(sprintf("\n >> LinkingTo : %s\n", paste(LinkingTo, collapse = ", "))) cat("CLINK_CPPFLAGS = ", flag, "\n\n") } } } if (isTRUE(verbose)) { writeLines(" >> Program source :\n") writeLines(addLineNumbers(code)) } language <- "C++" ## WRITE AND COMPILE THE CODE libLFile <- compileCode(f, code, language = language, verbose = verbose) ## SET A FINALIZER TO PERFORM CLEANUP cleanup <- function(env) { if (f %in% names(getLoadedDLLs())) dyn.unload(libLFile) unlink(libLFile) } reg.finalizer(environment(), cleanup, onexit=TRUE) ## Create new objects of class CFunc, each containing the code of ALL inline ## functions. This will be used to recompile the whole shared lib when needed res <- vector("list", length(sig)) names(res) <- names(sig) res <- new("CFuncList", res) DLL <- dyn.load(libLFile) for (i in seq_along(sig)) { res[[i]] <- new("CFunc", code = code) fn <- function(arg) { NULL } ## Modify the function formals to give the right argument list args <- formals(fn)[ rep(1, length(sig[[i]])) ] names(args) <- names(sig[[i]]) formals(fn) <- args ## create .Call function call that will be added to 'fn' body <- quote(.Call(EXTERNALNAME, ARG))[ c(1:2, rep(3, length(sig[[i]]))) ] for (j in seq_along(sig[[i]])) body[[j+2]] <- as.name(names(sig[[i]])[j]) body[[1L]] <- .Call body[[2L]] <- getNativeSymbolInfo(names(sig)[[i]], DLL)$address ## update the body of 'fn' body(fn) <- body ## set fn as THE function in CFunc of res[[i]] res[[i]]@.Data <- fn } ## clear the environment rm(j) convention <- ".Call" if (identical(length(sig), 1L)) res[[1L]] else res } rcpp <- function(..., plugin="Rcpp") cxxfunction(..., plugin=plugin) inline/R/getDynLib.R0000644000176200001440000000114612377726054013754 0ustar liggesuserssetGeneric("getDynLib", function(x, ...) standardGeneric("getDynLib") ) setMethod( "getDynLib", signature( x = "character" ), function( x ){ dlls <- getLoadedDLLs() if( x %in% names( dlls ) ){ dlls[[ x ]] } else { stop( sprintf( "dll %s not loaded", x ) ) } } ) setMethod( "getDynLib", signature( x = "CFunc" ), function( x ){ env <- environment( x@.Data ) f <- get( "f", env ) dlls <- getLoadedDLLs() dll <- if( ! f %in% names(dlls) ){ dyn.load( get( "libLFile", env ) ) } else{ dlls[[ f ]] } dll } ) setMethod( "getDynLib", signature( x = "CFuncList" ), function(x) getDynLib( x[[1L]] ) ) inline/R/cfunction.R0000644000176200001440000003206513760736751014071 0ustar liggesusers# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ## CFunc is an S4 class derived from 'function'. This inheritance allows objects ## to behave exactly as functions do, but it provides a slot @code that keeps the ## source C or Fortran code used to create the inline call setClass("CFunc", representation( code="character" ), contains="function" ) setClass( "CFuncList", contains = "list" ) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - cfunction <- function(sig=character(), body=character(), includes=character(), otherdefs=character(), language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"), verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), Rcpp=FALSE, cppargs=character(), cxxargs=character(), libargs=character(), dim = NULL, implicit = NULL, module = NULL, name = NULL) { if (missing (convention) & !missing(language)) convention <- switch (EXPR = language, "Fortran" = ".Fortran", "F95" = ".Fortran", ".C" = ".C", ObjectiveC = ".Call", "ObjectiveC++" = ".Call", "C++" = ".Call") convention <- match.arg(convention) if ( missing(language) ) language <- ifelse(convention == ".Fortran", "Fortran", "C++") else language <- match.arg(language) language <- switch(EXPR=tolower(language), cpp="C++", f="Fortran", f95="F95", objc="ObjectiveC", objcpp= ,"objc++"="ObjectiveC++", language) f <- basename(tempfile()) if (is.null(name)) { name <- f } if ( !is.list(sig) ) { sig <- list(sig) names(sig) <- name names(body) <- name } if( length(sig) != length(body) ) stop("mismatch between the number of functions declared in 'sig' and the number of function bodies provided in 'body'") if (is.null(dim)) dim <- as.list(rep("(*)", length(sig))) else { # this assumes fortran style if (!is.list(dim)) dim <- list(dim) if (length(dim) != length(sig)) stop("mismatch between the number of functions declared in 'sig' and the number of dimensions declared in 'dim'") } if (Rcpp) { if (!requireNamespace("Rcpp", quietly=TRUE)) stop("Rcpp cannot be loaded, install it or use the default Rcpp=FALSE", call.=FALSE) rcppdir <- system.file("include", package="Rcpp") if (.Platform$OS.type == "windows") rcppdir <- utils::shortPathName(normalizePath(rcppdir)) cxxargs <- c(paste("-I", rcppdir, sep=""), cxxargs) # prepend information from Rcpp } if (length(cppargs) != 0) { args <- paste(cppargs, collapse=" ") if (verbose) cat("Setting PKG_CPPFLAGS to", args, "\n") Sys.setenv(PKG_CPPFLAGS=args) } if (length(cxxargs) != 0) { args <- paste(cxxargs, collapse=" ") if (verbose) cat("Setting PKG_CXXFLAGS to", args, "\n") Sys.setenv(PKG_CXXFLAGS=args) } if (length(libargs) != 0) { args <- paste(libargs, collapse=" ") if (verbose) cat("Setting PKG_LIBS to", args, "\n") Sys.setenv(PKG_LIBS=args) } types <- vector(mode="list", length=length(sig)) ## GENERATE THE CODE for ( i in seq_along(sig) ) { ## C/C++ with .Call convention ********************************************* if ( convention == ".Call" ) { ## include R includes, also error if (i == 1) { code <- ifelse(Rcpp, "#include \n", paste("#include \n#include \n", "#include \n", sep="")); ## include further includes code <- paste(c(code, includes, ""), collapse="\n") ## include further definitions code <- paste(c(code, otherdefs, ""), collapse="\n") } ## generate C-function sig from the original sig if ( length(sig[[i]]) > 0 ) { funCsig <- paste("SEXP", names(sig[[i]]), collapse=", " ) } else funCsig <- "" funCsig <- paste("SEXP", names(sig)[i], "(", funCsig, ")", sep=" ") ## add C export of the function if ( language == "C++" || language == "ObjectiveC++") code <- paste( code, "extern \"C\" {\n ", funCsig, ";\n}\n\n", sep="") ## OPEN function code <- paste( code, funCsig, " {\n", sep="") ## add code, split lines code <- paste( code, paste(body[[i]], collapse="\n"), sep="") ## CLOSE function, add return and warning in case the user forgot it code <- paste(code, "\n ", ifelse(Rcpp, "Rf_warning", "warning"), "(\"your C program does not return anything!\");\n return R_NilValue;\n}\n", sep=""); } ## C/C++ with .C convention ************************************************ else if ( convention == ".C" ) { if (i == 1) { ## include only basic R includes code <- ifelse(Rcpp,"#include \n", "#include \n") ## include further includes code <- paste(c(code, includes, ""), collapse="\n") ## include further definitions code <- paste(c(code, otherdefs, ""), collapse="\n") } ## determine function header if ( length(sig[[i]]) > 0 ) { types[[i]] <- pmatch(sig[[i]], c("logical", "integer", "double", "complex", "character", "raw", "numeric"), duplicates.ok = TRUE) if ( any(is.na(types[[i]])) ) stop( paste("Unrecognized type", sig[[i]][is.na(types[[i]])]) ) decls <- c("int *", "int *", "double *", "Rcomplex *", "char **", "unsigned char *", "double *")[ types[[i]] ] funCsig <- paste(decls, names(sig[[i]]), collapse=", ") } else funCsig <- "" funCsig <- paste("void", names(sig)[i], "(", funCsig, ")", sep=" ") if ( language == "C++" || language == "ObjectiveC++" ) code <- paste( code, "extern \"C\" {\n ", funCsig, ";\n}\n\n", sep="") ## OPEN function code <- paste( code, funCsig, " {\n", sep="") ## add code, split lines code <- paste( code, paste(body[[i]], collapse="\n"), sep="") ## CLOSE function code <- paste( code, "\n}\n", sep="") } ## .Fortran convention ***************************************************** else { # old-style fortran requires 6 columns not used lead <- ifelse (language == "Fortran", " ","") if (i == 1) { ## no default includes, include further includes code <- paste(includes, collapse="\n") ## include further definitions code <- paste(c(code, otherdefs, ""), collapse="\n") } ## determine function header if ( length(sig[[i]]) > 0 ) { types[[i]] <- pmatch(sig[[i]], c("logical", "integer", "double", "complex", "character", "raw", "numeric"), duplicates.ok = TRUE) if ( any(is.na(types[[i]])) ) stop( paste("Unrecognized type", sig[[i]][is.na(types[[i]])]) ) if (6 %in% types[[i]]) stop( "raw type unsupported by .Fortran()" ) decls <- c("INTEGER", "INTEGER", "DOUBLE PRECISION", "DOUBLE COMPLEX", "CHARACTER*255", "Unsupported", "DOUBLE PRECISION")[ types[[i]] ] decls <- paste(lead, decls, " ", names(sig[[i]]), dim[[i]], sep="", collapse="\n") funCsig <- paste(names(sig[[i]]), collapse=", ") } else { decls <- "" funCsig <- "" } funCsig <- paste(lead,"SUBROUTINE", names(sig)[i], "(", funCsig, ")\n", sep=" ") ## old-style FORTRAN line length restricted to 72 characters if (language == "Fortran") { if ((cl <- nchar(funCsig)) >= 72) { fstring <- substr(funCsig, 72, cl) funCsig <- substr(funCsig, 1, 71) while ((cf <- nchar(fstring)) > 66) { funCsig <- paste(funCsig, "\n &", substr(fstring, 1, 66), sep = "") fstring <- substr(fstring, 67, cf) } if (cf > 0) funCsig <- paste(funCsig, "\n &", fstring, sep = "") funCsig <- paste(funCsig, "\n") } } ## IMPLICIT statement and module use if (is.character(module)) funCsig <- paste(funCsig, lead, "USE ", module, "\n", sep = "") if (is.character(implicit)) funCsig <- paste(funCsig, lead, "IMPLICIT ", implicit, "\n", sep = "") ## OPEN function code <- paste( code, funCsig, decls, "\n", collapse="\n", sep="") ## add code, split lines code <- paste( code, paste(body[[i]], collapse="\n"), sep="") ## CLOSE function code <- paste( code, "\n", lead, "RETURN\n", lead, "END\n\n", sep="") } } ## for along signatures ## WRITE AND COMPILE THE CODE libLFile <- compileCode(f, code, language, verbose) ## SET A FINALIZER TO PERFORM CLEANUP # Make a copy of libLFile, as we may overwrite it later in writeDynLib(), and # we don't want the finalizer to remove the new libLFile libLFile_orig <- libLFile cleanup <- function(env) { if ( f %in% names(getLoadedDLLs()) ) dyn.unload(libLFile_orig) unlink(libLFile_orig) } reg.finalizer(environment(), cleanup, onexit=TRUE) res <- vector("list", length(sig)) names(res) <- names(sig) ## GENERATE R FUNCTIONS for ( i in seq_along(sig) ) { ## Create new objects of class CFunc, each containing the code of ALL inline ## functions. This will be used to recompile the whole shared lib when needed res[[i]] <- new("CFunc", code = code) ## this is the skeleton of the function, the external call is added below using 'body' ## important here: all variables are kept in the local environment fn <- function(arg) { NULL } DLL <- dyn.load( libLFile ) ## Modify the function formals to give the right argument list args <- formals(fn)[ rep(1, length(sig[[i]])) ] names(args) <- names(sig[[i]]) formals(fn) <- args ## create .C/.Call function call that will be added to 'fn' if (convention == ".Call") { body <- quote( CONVENTION("EXTERNALNAME", ARG) )[ c(1:2, rep(3, length(sig[[i]]))) ] for ( j in seq_along(sig[[i]]) ) body[[j+2]] <- as.name(names(sig[[i]])[j]) } else { body <- quote( CONVENTION("EXTERNALNAME", as.logical(ARG), as.integer(ARG), as.double(ARG), as.complex(ARG), as.character(ARG), as.raw(ARG), as.double(ARG)) )[ c(1:2,types[[i]]+2) ] names(body) <- c( NA, "", names(sig[[i]]) ) for ( j in seq_along(sig[[i]]) ) body[[j+2]][[2]] <- as.name(names(sig[[i]])[j]) ## OLD VERSION -- does not work for lists of functions # body <- quote( CONVENTION("EXTERNALNAME", as.logical(ARG), as.integer(ARG), # as.double(ARG), as.complex(ARG), as.character(ARG), # as.raw(ARG), as.double(ARG)) )[ c(1:2,types+2) ] # names(body) <- c( NA, "", names(sig[[i]]) ) # for ( j in seq(along = sig[[i]]) ) body[[j+2]][[2]] <- as.name(names(sig[[i]])[j]) } body[[1]] <- get(convention) body[[2]] <- getNativeSymbolInfo( names(sig)[i], DLL )$address ## update the body of 'fn' body(fn) <- body ## set fn as THE function in CFunc of res[[i]] res[[i]]@.Data <- fn } ## OUTPUT PROGRAM CODE IF DESIRED if ( verbose ) { cat("Program source:\n") lines <- strsplit(code, "\n") for ( i in 1:length(lines[[1]]) ) cat(format(i,width=3), ": ", lines[[1]][i], "\n", sep="") } ## Remove unnecessary objects from the local environment remove(list = c("args", "body", "fn", "funCsig", "i", "includes", "j")) ## RETURN THE FUNCTION if (length(res) == 1 && names(res) == name) return( res[[1]] ) else return( new( "CFuncList", res ) ) } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - compileCode <- function(f, code, language, verbose) { wd = getwd() on.exit(setwd(wd)) ## Prepare temp file names extension <- switch(language, "C++"=".cpp", C=".c", Fortran=".f", F95=".f95", ObjectiveC=".m", "ObjectiveC++"=".mm") libCFile <- file.path(tempdir(), paste0(f, extension)) libLFile <- file.path(tempdir(), paste0(f, .Platform$dynlib.ext)) ## Write the code to the temp file for compilation write(code, libCFile) ## Compile the code using the running version of R if several available if ( file.exists(libLFile) ) file.remove( libLFile ) setwd(dirname(libCFile)) errfile <- paste( basename(libCFile), ".err.txt", sep = "" ) cmd <- paste0(R.home(component="bin"), "/R") if ( verbose ) system2(cmd, args = paste(" CMD SHLIB --dry-run", basename(libCFile))) compiled <- system2(cmd, args = paste(" CMD SHLIB", basename(libCFile)), stdout = FALSE, stderr = errfile) errmsg <- readLines( errfile ) unlink( errfile ) if ( !file.exists(libLFile) ) { cat("\nERROR(s) during compilation: source code errors or compiler configuration errors!\n") if ( !verbose ) system2(cmd, args = paste(" CMD SHLIB --dry-run --preclean", basename(libCFile))) cat("\nProgram source:\n") code <- strsplit(code, "\n") for (i in 1:length(code[[1]])) cat(format(i,width=3), ": ", code[[1]][i], "\n", sep="") cat("\nCompilation ERROR, function(s)/method(s) not created!\n") if ( sum(nchar(errmsg)) > getOption("warning.length") ) stop(tail(errmsg)) else stop(errmsg) } return( libLFile ) } inline/MD50000644000176200001440000000225514055120342012040 0ustar liggesusers8e096205390c7a283c1c266834143da6 *DESCRIPTION 04fb0b89d8e5bfdf5a6a3c8742fbb497 *NAMESPACE 646c24f533ad74b80c175366fcb49808 *R/cfunction.R 3661ee24e0f177e278d23dc97797e056 *R/cmethods.R aac2d2db93459cdd03d169d8ef50f622 *R/cxxfunction.R 7e32cd42ac56d4e281a1fe82b38738a7 *R/getDynLib.R b060d5e5093bf71dd36ba4ca26001cac *R/package.skeleton.R 81e1d890da5b85685583318e51823418 *R/utilities.R a2ee040ec35c5f7c11ea23c5ed56b1a8 *README.md 1322de0007dfb535d9d63af446efc9c0 *build/partial.rdb 69cacd38e241c04917b1d64eb030a109 *inst/NEWS.Rd bf1cd515f287eaf01bcb5d241f18f0cf *inst/tinytest/test_cfunction.R 39c248bfe8f8db1ceacb5291ac6c6db3 *inst/tinytest/test_cxxfunction.R 1e3788bc262425b7a03111414b573ecd *inst/tinytest/test_utilities.R f763aeb09afa824ff93e53c61b522424 *man/cfunction.Rd ff7a3754cb0b9ebf56b01bf7b15720e1 *man/cxxfunction.Rd 18b89221354bc68a777c5ea418e6efbe *man/getDynLib.Rd d29d73247a35885fa13c0fa020866986 *man/inline-package.Rd c0c301365881f1f019e9ecae2df2a062 *man/internals.Rd dca9bbdf2e3bd0052d048097c715116e *man/package.skeleton.Rd 04a5e1e601e5da5565578ae818a848f6 *man/plugins.Rd fb2e5ce13ad421d014f5132e45ab3a68 *man/utilities.Rd 46ed7ffcd19192844b681001be5cffcd *tests/tinytest.R inline/inst/0000755000176200001440000000000014053170471012507 5ustar liggesusersinline/inst/tinytest/0000755000176200001440000000000014053170471014372 5ustar liggesusersinline/inst/tinytest/test_cxxfunction.R0000644000176200001440000000135413760272312020130 0ustar liggesusers library(inline) ## basic examples from manual page fx <- cxxfunction(signature(x = "integer", y = "numeric"), "return ScalarReal(INTEGER(x)[0] * REAL(y)[0]);") expect_true(is(fx, "CFunc")) expect_equal(fx(2L, 5), 10) if (!requireNamespace("Rcpp", quietly=TRUE)) exit_file("Need Rcpp for remainder of tests") fx <- cxxfunction(signature(x = "integer", y = "numeric"), "return wrap(as(x) * as(y));", plugin = "Rcpp") expect_true(is(fx, "CFunc")) expect_equal(fx(2L, 5), 10) ## equivalent shorter form using rcpp() fx <- rcpp(signature(x = "integer", y = "numeric"), "return wrap(as(x) * as(y));") expect_true(is(fx, "CFunc")) expect_equal(fx(2L, 5), 10) inline/inst/tinytest/test_utilities.R0000644000176200001440000000557314053170471017601 0ustar liggesuserslibrary(inline) isM1 <- grepl("aarch64-apple", R.version$platform) code <- " int i; for (i = 0; i < *n; i++) x[i] = x[i]*x[i]; " quadfn <- cfunction(signature(n = "integer", x = "numeric"), code, language = "C", convention = ".C") res_known <- list(n = 5L, x = c(1, 4, 9, 16, 25)) expect_identical(quadfn(5, 1:5), res_known) # Saving and restoring the function removes the pointer to the DLL quadfn_path <- file.path(tempdir(), "quadfn.rda") save(quadfn, file = quadfn_path) rm(quadfn) load(quadfn_path) expect_error(quadfn(5, 1:5), "NULL value passed as symbol address") # The DLL is removed by garbage collection gc() expect_false(file.exists(environment(quadfn)$libLFile)) if (isM1) exit_file("Skip remainer") # So we recreate the function and move the DLL to a user defined location quadfn <- cfunction(signature(n = "integer", x = "numeric"), code, language = "C", convention = ".C") moveDLL(quadfn, name = "testname", directory = tempdir()) expect_identical(quadfn(5, 1:5), res_known) expect_error( moveDLL(quadfn, name = "testname", directory = tempdir(), unload = TRUE), "Failed to copy") expect_error( moveDLL(quadfn, name = "testname", directory = tempdir(), unload = TRUE, overwrite = TRUE), "file can not be copied both 'from' and 'to'") # We recreate the function to have a new temporary DLL name quadfn <- cfunction(signature(n = "integer", x = "numeric"), code, language = "C", convention = ".C") expect_identical(quadfn(5, 1:5), res_known) # Now the new path is taken and loaded, but we can unload and overwrite moveDLL(quadfn, name = "testname", directory = tempdir(), unload = TRUE, overwrite = TRUE) expect_identical(quadfn(5, 1:5), res_known) # Now the DLL is not removed by garbage collection gc() expect_true(file.exists(environment(quadfn)$libLFile)) # But we still get the pointer removed when saving and restoring save(quadfn, file = quadfn_path) rm(quadfn) load(quadfn_path) expect_error(quadfn(5, 1:5), "NULL value passed as symbol address") # So we recreate the function again, move the DLL, write and restore quadfn <- cfunction(signature(n = "integer", x = "numeric"), code, language = "C", convention = ".C") moveDLL(quadfn, name = "testname", directory = tempdir(), unload = TRUE, overwrite = TRUE) writeCFunc(quadfn, quadfn_path) quadfn_reloaded <- readCFunc(quadfn_path) expect_identical(quadfn_reloaded(5, 1:5), res_known) # Create a function with a user defined function name in the source code, # save and restore quadfn_named <- cfunction(signature(n = "integer", x = "numeric"), code, language = "C", convention = ".C", name = "quadfn") moveDLL(quadfn_named, name = "quadfn_dll", directory = tempdir(), unload = TRUE, overwrite = TRUE) writeCFunc(quadfn_named, quadfn_path) quadfn_named_reloaded <- readCFunc(quadfn_path) expect_identical(quadfn_named_reloaded(5, 1:5), res_known) expect_true(grepl("quadfn", quadfn_named_reloaded@code)) inline/inst/tinytest/test_cfunction.R0000644000176200001440000000574614053170471017560 0ustar liggesuserslibrary(inline) isSolaris <- Sys.info()[["sysname"]] == "SunOS" n <- 10L x <- 1:10 ## A simple Fortran example - n and x: assumed-size vector code <- " integer i do 1 i=1, n(1) 1 x(i) = x(i)**3 " cubefn <- cfunction(signature(n = "integer", x = "numeric"), code, convention = ".Fortran") res_cube <- list( n = 10L, x = c(1, 8, 27, 64, 125, 216, 343, 512, 729, 1000)) res_1 <- cubefn(n, x) expect_identical(res_cube, res_1) cubefn_named <- cfunction(signature(n = "integer", x = "numeric"), code, convention = ".Fortran", name = "cubefn") expect_identical(cubefn_named(n, x), res_1) expect_true(grepl("cubefn", cubefn_named@code)) ## Same Fortran example - now n is one number code2 <- " integer i do 1 i=1, n 1 x(i) = x(i)**3 " cubefn2 <- cfunction(signature(n = "integer", x = "numeric"), implicit = "none", dim = c("", "(*)"), code2, convention=".Fortran") res_2 <- cubefn2(n, x) expect_identical(res_2, res_cube) ## Same in F95, now x is fixed-size vector (length = n) code3 <- "x = x*x*x" cubefn3 <- cfunction(signature(n = "integer", x = "numeric"), implicit = "none", dim = c("", "(n)"), code3, language="F95") res_3 <- cubefn3(n, x) expect_identical(res_3, res_cube) ## Same example in C code4 <- " int i; for (i = 0; i < *n; i++) x[i] = x[i]*x[i]*x[i]; " cubefn4 <- cfunction(signature(n = "integer", x = "numeric"), code4, language = "C", convention = ".C") res_4 <- cubefn4(n, x) expect_identical(res_4, res_cube) if (isSolaris) exit_file("Skip remainder") ## use of a module in F95 modct <- "module modcts double precision, parameter :: pi = 3.14159265358979 double precision, parameter :: e = 2.71828182845905 end" getconstants <- "x(1) = pi x(2) = e" cgetcts <- cfunction(body = getconstants, module = "modcts", implicit = "none", includes = modct, sig = c(x = "double"), dim = c("(2)"), language = "F95") res_5 <- cgetcts(x = c(1, 2)) expect_equal(res_5$x, c(pi, exp(1)), tolerance = 1e-7) ## Use of .C convention with C code ## Defining two functions, one of which calls the other sigSq <- signature(n = "integer", x = "numeric") codeSq <- " for (int i=0; i < *n; i++) { x[i] = x[i]*x[i]; }" sigQd <- signature(n = "integer", x = "numeric") codeQd <- " squarefn(n, x); squarefn(n, x); " fns <- cfunction( sig = list(squarefn = sigSq, quadfn = sigQd), body = list(codeSq, codeQd), convention = ".C") res_square <- list( n = 10L, x = c(1, 4, 9, 16, 25, 36, 49, 64, 81, 100)) res_quad <- list( n = 10L, x = c(1, 16, 81, 256, 625, 1296, 2401, 4096, 6561, 10000)) res_6_square <- fns[["squarefn"]](n, x) res_6_quad <- fns[["quadfn"]](n, x) expect_identical(res_6_square, res_square) expect_identical(res_6_quad, res_quad) ## Alternative declaration using 'setCMethod' setCMethod(c("squarefn", "quadfn"), list(sigSq, sigQd), list(codeSq, codeQd), convention = ".C") res_7_square <- squarefn(n, x) res_7_quad <- quadfn(n, x) expect_identical(res_7_square, res_square) expect_identical(res_7_quad, res_quad) inline/inst/NEWS.Rd0000644000176200001440000001275214053170471013561 0ustar liggesusers\name{NEWS} \title{News for Package \pkg{inline}} \newcommand{\ghpr}{\href{https://github.com/eddelbuettel/inline/pull/#1}{##1}} \newcommand{\ghit}{\href{https://github.com/eddelbuettel/inline/issues/#1}{##1}} \section{Changes in inline version 0.3.19 (2021-05-25)}{ \itemize{ \item Documentation for \code{moveDLL} was updated and extended (Johannes in \ghpr{22}). \item A few more tests were made conditional the test platform (Dirk in \ghpr{24}). } } \section{Changes in inline version 0.3.18 (2021-05-17)}{ \itemize{ \item The \code{moveDLL} code and tests were updated for changed in R-devel (Johannes in \ghpr{22} fixing \ghit{21}). } } \section{Changes in inline version 0.3.17 (2020-11-30)}{ \itemize{ \item Unit testing is now supported via \pkg{tinytest} (Johannes in \ghpr{15} addressing \ghit{14}). \item CI was updated to use focal and run.sh from r-ci on Travis and GitHub Actions (Dirk) \item The writing and reading of compiled code was refactored and extended (Johannes in \ghpr{16} fixing \ghit{13}). \item Some minor problems related to CRAN checks and tests were corrected (Johannes and Dirk in \ghpr{17}, Johannes in \ghpr{18}, \ghpr{19}, \ghpr{20}). \item Small stylistic updates have been applied to some R and Rd files (Dirk). } } \section{Changes in inline version 0.3.16 (2020-09-06)}{ \itemize{ \item Maintenance updates to README.md standardizing badges (Dirk). \item Maintenance update to Travis CI setup (Dirk). \item Switch to using \code{system2()} for better error diagnostics (Ben Goodrich in \ghpr{12}). } } \section{Changes in inline version 0.3.15 (2018-05-18)}{ \itemize{ \item Correct \code{requireNamespace()} call thanks (Alexander Grueneberg in \ghpr{5}). \item Small simplification to \code{.travis.yml}; also switch to https. \item Use \code{seq_along} instead of \code{seq(along=...)} (Watal M. Iwasaki) in \ghpr{6}). \item Update package manual page using references to \code{DESCRIPTION} file [CRAN request]. \item Minor packaging updates. } } \section{Changes in inline version 0.3.14 (2015-04-11)}{ \itemize{ \item Removed call to \code{Rcpp::RcppLdFlags()} which is no longer needed \item With move of repository to GitHub, added a \code{.travis.yml} file and corresponding entry in \code{.Rbuildignore} \item Replaced calls to \code{require()} with calls to \code{requireNamespace()}; also updated one call \item Much improved support for Fortran and Fortran95 thanks to Karline Soetaert who became a package co-author \item New helper functions \code{writeDynLib} and \code{readDynLib} as well as new methods \code{print} and \code{code} (also by Karline) } } \section{Changes in inline version 0.3.13 (2013-08-08)}{ \itemize{ \item Applied contributed patch by Mikhail Umorin which corrects \code{cfunction()} in the case of a \code{list} of signature and body arguments. } } \section{Changes in inline version 0.3.12 (2013-06-12)}{ \itemize{ \item Align \code{package.skeleton} with the R-devel version of the function which no longer has a \code{NAMESPACE} argument. \item Remove copy of LGPL in source archive as \code{R CMD check} now complains about it. License status continues to be specified in file \code{DESCRIPTION}. } } \section{Changes in inline version 0.3.11 (2013-02-26)}{ \itemize{ \item Fix bug in \code{cfunction} for \code{.C} convention with raw vectors. \item Correct \code{cfunction} to use \code{.Platform$dynlib.ext} as the file extension for the library file (unless on Windows). \item Allow \code{rcpp} wrapper to pass another plugin (as eg RcppArmadillo) } } \section{Changes in inline version 0.3.10 (2012-10-03)}{ \itemize{ \item \code{getDynLib()} error message corrected as suggested by Yasir Suhail \item Added \code{rcpp()} wrapper for \code{cxxfunction()} which sets \code{plugin="Rcpp"} \item Converted NEWS to NEWS.Rd \item New maintainer, after having coordinated releases (along with Romain) since 0.3.5 in June 2010 } } \section{Changes in inline version 0.3.9 (2012-10-02)}{ \itemize{ \item Uncoordinating hijacking of package by CRAN maintainers with a single word change in cfunction.R to prevent an error under an unreleased version of R } } \section{Changes in inline version 0.3.8 (2010-12-07)}{ \itemize{ \item faster \code{cfunction} and \code{cxxfunction} by loading and resolving the routine at \dQuote{compile} time } } \section{Changes in inline version 0.3.7 (2010-11-02)}{ \itemize{ \item fix \code{package.skeleton} for use with just a single function } } \section{Changes in inline version 0.3.6 (2010-07-29)}{ \itemize{ \item compileCode now grabs the error message generated by the compiler and uses it in in the error message } } \section{Changes in inline version 0.3.5 (2010-06-02)}{ \itemize{ \item new R function \code{cxxfunction} to generate an R function with inlined C++ code using the \code{.Call} calling convention. The function was introduced to accomodate the needs of the Rcpp family of packages. \item new R functions \code{getPlugin} and \code{registerPlugin} to manage the plugin system of \code{cxxfunction}. \item The function \code{package.skeleton} (from utils) is made generic and a method is available to generate a package skeleton from a function generated by \code{cfunction} or \code{cxxfunction} } }