1# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 2## CFunc is an S4 class derived from 'function'. This inheritance allows objects 3## to behave exactly as functions do, but it provides a slot @code that keeps the 4## source C or Fortran code used to create the inline call 5setClass("CFunc", 6 representation( 7 code="character" 8 ), 9 contains="function" 10) 11 12setClass( "CFuncList", contains = "list" ) 13 14# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 15cfunction <- function(sig=character(), body=character(), includes=character(), otherdefs=character(), 16 language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"), 17 verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), Rcpp=FALSE, 18 cppargs=character(), cxxargs=character(), libargs=character(), 19 dim = NULL, implicit = NULL, module = NULL, name = NULL) { 20 21 if (missing (convention) & !missing(language)) 22 convention <- switch (EXPR = language, "Fortran" = ".Fortran", "F95" = ".Fortran", ".C" = ".C", ObjectiveC = ".Call", "ObjectiveC++" = ".Call", "C++" = ".Call") 23 24 convention <- match.arg(convention) 25 26 if ( missing(language) ) language <- ifelse(convention == ".Fortran", "Fortran", "C++") 27 else language <- match.arg(language) 28 29 language <- switch(EXPR=tolower(language), cpp="C++", f="Fortran", f95="F95", 30 objc="ObjectiveC", objcpp= ,"objc++"="ObjectiveC++", language) 31 32 f <- basename(tempfile()) 33 34 if (is.null(name)) { 35 name <- f 36 } 37 38 if ( !is.list(sig) ) { 39 sig <- list(sig) 40 names(sig) <- name 41 names(body) <- name 42 } 43 44 if( length(sig) != length(body) ) 45 stop("mismatch between the number of functions declared in 'sig' and the number of function bodies provided in 'body'") 46 47 if (is.null(dim)) 48 dim <- as.list(rep("(*)", length(sig))) 49 else { # this assumes fortran style 50 if (!is.list(dim)) 51 dim <- list(dim) 52 if (length(dim) != length(sig)) 53 stop("mismatch between the number of functions declared in 'sig' and the number of dimensions declared in 'dim'") 54 } 55 56 if (Rcpp) { 57 if (!requireNamespace("Rcpp", quietly=TRUE)) 58 stop("Rcpp cannot be loaded, install it or use the default Rcpp=FALSE", call.=FALSE) 59 rcppdir <- system.file("include", package="Rcpp") 60 if (.Platform$OS.type == "windows") rcppdir <- utils::shortPathName(normalizePath(rcppdir)) 61 cxxargs <- c(paste("-I", rcppdir, sep=""), cxxargs) # prepend information from Rcpp 62 } 63 if (length(cppargs) != 0) { 64 args <- paste(cppargs, collapse=" ") 65 if (verbose) cat("Setting PKG_CPPFLAGS to", args, "\n") 66 Sys.setenv(PKG_CPPFLAGS=args) 67 } 68 if (length(cxxargs) != 0) { 69 args <- paste(cxxargs, collapse=" ") 70 if (verbose) cat("Setting PKG_CXXFLAGS to", args, "\n") 71 Sys.setenv(PKG_CXXFLAGS=args) 72 } 73 if (length(libargs) != 0) { 74 args <- paste(libargs, collapse=" ") 75 if (verbose) cat("Setting PKG_LIBS to", args, "\n") 76 Sys.setenv(PKG_LIBS=args) 77 } 78 types <- vector(mode="list", length=length(sig)) 79 ## GENERATE THE CODE 80 for ( i in seq_along(sig) ) { 81 ## C/C++ with .Call convention ********************************************* 82 if ( convention == ".Call" ) { 83 ## include R includes, also error 84 if (i == 1) { 85 code <- ifelse(Rcpp, 86 "#include <Rcpp.h>\n", 87 paste("#include <R.h>\n#include <Rdefines.h>\n", 88 "#include <R_ext/Error.h>\n", sep="")); 89 ## include further includes 90 code <- paste(c(code, includes, ""), collapse="\n") 91 ## include further definitions 92 code <- paste(c(code, otherdefs, ""), collapse="\n") 93 } 94 ## generate C-function sig from the original sig 95 if ( length(sig[[i]]) > 0 ) { 96 funCsig <- paste("SEXP", names(sig[[i]]), collapse=", " ) 97 } 98 else funCsig <- "" 99 funCsig <- paste("SEXP", names(sig)[i], "(", funCsig, ")", sep=" ") 100 ## add C export of the function 101 if ( language == "C++" || language == "ObjectiveC++") 102 code <- paste( code, "extern \"C\" {\n ", funCsig, ";\n}\n\n", sep="") 103 ## OPEN function 104 code <- paste( code, funCsig, " {\n", sep="") 105 ## add code, split lines 106 code <- paste( code, paste(body[[i]], collapse="\n"), sep="") 107 ## CLOSE function, add return and warning in case the user forgot it 108 code <- paste(code, "\n ", 109 ifelse(Rcpp, "Rf_warning", "warning"), 110 "(\"your C program does not return anything!\");\n return R_NilValue;\n}\n", sep=""); 111 } 112 113 ## C/C++ with .C convention ************************************************ 114 else if ( convention == ".C" ) { 115 if (i == 1) { 116 ## include only basic R includes 117 code <- ifelse(Rcpp,"#include <Rcpp.h>\n", "#include <R.h>\n") 118 ## include further includes 119 code <- paste(c(code, includes, ""), collapse="\n") 120 ## include further definitions 121 code <- paste(c(code, otherdefs, ""), collapse="\n") 122 } 123 ## determine function header 124 if ( length(sig[[i]]) > 0 ) { 125 types[[i]] <- pmatch(sig[[i]], c("logical", "integer", "double", "complex", 126 "character", "raw", "numeric"), duplicates.ok = TRUE) 127 if ( any(is.na(types[[i]])) ) stop( paste("Unrecognized type", sig[[i]][is.na(types[[i]])]) ) 128 decls <- c("int *", "int *", "double *", "Rcomplex *", "char **", 129 "unsigned char *", "double *")[ types[[i]] ] 130 funCsig <- paste(decls, names(sig[[i]]), collapse=", ") 131 } 132 else funCsig <- "" 133 funCsig <- paste("void", names(sig)[i], "(", funCsig, ")", sep=" ") 134 if ( language == "C++" || language == "ObjectiveC++" ) 135 code <- paste( code, "extern \"C\" {\n ", funCsig, ";\n}\n\n", sep="") 136 ## OPEN function 137 code <- paste( code, funCsig, " {\n", sep="") 138 ## add code, split lines 139 code <- paste( code, paste(body[[i]], collapse="\n"), sep="") 140 ## CLOSE function 141 code <- paste( code, "\n}\n", sep="") 142 } 143 ## .Fortran convention ***************************************************** 144 else { 145 # old-style fortran requires 6 columns not used 146 lead <- ifelse (language == "Fortran", " ","") 147 if (i == 1) { 148 ## no default includes, include further includes 149 code <- paste(includes, collapse="\n") 150 ## include further definitions 151 code <- paste(c(code, otherdefs, ""), collapse="\n") 152 } 153 ## determine function header 154 if ( length(sig[[i]]) > 0 ) { 155 types[[i]] <- pmatch(sig[[i]], c("logical", "integer", "double", "complex", 156 "character", "raw", "numeric"), duplicates.ok = TRUE) 157 if ( any(is.na(types[[i]])) ) stop( paste("Unrecognized type", sig[[i]][is.na(types[[i]])]) ) 158 if (6 %in% types[[i]]) stop( "raw type unsupported by .Fortran()" ) 159 decls <- c("INTEGER", "INTEGER", "DOUBLE PRECISION", "DOUBLE COMPLEX", 160 "CHARACTER*255", "Unsupported", "DOUBLE PRECISION")[ types[[i]] ] 161 decls <- paste(lead, decls, " ", names(sig[[i]]), dim[[i]], sep="", collapse="\n") 162 funCsig <- paste(names(sig[[i]]), collapse=", ") 163 } 164 else { 165 decls <- "" 166 funCsig <- "" 167 } 168 169 funCsig <- paste(lead,"SUBROUTINE", names(sig)[i], "(", funCsig, ")\n", sep=" ") 170 ## old-style FORTRAN line length restricted to 72 characters 171 if (language == "Fortran") { 172 if ((cl <- nchar(funCsig)) >= 72) { 173 fstring <- substr(funCsig, 72, cl) 174 funCsig <- substr(funCsig, 1, 71) 175 while ((cf <- nchar(fstring)) > 66) { 176 funCsig <- paste(funCsig, "\n &", substr(fstring, 1, 66), sep = "") 177 fstring <- substr(fstring, 67, cf) 178 } 179 if (cf > 0) funCsig <- paste(funCsig, "\n &", fstring, sep = "") 180 funCsig <- paste(funCsig, "\n") 181 } 182 } 183 ## IMPLICIT statement and module use 184 if (is.character(module)) funCsig <- paste(funCsig, lead, "USE ", module, "\n", sep = "") 185 if (is.character(implicit)) funCsig <- paste(funCsig, lead, "IMPLICIT ", implicit, "\n", sep = "") 186 ## OPEN function 187 code <- paste( code, funCsig, decls, "\n", collapse="\n", sep="") 188 ## add code, split lines 189 code <- paste( code, paste(body[[i]], collapse="\n"), sep="") 190 ## CLOSE function 191 code <- paste( code, "\n", lead, "RETURN\n", lead, "END\n\n", sep="") 192 } 193 } ## for along signatures 194 195 ## WRITE AND COMPILE THE CODE 196 libLFile <- compileCode(f, code, language, verbose) 197 198 199 ## SET A FINALIZER TO PERFORM CLEANUP 200 # Make a copy of libLFile, as we may overwrite it later in writeDynLib(), and 201 # we don't want the finalizer to remove the new libLFile 202 libLFile_orig <- libLFile 203 cleanup <- function(env) { 204 if ( f %in% names(getLoadedDLLs()) ) dyn.unload(libLFile_orig) 205 unlink(libLFile_orig) 206 } 207 reg.finalizer(environment(), cleanup, onexit=TRUE) 208 209 res <- vector("list", length(sig)) 210 names(res) <- names(sig) 211 212 ## GENERATE R FUNCTIONS 213 for ( i in seq_along(sig) ) { 214 ## Create new objects of class CFunc, each containing the code of ALL inline 215 ## functions. This will be used to recompile the whole shared lib when needed 216 res[[i]] <- new("CFunc", code = code) 217 218 ## this is the skeleton of the function, the external call is added below using 'body' 219 ## important here: all variables are kept in the local environment 220 fn <- function(arg) { 221 NULL 222 } 223 224 DLL <- dyn.load( libLFile ) 225 226 ## Modify the function formals to give the right argument list 227 args <- formals(fn)[ rep(1, length(sig[[i]])) ] 228 names(args) <- names(sig[[i]]) 229 formals(fn) <- args 230 231 ## create .C/.Call function call that will be added to 'fn' 232 if (convention == ".Call") { 233 body <- quote( CONVENTION("EXTERNALNAME", ARG) )[ c(1:2, rep(3, length(sig[[i]]))) ] 234 for ( j in seq_along(sig[[i]]) ) body[[j+2]] <- as.name(names(sig[[i]])[j]) 235 } 236 else { 237 body <- quote( CONVENTION("EXTERNALNAME", as.logical(ARG), as.integer(ARG), 238 as.double(ARG), as.complex(ARG), as.character(ARG), 239 as.raw(ARG), as.double(ARG)) )[ c(1:2,types[[i]]+2) ] 240 names(body) <- c( NA, "", names(sig[[i]]) ) 241 for ( j in seq_along(sig[[i]]) ) body[[j+2]][[2]] <- as.name(names(sig[[i]])[j]) 242## OLD VERSION -- does not work for lists of functions 243# body <- quote( CONVENTION("EXTERNALNAME", as.logical(ARG), as.integer(ARG), 244# as.double(ARG), as.complex(ARG), as.character(ARG), 245# as.raw(ARG), as.double(ARG)) )[ c(1:2,types+2) ] 246# names(body) <- c( NA, "", names(sig[[i]]) ) 247# for ( j in seq(along = sig[[i]]) ) body[[j+2]][[2]] <- as.name(names(sig[[i]])[j]) 248 } 249 body[[1]] <- get(convention) 250 body[[2]] <- getNativeSymbolInfo( names(sig)[i], DLL )$address 251 ## update the body of 'fn' 252 body(fn) <- body 253 ## set fn as THE function in CFunc of res[[i]] 254 res[[i]]@.Data <- fn 255 } 256 257 ## OUTPUT PROGRAM CODE IF DESIRED 258 if ( verbose ) { 259 cat("Program source:\n") 260 lines <- strsplit(code, "\n") 261 for ( i in 1:length(lines[[1]]) ) 262 cat(format(i,width=3), ": ", lines[[1]][i], "\n", sep="") 263 } 264 265 ## Remove unnecessary objects from the local environment 266 remove(list = c("args", "body", "fn", "funCsig", "i", "includes", "j")) 267 268 ## RETURN THE FUNCTION 269 if (length(res) == 1 && names(res) == name) return( res[[1]] ) 270 else return( new( "CFuncList", res ) ) 271} 272 273# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 274compileCode <- function(f, code, language, verbose) { 275 wd = getwd() 276 on.exit(setwd(wd)) 277 ## Prepare temp file names 278 extension <- switch(language, "C++"=".cpp", C=".c", Fortran=".f", F95=".f95", 279 ObjectiveC=".m", "ObjectiveC++"=".mm") 280 libCFile <- file.path(tempdir(), paste0(f, extension)) 281 libLFile <- file.path(tempdir(), paste0(f, .Platform$dynlib.ext)) 282 283 ## Write the code to the temp file for compilation 284 write(code, libCFile) 285 286 ## Compile the code using the running version of R if several available 287 if ( file.exists(libLFile) ) file.remove( libLFile ) 288 289 setwd(dirname(libCFile)) 290 errfile <- paste( basename(libCFile), ".err.txt", sep = "" ) 291 cmd <- paste0(R.home(component="bin"), "/R") 292 if ( verbose ) system2(cmd, args = paste(" CMD SHLIB --dry-run", basename(libCFile))) 293 compiled <- system2(cmd, args = paste(" CMD SHLIB", basename(libCFile)), 294 stdout = FALSE, stderr = errfile) 295 errmsg <- readLines( errfile ) 296 unlink( errfile ) 297 298 if ( !file.exists(libLFile) ) { 299 cat("\nERROR(s) during compilation: source code errors or compiler configuration errors!\n") 300 if ( !verbose ) system2(cmd, args = paste(" CMD SHLIB --dry-run --preclean", basename(libCFile))) 301 cat("\nProgram source:\n") 302 code <- strsplit(code, "\n") 303 for (i in 1:length(code[[1]])) cat(format(i,width=3), ": ", code[[1]][i], "\n", sep="") 304 cat("\nCompilation ERROR, function(s)/method(s) not created!\n") 305 if ( sum(nchar(errmsg)) > getOption("warning.length") ) stop(tail(errmsg)) 306 else stop(errmsg) 307 } 308 return( libLFile ) 309} 310