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