1 2plugins <- new.env() 3 4plugins[["default"]] <- function() { 5 includes = ' 6#include <R.h> 7#include <Rdefines.h> 8#include <R_ext/Error.h> 9' 10 list(includes = includes, 11 body = function(x) { 12 paste0(x, 13 '\nRf_warning("your C++ program does not return anything");', 14 '\nreturn R_NilValue;')}) 15} 16 17registerPlugin <- function(name, plugin) { 18 plugins[[ name ]] <- plugin 19} 20 21getPlugin <- function(name, ...) { 22 if (name %in% ls(plugins)) { 23 plugins[[ name ]](...) 24 } else if (sprintf("package:%s", name) %in% search() || requireNamespace(name, quietly = TRUE)) { 25 plugin <- get("inlineCxxPlugin", asNamespace(name)) 26 if (is.null(plugin)) { 27 stop(sprintf("package '%s' does not define an inline plugin", name)) 28 } 29 registerPlugin(name, plugin) 30 plugin(...) 31 } else { 32 stop(sprintf("could not find plugin '%s'", name)) 33 } 34} 35 36paste0 <- function(...) paste(..., sep="") 37 38addLineNumbers <- function(code) { 39 code <- strsplit(paste(code, collapse = "\n" ), "\n")[[1]] 40 sprintf("%4d : %s", 1:length(code), code) 41} 42 43cxxfunction <- function(sig = character(), body = character(), 44 plugin = "default", includes = "", 45 settings = getPlugin(plugin), 46 ..., verbose = FALSE) { 47 f <- basename(tempfile()) 48 49 if (!is.list(sig)) { 50 sig <- list(sig) 51 names(sig) <- f 52 if (!length(body)) body <- "" 53 names(body) <- f 54 } 55 if (length(sig) != length(body)) 56 stop("mismatch between the number of functions declared in 'sig' and the number of function bodies provided in 'body'") 57 58 signature <- lapply( sig, function(x) { 59 if (!length(x)){ 60 "" 61 } else { 62 paste(sprintf("SEXP %s", names(x) ), collapse = ", ") 63 } 64 }) 65 66 decl <- lapply(1:length(sig) , function(index) { 67 sprintf('SEXP %s( %s) ;', names(signature)[index], signature[[index]]) 68 } ) 69 70 def <- lapply(1:length(sig), function(index){ 71 sprintf('SEXP %s(%s) {\n%s\n}', 72 names(signature)[index], 73 signature[[index]], 74 if (is.null(settings$body)) body[[index]] else settings$body(body[[index]]) ) 75 }) 76 77 settings_includes <- if (is.null(settings$includes)) "" else paste(settings$includes, collapse = "\n") 78 79 code <- sprintf(' 80// includes from the plugin 81%s 82 83// user includes 84%s 85 86// declarations 87extern "C" { 88%s 89} 90 91// definition 92%s 93', 94 settings_includes, 95 paste(includes, collapse = "\n"), 96 paste(decl, collapse = "\n"), 97 paste(def, collapse = "\n")) 98 99 100 if (!is.null(env <- settings$env)) { 101 do.call(Sys.setenv, env) 102 if (isTRUE(verbose)) { 103 cat(" >> setting environment variables: \n") 104 writeLines(sprintf("%s = %s", names(env), env)) 105 } 106 } 107 108 LinkingTo <- settings$LinkingTo 109 if (!is.null(LinkingTo)) { 110 paths <- find.package(LinkingTo, quiet=TRUE) 111 if (length(paths)) { 112 flag <- paste(paste0('-I"', paths, '/include"'), collapse = " ") 113 Sys.setenv(CLINK_CPPFLAGS = flag) 114 if (isTRUE(verbose)) { 115 cat(sprintf("\n >> LinkingTo : %s\n", paste(LinkingTo, collapse = ", "))) 116 cat("CLINK_CPPFLAGS = ", flag, "\n\n") 117 } 118 } 119 120 } 121 122 if (isTRUE(verbose)) { 123 writeLines(" >> Program source :\n") 124 writeLines(addLineNumbers(code)) 125 } 126 127 language <- "C++" 128 129 ## WRITE AND COMPILE THE CODE 130 libLFile <- compileCode(f, code, language = language, verbose = verbose) 131 132 ## SET A FINALIZER TO PERFORM CLEANUP 133 cleanup <- function(env) { 134 if (f %in% names(getLoadedDLLs())) dyn.unload(libLFile) 135 unlink(libLFile) 136 } 137 reg.finalizer(environment(), cleanup, onexit=TRUE) 138 139 ## Create new objects of class CFunc, each containing the code of ALL inline 140 ## functions. This will be used to recompile the whole shared lib when needed 141 res <- vector("list", length(sig)) 142 names(res) <- names(sig) 143 res <- new("CFuncList", res) 144 145 DLL <- dyn.load(libLFile) 146 147 for (i in seq_along(sig)) { 148 res[[i]] <- new("CFunc", code = code) 149 150 fn <- function(arg) { 151 NULL 152 } 153 154 ## Modify the function formals to give the right argument list 155 args <- formals(fn)[ rep(1, length(sig[[i]])) ] 156 names(args) <- names(sig[[i]]) 157 formals(fn) <- args 158 159 ## create .Call function call that will be added to 'fn' 160 body <- quote(.Call(EXTERNALNAME, ARG))[ c(1:2, rep(3, length(sig[[i]]))) ] 161 for (j in seq_along(sig[[i]])) body[[j+2]] <- as.name(names(sig[[i]])[j]) 162 163 body[[1L]] <- .Call 164 body[[2L]] <- getNativeSymbolInfo(names(sig)[[i]], DLL)$address 165 ## update the body of 'fn' 166 body(fn) <- body 167 ## set fn as THE function in CFunc of res[[i]] 168 res[[i]]@.Data <- fn 169 } 170 171 ## clear the environment 172 rm(j) 173 convention <- ".Call" 174 if (identical(length(sig), 1L)) res[[1L]] else res 175} 176 177rcpp <- function(..., plugin="Rcpp") cxxfunction(..., plugin=plugin) 178