[Rcpp-commits] r4106 - in pkg/Rcpp: . R inst/include/Rcpp/iostream src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Dec 6 14:20:31 CET 2012
Author: jjallaire
Date: 2012-12-06 14:20:30 +0100 (Thu, 06 Dec 2012)
New Revision: 4106
Modified:
pkg/Rcpp/ChangeLog
pkg/Rcpp/R/Attributes.R
pkg/Rcpp/inst/include/Rcpp/iostream/Rstreambuf.h
pkg/Rcpp/src/Attributes.cpp
pkg/Rcpp/src/AttributesGen.cpp
pkg/Rcpp/src/AttributesParser.cpp
Log:
revert DOS newlines; define RCPP_NO_SUGAR
Modified: pkg/Rcpp/ChangeLog
===================================================================
--- pkg/Rcpp/ChangeLog 2012-12-06 13:10:29 UTC (rev 4105)
+++ pkg/Rcpp/ChangeLog 2012-12-06 13:20:30 UTC (rev 4106)
@@ -1,3 +1,11 @@
+2012-12-06 JJ Allaire <jj at rstudio.org>
+
+ * R/Attributes.R: revert DOS newlines
+ * src/Attributes.cpp: revert DOS newlines; define RCPP_NO_SUGAR
+ * src/AttributesGen.cpp: revert DOS newlines
+ * src/AttributesParser.cpp: revert DOS newlines; define RCPP_NO_SUGAR
+ * include/Rcpp/iostream/Rstreambuf.h: revert DOS newlines
+
2012-12-06 Dirk Eddelbuettel <edd at debian.org>
* src/exceptions.cpp: Added include of cstdlib to compile
Modified: pkg/Rcpp/R/Attributes.R
===================================================================
--- pkg/Rcpp/R/Attributes.R 2012-12-06 13:10:29 UTC (rev 4105)
+++ pkg/Rcpp/R/Attributes.R 2012-12-06 13:20:30 UTC (rev 4106)
@@ -1,723 +1,723 @@
-# Copyright (C) 2012 JJ Allaire, Dirk Eddelbuettel and Romain Francois
-#
-# This file is part of Rcpp.
-#
-# Rcpp is free software: you can redistribute it and/or modify it
-# under the terms of the GNU General Public License as published by
-# the Free Software Foundation, either version 2 of the License, or
-# (at your option) any later version.
-#
-# Rcpp is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
-
-
-# Source C++ code from a file
-sourceCpp <- function(file = "",
- code = NULL,
- env = globalenv(),
- rebuild = FALSE,
- showOutput = verbose,
- verbose = getOption("verbose")) {
-
- # resolve code into a file if necessary
- if (!missing(code)) {
- file <- tempfile(fileext = ".cpp")
- con <- file(file, open = "w")
- writeLines(code, con)
- close(con)
- }
-
- # resolve the file path
- file <- normalizePath(file, winslash = "/")
-
- # get the context (does code generation as necessary)
- context <- .Call("sourceCppContext", PACKAGE="Rcpp", file, code, .Platform)
-
- # perform a build if necessary
- if (context$buildRequired || rebuild) {
-
- # print output for verbose mode
- if (verbose)
- .printVerboseOutput(context)
-
- # variables used to hold completed state (passed to completed hook)
- succeeded <- FALSE
- output <- NULL
-
- # build dependency list
- depends <- .getSourceCppDependencies(context$depends, file)
-
- # validate packages (error if package not found)
- .validatePackages(depends, context$cppSourceFilename)
-
- # temporarily modify environment for the build
- envRestore <- .setupBuildEnvironment(depends, file)
-
- # temporarily setwd to build directory
- cwd <- getwd()
- setwd(context$buildDirectory)
-
- # call the onBuild hook. note that this hook should always be called
- # after .setupBuildEnvironment so subscribers are able to examine
- # the build environment
- fromCode <- !missing(code)
- if (!.callBuildHook(context$cppSourcePath, fromCode, showOutput)) {
- .restoreEnvironment(envRestore)
- setwd(cwd)
- return (invisible(NULL))
- }
-
- # on.exit handler calls hook and restores environment and working dir
- on.exit({
- if (!succeeded)
- .showBuildFailureDiagnostics()
- .callBuildCompleteHook(succeeded, output)
- setwd(cwd)
- .restoreEnvironment(envRestore)
- })
-
- # unload and delete existing dylib if necessary
- if (file.exists(context$dynlibPath)) {
- try(silent=T, dyn.unload(context$dynlibPath))
- file.remove(context$dynlibPath)
- }
-
- # prepare the command (output if we are in showOutput mode)
- cmd <- paste(R.home(component="bin"), .Platform$file.sep, "R ",
- "CMD SHLIB ",
- "-o ", shQuote(context$dynlibFilename), " ",
- ifelse(rebuild, "--preclean ", ""),
- shQuote(context$cppSourceFilename), sep="")
- if (showOutput)
- cat(cmd, "\n")
-
- # execute the build -- suppressWarnings b/c when showOutput = FALSE
- # we are going to explicitly check for an error and print the output
- result <- suppressWarnings(system(cmd, intern = !showOutput))
-
- # check build results
- if(!showOutput) {
- # capture output
- output <- result
- attributes(output) <- NULL
- # examine status
- status <- attr(result, "status")
- if (!is.null(status)) {
- cat(result, "\n")
- succeeded <- FALSE
- stop("Error ", status, " occurred building shared library.")
- } else {
- succeeded <- TRUE
- }
- }
- else if (!identical(as.character(result), "0")) {
- succeeded <- FALSE
- stop("Error ", result, " occurred building shared library.")
- } else {
- succeeded <- TRUE
- }
- }
- else {
- if (verbose)
- cat("\nNo rebuild required (use rebuild = TRUE to ",
- "force a rebuild)\n\n", sep="")
- }
-
- # load the module if we have exported functions (else there is no module)
- if (length(context$exportedFunctions) > 0) {
-
- # remove existing objects of the same name from the environment
- exports <- context$exportedFunctions
- removeObjs <- exports[exports %in% ls(envir = env, all.names = T)]
- remove(list = removeObjs, envir = env)
-
- # source the R script
- scriptPath <- file.path(context$buildDirectory, context$rSourceFilename)
- source(scriptPath, local = env)
- } else if (getOption("rcpp.warnNoExports", default=TRUE)) {
- warning("No Rcpp::export attributes found in source")
- }
-
- # source the embeddedR
- if (length(context$embeddedR) > 0) {
- srcConn <- textConnection(context$embeddedR)
- source(file=srcConn, echo=TRUE)
- }
-
- # return (invisibly) a list of exported functions
- invisible(context$exportedFunctions)
-}
-
-# Define a single C++ function
-cppFunction <- function(code,
- depends = character(),
- includes = character(),
- env = parent.frame(),
- rebuild = FALSE,
- showOutput = verbose,
- verbose = getOption("verbose")) {
-
- # generate required scaffolding
- if (!is.null(depends) && length(depends) > 0) {
- depends <- paste(depends, sep=", ")
- scaffolding <- paste("// [[Rcpp::depends(", depends, ")]]", sep="")
- scaffolding <- c(scaffolding, "", .linkingToIncludes(depends, FALSE),
- recursive=T)
- }
- else {
- scaffolding <- "#include <Rcpp.h>"
- }
- scaffolding <- c(scaffolding,
- "",
- "using namespace Rcpp;",
- "",
- includes,
- "// [[Rcpp::export]]",
- recursive = T)
-
- # prepend scaffolding to code
- code <- paste(c(scaffolding, code, recursive = T), collapse="\n")
-
- # print the generated code if we are in verbose mode
- if (verbose) {
- cat("\nGenerated code for function definition:",
- "\n--------------------------------------------------------\n\n")
- cat(code)
- cat("\n")
- }
-
- # source cpp into specified environment. if env is set to NULL
- # then create a new one (the caller can get a hold of the function
- # via the return value)
- if (is.null(env))
- env <- new.env()
- exported <- sourceCpp(code = code,
- env = env,
- rebuild = rebuild,
- showOutput = showOutput,
- verbose = verbose)
-
- # verify that a single function was exported and return it
- if (length(exported) == 0)
- stop("No function definition found")
- else if (length(exported) > 1)
- stop("More than one function definition")
- else {
- functionName <- exported[[1]]
- invisible(get(functionName, env))
- }
-}
-
-# Evaluate a simple c++ expression
-evalCpp <- function(code,
- depends = character(),
- includes = character(),
- rebuild = FALSE,
- showOutput = verbose,
- verbose = getOption( "verbose" ) ){
-
-
- code <- sprintf( "SEXP get_value(){ return wrap( %s ) ; }", code )
- env <- new.env()
- cppFunction(code, depends = depends, includes = includes, env = env,
- rebuild = rebuild, showOutput = showOutput, verbose = verbose )
- fun <- env[["get_value"]]
- fun()
-}
-
-areMacrosDefined <- function(names,
- depends = character(),
- includes = character(),
- rebuild = FALSE,
- showOutput = verbose,
- verbose = getOption( "verbose" ) ){
-
-
- code <- sprintf( '
- LogicalVector get_value(){
-
- return LogicalVector::create(
- %s
- ) ;
- }',
-
- paste( sprintf( ' _["%s"] =
- #if defined(%s)
- true
- #else
- false
- #endif
- ', names, names ), collapse = ",\n" )
- )
- env <- new.env()
- cppFunction(code, depends = depends, includes = includes, env = env,
- rebuild = rebuild, showOutput = showOutput, verbose = verbose )
- fun <- env[["get_value"]]
- fun()
-}
-
-# Scan the source files within a package for attributes and generate code
-# based on the attributes.
-compileAttributes <- function(pkgdir = ".", verbose = getOption("verbose")) {
-
- # verify this is a package and read the DESCRIPTION to get it's name
- pkgdir <- normalizePath(pkgdir, winslash = "/")
- descFile <- file.path(pkgdir,"DESCRIPTION")
- if (!file.exists(descFile))
- stop("pkgdir must refer to the directory containing an R package")
- DESCRIPTION <- read.dcf(descFile, all = TRUE)
- pkgname <- DESCRIPTION$Package
-
- # determine source directory
- srcDir <- file.path(pkgdir, "src")
- if (!file.exists(srcDir))
- return (FALSE)
-
- # create R directory if it doesn't already exist
- rDir <- file.path(pkgdir, "R")
- if (!file.exists(rDir))
- dir.create(rDir)
-
- # get a list of all source files
- cppFiles <- list.files(srcDir, pattern=glob2rx("*.c*"))
-
- # derive base names (will be used for modules)
- cppFileBasenames <- tools:::file_path_sans_ext(cppFiles)
-
- # expend them to their full paths
- cppFiles <- file.path(srcDir, cppFiles)
- cppFiles <- normalizePath(cppFiles, winslash = "/")
-
- # generate the includes list based on LinkingTo. Specify plugins-only
- # because we only need as/wrap declarations
- includes <- .linkingToIncludes(DESCRIPTION$LinkingTo, TRUE)
-
- # generate exports
- invisible(.Call("compileAttributes", PACKAGE="Rcpp",
- pkgdir, pkgname, cppFiles, cppFileBasenames,
- includes, verbose, .Platform))
-}
-
-
-# Take an empty function body and connect it to the specified external symbol
-sourceCppFunction <- function(func, dll, symbol) {
-
- args <- names(formals(func))
-
- body <- quote( .Call( EXTERNALNAME, ARG ) )[ c(1:2, rep(3, length(args))) ]
-
- for (i in seq(along = args))
- body[[i+2]] <- as.symbol(args[i])
-
- body[[1L]] <- .Call
- body[[2L]] <- getNativeSymbolInfo(symbol, dll)$address
-
- body(func) <- body
-
- func
-}
-
-
-# Print verbose output
-.printVerboseOutput <- function(context) {
-
- cat("\nGenerated extern \"C\" functions",
- "\n--------------------------------------------------------\n")
- cat(context$generatedCpp, sep="")
-
- cat("\nGenerated R .Call bindings",
- "\n-------------------------------------------------------\n\n")
- cat(readLines(file.path(context$buildDirectory,
- context$rSourceFilename)),
- sep="\n")
-
- cat("\nBuilding shared library",
- "\n--------------------------------------------------------\n",
- "\nDIR: ", context$buildDirectory, "\n\n", sep="")
-}
-
-# Add LinkingTo dependencies if the sourceFile is in a package
-.getSourceCppDependencies <- function(depends, sourceFile) {
-
- # If the source file is in a package then simulate it being built
- # within the package by including it's LinkingTo dependencies,
- # the src directory (.), and the inst/include directory
- if (.isPackageSourceFile(sourceFile)) {
- descFile <- file.path(dirname(sourceFile), "..", "DESCRIPTION")
- DESCRIPTION <- read.dcf(descFile, all = TRUE)
- linkingTo <- .parseLinkingTo(DESCRIPTION$LinkingTo)
- unique(c(depends, linkingTo))
- } else {
- depends
- }
-}
-
-
-# Check whether a source file is in a package
-.isPackageSourceFile <- function(sourceFile) {
- file.exists(file.path(dirname(sourceFile), "..", "DESCRIPTION"))
-}
-
-# Error if a package is not currently available
-.validatePackages <- function(depends, sourceFilename) {
- unavailable <- depends[!depends %in% .packages(all.available=TRUE)]
- if (length(unavailable) > 0) {
- stop(paste("Package '", unavailable[[1]], "' referenced from ",
- "Rcpp::depends in source file ",
- sourceFilename, " is not available.",
- sep=""),
- call. = FALSE)
- }
-}
-
-
-# Get the inline plugin for the specified package (return NULL if none found)
-.getInlinePlugin <- function(package) {
- tryCatch(get("inlineCxxPlugin", asNamespace(package)),
- error = function(e) NULL)
-}
-
-# Setup the build environment based on the specified dependencies. Returns an
-# opaque object that can be passed to .restoreEnvironment to reverse whatever
-# changes that were made
-.setupBuildEnvironment <- function(depends, sourceFile) {
-
- # discover dependencies
- buildEnv <- list()
- linkingToPackages <- c("Rcpp")
- for (package in depends) {
-
- # add a LinkingTo for this package
- linkingToPackages <- unique(c(linkingToPackages, package))
-
- # see if the package exports a plugin
- plugin <- .getInlinePlugin(package)
- if (!is.null(plugin)) {
-
- # get the plugin settings
- settings <- plugin()
-
- # merge environment variables
- pluginEnv <- settings$env
- for (name in names(pluginEnv)) {
- # if it doesn't exist already just set it
- if (is.null(buildEnv[[name]])) {
- buildEnv[[name]] <- pluginEnv[[name]]
- }
- # if it's not identical then append
- else if (!identical(buildEnv[[name]],
- pluginEnv[[name]])) {
- buildEnv[[name]] <- paste(buildEnv[[name]],
- pluginEnv[[name]]);
- }
- else {
- # it already exists and it's the same value, this
- # likely means it's a flag-type variable so we
- # do nothing rather than appending it
- }
- }
-
- # capture any LinkingTo elements defined by the plugin
- linkingToPackages <- unique(c(linkingToPackages,
- settings$LinkingTo))
- }
- }
-
- # if there is no buildEnv from a plugin then use the Rcpp plugin
- if (length(buildEnv) == 0) {
- buildEnv <- Rcpp:::inlineCxxPlugin()$env
- } else {
- # we are using a plugin -- confirm that the plugin includes the Rcpp
- # PKG_LIBS and if it doesn't then add them
- pkgLibs <- buildEnv$PKG_LIBS
- rcppLibs <- Rcpp:::RcppLdFlags()
- if (is.null(pkgLibs) || !grepl(rcppLibs, pkgLibs, fixed = TRUE))
- buildEnv$PKG_LIBS <- paste(pkgLibs, rcppLibs)
- }
-
- # set CLINK_CPPFLAGS based on the LinkingTo dependencies
- buildEnv$CLINK_CPPFLAGS <- .buildClinkCppFlags(linkingToPackages)
-
- # if the source file is in a package then add standard package
- # include directories
- if (.isPackageSourceFile(sourceFile)) {
- srcDir <- dirname(sourceFile)
- incDir <- file.path(dirname(sourceFile), "..", "inst", "include")
- buildEnv$CLINK_CPPFLAGS <- paste(buildEnv$CLINK_CPPFLAGS,
- paste0('-I"', c(srcDir, incDir), '"'),
- collapse=" ")
- }
-
- # add cygwin message muffler
- buildEnv$CYGWIN = "nodosfilewarning"
-
- # create restore list
- restore <- list()
- for (name in names(buildEnv))
- restore[[name]] <- Sys.getenv(name, unset = NA)
-
- # set environment variables
- do.call(Sys.setenv, buildEnv)
-
- # return restore list
- return (restore)
-}
-
-# Build CLINK_CPPFLAGS from include directories of LinkingTo packages
-.buildClinkCppFlags <- function(linkingToPackages) {
- pkgCxxFlags <- NULL
- for (package in linkingToPackages) {
- packagePath <- find.package(package, NULL, quiet=TRUE)
- pkgCxxFlags <- paste(pkgCxxFlags,
- paste0('-I"', packagePath, '/include"'),
- collapse=" ")
- }
- return (pkgCxxFlags)
-}
-
-.restoreEnvironment <- function(restore) {
- # variables to reset
- setVars <- restore[!is.na(restore)]
- if (length(setVars))
- do.call(Sys.setenv, setVars)
-
- # variables to remove
- removeVars <- names(restore[is.na(restore)])
- if (length(removeVars))
- Sys.unsetenv(removeVars)
-}
-
-
-# Call the onBuild hook. This hook is provided so that external tools
-# can perform processing (e.g. lint checking or other diagnostics) prior
-# to the execution of a build). The showOutput flag is there to inform the
-# subscriber whether they'll be getting output in the onBuildComplete hook
-# or whether it will need to be scraped from the console (for verbose=TRUE)
-# The onBuild hook is always called from within the temporary build directory
-.callBuildHook <- function(file, fromCode, showOutput) {
-
- for (fun in .getHooksList("sourceCpp.onBuild")) {
-
- if (is.character(fun))
- fun <- get(fun)
-
- # allow the hook to cancel the build (errors in the hook explicitly
- # do not cancel the build since they are unexpected bugs)
- continue <- tryCatch(fun(file, fromCode, showOutput),
- error = function(e) TRUE)
-
- if (!continue)
- return (FALSE)
- }
-
- return (TRUE)
-}
-
-# Call the onBuildComplete hook. This hook is provided so that external tools
-# can do analysis of build errors and (for example) present them in a
-# navigable list. Note that the output parameter will be NULL when showOutput
-# is TRUE. Tools can try to scrape the output from the console (in an
-# implemenentation-dependent fashion) or can simply not rely on output
-# processing in that case (since the user explicitly asked for output to be
-# printed to the console). The onBuildCompleted hook is always called within
-# the temporary build directory.
-.callBuildCompleteHook <- function(succeeded, output) {
-
- # Call the hooks in reverse order to align sequencing with onBuild
- for (fun in .getHooksList("sourceCpp.onBuildComplete")) {
-
- if (is.character(fun))
- fun <- get(fun)
-
- try(fun(succeeded, output))
- }
-}
-
-# The value for getHooks can be a single function or a list of functions,
-# This function ensures that the result can always be processed as a list
-.getHooksList <- function(name) {
- hooks <- getHook(name)
- if (!is.list(hooks))
- hooks <- list(hooks)
- hooks
-}
-
-
-# Generate list of includes based on LinkingTo. The pluginsOnly parameter
-# to distinguish the case of capturing all includes needed for a compiliation
-# (e.g. cppFunction) verses only needing to capture as/wrap converters which
-# is the case for generation of shims (RcppExports.cpp) and Rcpp::interfaces
-# package header files.
-.linkingToIncludes <- function(linkingTo, pluginsOnly) {
-
- # This field can be NULL or empty -- in that case just return Rcpp.h
- if (is.null(linkingTo) || !nzchar(linkingTo))
- return (c("#include <Rcpp.h>"))
-
- # Look for Rcpp inline plugins within the list or LinkedTo packages
- include.before <- character()
- include.after <- character()
- linkingToPackages <- .parseLinkingTo(linkingTo)
- for (package in linkingToPackages) {
-
- # We already handle Rcpp internally
- if (identical(package, "Rcpp"))
- next
-
- # see if there is a plugin that we can extract includes from
- plugin <- .getInlinePlugin(package)
- if (!is.null(plugin)) {
- includes <- .pluginIncludes(plugin)
- if (!is.null(includes)) {
- include.before <- c(include.before, includes$before)
- include.after <- c(include.after, includes$after)
- }
- }
- # otherwise check for standard Rcpp::interfaces generated include
- else if (!pluginsOnly) {
- pkgPath <- find.package(package, NULL, quiet=TRUE)
- pkgHeader <- paste(package, ".h", sep="")
- pkgHeaderPath <- file.path(pkgPath, "include", pkgHeader)
- if (file.exists(pkgHeaderPath)) {
- pkgInclude <- paste("#include <", pkgHeader, ">", sep="")
- include.after <- c(include.after, pkgInclude)
- }
- }
- }
-
- # return the includes
- c(include.before, "#include <Rcpp.h>", include.after)
-}
-
-# Analyze the plugin's includes field to determine include.before and
-# include.after. We are ONLY interested in plugins that work with Rcpp since
-# the only types we need from includes are as/wrap marshallers. Therefore,
-# we verify that the plugin was created using Rcpp.plugin.maker and then
-# use that assumption to correctly extract include.before and include.after
-.pluginIncludes <- function(plugin) {
-
- # First determine the standard suffix of an Rcpp plugin by calling
- # Rcpp.plugin.maker. If the plugin$includes has this suffix we know
- # it's an Rcpp plugin
- token <- "include_after_token"
- stockRcppPlugin <- Rcpp:::Rcpp.plugin.maker(include.after=token)
- includes <- stockRcppPlugin()$includes
- suffix <- strsplit(includes, token)[[1]][[2]]
-
- # now ask the plugin for it's includes, ensure that the plugin includes
- # are not null, and verify they have the Rcpp suffix before proceeding
- pluginIncludes <- plugin()$includes
- if (is.null(pluginIncludes))
- return (NULL)
- if (!grepl(suffix, pluginIncludes))
- return (NULL)
-
- # strip the suffix then split on stock Rcpp include to get before and after
- pluginIncludes <- strsplit(pluginIncludes, suffix)[[1]][[1]]
- pluginIncludes <- strsplit(pluginIncludes, c("#include <Rcpp.h>"))[[1]]
-
- # extract before and after and nix empty lines
- before <- pluginIncludes[[1]]
- before <- strsplit(before, "\n")[[1]]
- before <- before[nzchar(before)]
- after <- pluginIncludes[[2]]
- after <- strsplit(after, "\n")[[1]]
- after <- after[nzchar(after)]
-
- # return before and after
- list(before = before, after = after)
-}
-
-# Parse a LinkingTo field into a character vector
-.parseLinkingTo <- function(linkingTo) {
-
- if (is.null(linkingTo))
- return (character())
-
- linkingTo <- strsplit(linkingTo, "\\s*\\,")[[1]]
- gsub("\\s", "", linkingTo)
-}
-
-# show diagnostics for failed builds
-.showBuildFailureDiagnostics <- function() {
-
- # RStudio does it's own diagnostics so only do this for other environments
- if (nzchar(Sys.getenv("RSTUDIO")))
- return();
-
- # if we can't call R CMD SHLIB then notify the user they should
- # install the appropriate development tools
- if (!.checkDevelTools()) {
- msg <- paste("\nWARNING: The tools required to build C++ code for R ",
- "were not found.\n\n", sep="")
- sysName <- Sys.info()[['sysname']]
- if (identical(sysName, "Windows")) {
-
- # different message depending on whether Rtools is installed
- key <- NULL
- try(key <- utils::readRegistry("SOFTWARE\\R-core\\Rtools",
- hive = "HLM",
- view = "32-bit"),
- silent = TRUE)
-
- if (!is.null(key) && !is.null(key$`Current Version`)) {
- msg <- paste(msg, "Rtools appears to be installed however you ",
- "may not have updated the PATH.\n",
- "Please run the Rtools installer and follow ",
- "the instructions for updating\n",
- "the system PATH during installation.\n",
- sep="")
- } else {
- msg <- paste(msg, "Please download and install the appropriate ",
- "version of Rtools:\n\n",
- "http://cran.r-project.org/bin/windows/Rtools/\n",
- sep="");
- }
- } else if (identical(sysName, "Darwin")) {
- msg <- paste(msg, "Please install Command Line Tools for XCode ",
- "(or equivalent).\n", sep="")
- } else {
- msg <- paste(msg, "Please install GNU development tools ",
- "including a C++ compiler.\n", sep="")
- }
- message(msg)
- }
-}
-
-# check if R development tools are installed (cache successful result)
-.hasDevelTools <- FALSE
-.checkDevelTools <- function() {
-
- if (!.hasDevelTools) {
- # create temp source file
- tempFile <- file.path(tempdir(), "foo.c")
- cat("void foo() {}\n", file = tempFile)
- on.exit(unlink(tempFile))
-
- # set working directory to tempdir (revert on exit)
- oldDir <- setwd(tempdir())
- on.exit(setwd(oldDir), add = TRUE)
-
- # attempt the compilation and note whether we succeed
- cmd <- paste(R.home(component="bin"), .Platform$file.sep, "R ",
- "CMD SHLIB foo.c", sep = "")
- result <- suppressWarnings(system(cmd,
- ignore.stderr = TRUE,
- intern = TRUE))
- assignInMyNamespace(".hasDevelTools", is.null(attr(result, "status")))
-
- # if we build successfully then remove the shared library
- if (.hasDevelTools) {
- lib <- file.path(tempdir(),
- paste("foo", .Platform$dynlib.ext, sep=''))
- unlink(lib)
- }
- }
- .hasDevelTools
-}
-
+# Copyright (C) 2012 JJ Allaire, Dirk Eddelbuettel and Romain Francois
+#
+# This file is part of Rcpp.
+#
+# Rcpp is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 2 of the License, or
+# (at your option) any later version.
+#
+# Rcpp is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Rcpp. If not, see <http://www.gnu.org/licenses/>.
+
+
+# Source C++ code from a file
+sourceCpp <- function(file = "",
+ code = NULL,
+ env = globalenv(),
+ rebuild = FALSE,
+ showOutput = verbose,
+ verbose = getOption("verbose")) {
+
+ # resolve code into a file if necessary
+ if (!missing(code)) {
+ file <- tempfile(fileext = ".cpp")
+ con <- file(file, open = "w")
+ writeLines(code, con)
+ close(con)
+ }
+
+ # resolve the file path
+ file <- normalizePath(file, winslash = "/")
+
+ # get the context (does code generation as necessary)
+ context <- .Call("sourceCppContext", PACKAGE="Rcpp", file, code, .Platform)
+
+ # perform a build if necessary
+ if (context$buildRequired || rebuild) {
+
+ # print output for verbose mode
+ if (verbose)
+ .printVerboseOutput(context)
+
+ # variables used to hold completed state (passed to completed hook)
+ succeeded <- FALSE
+ output <- NULL
+
+ # build dependency list
+ depends <- .getSourceCppDependencies(context$depends, file)
+
+ # validate packages (error if package not found)
+ .validatePackages(depends, context$cppSourceFilename)
+
+ # temporarily modify environment for the build
+ envRestore <- .setupBuildEnvironment(depends, file)
+
+ # temporarily setwd to build directory
+ cwd <- getwd()
+ setwd(context$buildDirectory)
+
+ # call the onBuild hook. note that this hook should always be called
+ # after .setupBuildEnvironment so subscribers are able to examine
+ # the build environment
+ fromCode <- !missing(code)
+ if (!.callBuildHook(context$cppSourcePath, fromCode, showOutput)) {
+ .restoreEnvironment(envRestore)
+ setwd(cwd)
+ return (invisible(NULL))
+ }
+
+ # on.exit handler calls hook and restores environment and working dir
+ on.exit({
+ if (!succeeded)
+ .showBuildFailureDiagnostics()
+ .callBuildCompleteHook(succeeded, output)
+ setwd(cwd)
+ .restoreEnvironment(envRestore)
+ })
+
+ # unload and delete existing dylib if necessary
+ if (file.exists(context$dynlibPath)) {
+ try(silent=T, dyn.unload(context$dynlibPath))
+ file.remove(context$dynlibPath)
+ }
+
+ # prepare the command (output if we are in showOutput mode)
+ cmd <- paste(R.home(component="bin"), .Platform$file.sep, "R ",
+ "CMD SHLIB ",
+ "-o ", shQuote(context$dynlibFilename), " ",
+ ifelse(rebuild, "--preclean ", ""),
+ shQuote(context$cppSourceFilename), sep="")
+ if (showOutput)
+ cat(cmd, "\n")
+
+ # execute the build -- suppressWarnings b/c when showOutput = FALSE
+ # we are going to explicitly check for an error and print the output
+ result <- suppressWarnings(system(cmd, intern = !showOutput))
+
+ # check build results
+ if(!showOutput) {
+ # capture output
+ output <- result
+ attributes(output) <- NULL
+ # examine status
+ status <- attr(result, "status")
+ if (!is.null(status)) {
+ cat(result, "\n")
+ succeeded <- FALSE
+ stop("Error ", status, " occurred building shared library.")
+ } else {
+ succeeded <- TRUE
+ }
+ }
+ else if (!identical(as.character(result), "0")) {
+ succeeded <- FALSE
+ stop("Error ", result, " occurred building shared library.")
+ } else {
+ succeeded <- TRUE
+ }
+ }
+ else {
+ if (verbose)
+ cat("\nNo rebuild required (use rebuild = TRUE to ",
+ "force a rebuild)\n\n", sep="")
+ }
+
+ # load the module if we have exported functions (else there is no module)
+ if (length(context$exportedFunctions) > 0) {
+
+ # remove existing objects of the same name from the environment
+ exports <- context$exportedFunctions
+ removeObjs <- exports[exports %in% ls(envir = env, all.names = T)]
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/rcpp -r 4106
More information about the Rcpp-commits
mailing list