# Copyright (C) 2010 - 2021 John Chambers, 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/>.
internal_function <- function(pointer){
f <- function(xp){
force(xp)
function(...){
.External( InternalFunction_invoke, xp, ... )
}
}
o <- new( "C++Function", f(pointer) )
o@pointer <- pointer
o
}
setMethod("$", "C++Class", function(x, name) {
x <- x@generator
eval.parent(substitute(x$name))
})
.badModulePointer <- NULL
.setModulePointer <- function(module, value) {
assign("pointer", value, envir = as.environment(module))
value
}
.getModulePointer <- function(module, mustStart = TRUE) {
pointer <- get("pointer", envir = as.environment(module))
if(is.null(pointer) && mustStart) { # #nocov start
## should be (except for bug noted in identical())
## if(identical(pointer, .badModulePointer) && mustStart) {
Module(module, mustStart = TRUE) # will either initialize pointer or throw error
pointer <- get("pointer", envir = as.environment(module))
} # #nocov end
pointer
}
setMethod("initialize", "Module",
function(.Object,
moduleName = "UNKNOWN",
packageName = "",
pointer = .badModulePointer, ...) {
env <- new.env(TRUE, emptyenv())
as(.Object, "environment") <- env
assign("pointer", pointer, envir = env)
assign("packageName", packageName, envir = env)
assign("moduleName", moduleName, envir = env)
if(length(list(...)) > 0) {
.Object <- callNextMethod(.Object, ...) # #nocov
}
.Object
})
.get_Module_function <- function(x, name, pointer = .getModulePointer(x) ){
pointer <- .getModulePointer(x)
info <- .Call( Module__get_function, pointer, name )
fun_ptr <- info[[1L]]
is_void <- info[[2L]]
doc <- info[[3L]]
sign <- info[[4L]]
formal_args <- info[[5L]]
nargs <- info[[6L]]
f <- function(...) NULL
if( nargs == 0L ) formals(f) <- NULL
stuff <- list( fun_pointer = fun_ptr, InternalFunction_invoke = InternalFunction_invoke )
body(f) <- if( nargs == 0L ){
if( is_void ) {
substitute( { # #nocov start
.External( InternalFunction_invoke, fun_pointer)
invisible(NULL)
}, stuff ) # #nocov end
} else {
substitute( {
.External( InternalFunction_invoke, fun_pointer)
}, stuff )
}
} else {
if( is_void ) {
substitute( { # #nocov start
.External( InternalFunction_invoke, fun_pointer, ... )
invisible(NULL)
}, stuff ) # #nocov end
} else {
substitute( {
.External( InternalFunction_invoke, fun_pointer, ... )
}, stuff )
}
}
out <- new( "C++Function", f, pointer = fun_ptr, docstring = doc, signature = sign )
if( ! is.null( formal_args ) ){
formals( out ) <- formal_args # #nocov
}
out
}
.get_Module_Class <- function( x, name, pointer = .getModulePointer(x) ){
value <- .Call( Module__get_class, pointer, name )
value@generator <- get("refClassGenerators", envir=x)[[value@.Data]]
value
}
setMethod( "$", "Module", function(x, name){ # #nocov start
pointer <- .getModulePointer(x)
storage <- get( "storage", envir = as.environment(x) )
storage[[ name ]]
} ) # #nocov end
new_CppObject_xp <- function(module, pointer, ...) {
.External( class__newInstance, module, pointer, ... )
}
new_dummyObject <- function(...) # #nocov
.External( class__dummyInstance, ...) # #nocov
# class method for $initialize
cpp_object_initializer <- function(.self, .refClassDef, ..., .object_pointer){
selfEnv <- as.environment(.self)
## generate the C++-side object and store its pointer, etc.
## access the private fields in the fieldPrototypes env.
fields <- .refClassDef@fieldPrototypes
pointer <- if(missing(.object_pointer)) new_CppObject_xp(fields$.module, fields$.pointer, ...) else .object_pointer
assign(".module", fields$.module, envir = selfEnv)
assign(".pointer", pointer, envir = selfEnv)
assign(".cppclass", fields$.pointer, envir = selfEnv)
.self
}
cpp_object_dummy <- function(.self, .refClassDef) { # #nocov start
selfEnv <- as.environment(.self)
## like initializer but a dummy for the case of no default
## constructor. Will throw an error if the object is used.
fields <- .refClassDef@fieldPrototypes
pointer <- new_dummyObject()
assign(".module", fields$.module, envir = selfEnv)
assign(".pointer", pointer, envir = selfEnv)
assign(".cppclass", fields$.pointer, envir = selfEnv)
.self
} # #nocov end
cpp_object_maker <- function(typeid, pointer){
Class <- .classes_map[[ typeid ]]
new( Class, .object_pointer = pointer )
}
Module <- function( module, PACKAGE = methods::getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ) {
if (inherits(module, "DLLInfo") && missing(mustStart)) mustStart <- TRUE # #nocov
if (inherits(module, "Module")) {
xp <- .getModulePointer(module, FALSE)
if(!missing(PACKAGE))
warning("ignoring PACKAGE argument in favor of internal package from Module object") # #nocov
env <- as.environment(module) # not needed from R 2.12.0
PACKAGE <- get("packageName", envir = env)
moduleName <- get("moduleName", envir = env)
}
else if( identical( typeof( module ), "externalptr" ) ){
## [john] Should Module() ever be called with a pointer as argument?
## If so, we need a safe check of the pointer's validity
## [romain] I don't think we actually can, external pointers
## are stored as void*, they don't know what they are. Or we could
## perhaps keep a vector of all known module pointers
## [John] One technique is to initialize the pointer to a known value
## and just check whether it's been reset from that (bad) value
xp <- module # #nocov start
moduleName <- .Call( Module__name, xp )
module <- methods::new("Module", pointer = xp, packageName = PACKAGE,
moduleName = moduleName) # #nocov end
} else if(is.character(module)) {
moduleName <- module
xp <- .badModulePointer
module <- methods::new("Module", pointer = xp, packageName = PACKAGE,
moduleName = moduleName)
}
if(identical(xp, .badModulePointer)) {
if(mustStart) {
name <- sprintf( "_rcpp_module_boot_%s", moduleName )
symbol <- tryCatch(getNativeSymbolInfo( name, PACKAGE ),
error = function(e)e)
if(inherits(symbol, "error"))
stop(gettextf("Failed to initialize module pointer: %s",
symbol), domain = NA)
xp <- .Call( symbol )
.setModulePointer(module, xp)
}
else
return(module)
}
classes <- .Call( Module__classes_info, xp )
## We need a general strategy for assigning class defintions
## since delaying the initialization of the module causes
## where to be the Rcpp namespace:
if(environmentIsLocked(where))
where <- .GlobalEnv # or???
generators <- list()
storage <- new.env()
for( i in seq_along(classes) ){
CLASS <- classes[[i]]
clname <- CLASS@.Data
fields <- cpp_fields( CLASS, where )
methods <- cpp_refMethods(CLASS, where)
generator <- methods::setRefClass( clname,
fields = fields,
contains = "C++Object",
methods = methods,
where = where
)
# just to make codetools happy
.self <- .refClassDef <- NULL
generator$methods(initialize =
if (cpp_hasDefaultConstructor(CLASS))
function(...) Rcpp::cpp_object_initializer(.self,.refClassDef, ...)
else
function(...) {
if (nargs()) Rcpp::cpp_object_initializer(.self,.refClassDef, ...)
else Rcpp::cpp_object_dummy(.self, .refClassDef) # #nocov
}
)
rm( .self, .refClassDef )
classDef <- methods::getClass(clname)
## non-public (static) fields in class representation
## <fixme> Should these become real fields? </fixme>
fields <- classDef@fieldPrototypes
assign(".pointer", CLASS@pointer, envir = fields)
assign(".module", xp, envir = fields)
assign(".CppClassName", clname, envir = fields)
generators[[clname]] <- generator
# [romain] : should this be promoted to reference classes
# perhaps with better handling of j and ... arguments
if( any( grepl( "^[[]", names(CLASS@methods) ) ) ){ # #nocov start
if( "[[" %in% names( CLASS@methods ) ){
methods::setMethod( "[[", clname, function(x, i, j, ..., exact = TRUE){
x$`[[`( i )
}, where = where )
}
if( "[[<-" %in% names( CLASS@methods ) ){
methods::setReplaceMethod( "[[", clname, function(x, i, j, ..., exact = TRUE, value){
x$`[[<-`( i, value )
x
} , where = where )
}
} # #nocov end
# promoting show to S4
if( any( grepl( "show", names(CLASS@methods) ) ) ){
setMethod( "show", clname, function(object) object$show(), where = where ) # #nocov
}
}
if(length(classes)) {
module$refClassGenerators <- generators
}
for( i in seq_along(classes) ){
CLASS <- classes[[i]]
clname <- CLASS@.Data
demangled_name <- sub( "^Rcpp_", "", clname )
.classes_map[[ CLASS@typeid ]] <- storage[[ demangled_name ]] <- .get_Module_Class( module, demangled_name, xp )
# exposing enums values as CLASS.VALUE
# (should really be CLASS$value but I don't know how to do it)
if( length( CLASS@enums ) ){
for( enum in CLASS@enums ){ # #nocov start
for( i in 1:length(enum) ){
storage[[ paste( demangled_name, ".", names(enum)[i], sep = "" ) ]] <- enum[i]
}
} # #nocov end
}
}
# functions
functions <- .Call( Module__functions_names, xp )
for( fun in functions ){
storage[[ fun ]] <- .get_Module_function( module, fun, xp )
# register as(FROM, TO) methods
converter_rx <- "^[.]___converter___(.*)___(.*)$"
if( length( matches <- grep( converter_rx, functions ) ) ){ # #nocov start
for( i in matches ){
fun <- functions[i]
from <- sub( converter_rx, "\\1", fun )
to <- sub( converter_rx, "\\2", fun )
converter <- function( from ){}
body( converter ) <- substitute( { CONVERT(from) },
list( CONVERT = storage[[fun]] )
)
setAs( from, to, converter, where = where )
}
} # #nocov end
}
assign( "storage", storage, envir = as.environment(module) )
module
}
dealWith <- function( x ) if(isTRUE(x[[1]])) invisible(NULL) else x[[2]] # #nocov
method_wrapper <- function( METHOD, where ){
noargs <- all( METHOD$nargs == 0 )
stuff <- list(
class_pointer = METHOD$class_pointer,
pointer = METHOD$pointer,
CppMethod__invoke = CppMethod__invoke,
CppMethod__invoke_void = CppMethod__invoke_void,
CppMethod__invoke_notvoid = CppMethod__invoke_notvoid,
dealWith = dealWith,
docstring = METHOD$info("")
)
f <- function(...) NULL
if( noargs ){
formals(f) <- NULL
}
extCall <- if( noargs ) {
if( all( METHOD$void ) ){
# all methods are void, so we know we want to return invisible(NULL)
substitute(
{
docstring
.External(CppMethod__invoke_void, class_pointer, pointer, .pointer )
invisible(NULL)
} , stuff )
} else if( all( ! METHOD$void ) ){
# none of the methods are void so we always return the result of
# .External
substitute(
{
docstring
.External(CppMethod__invoke_notvoid, class_pointer, pointer, .pointer )
} , stuff )
} else {
# some are void, some are not, so the voidness is part of the result
# we get from internally and we need to deal with it
substitute( # #nocov start
{
docstring
dealWith( .External(CppMethod__invoke, class_pointer, pointer, .pointer ) )
} , stuff ) # #nocov end
}
} else {
if( all( METHOD$void ) ){
# all methods are void, so we know we want to return invisible(NULL)
substitute(
{
docstring
.External(CppMethod__invoke_void, class_pointer, pointer, .pointer, ...)
invisible(NULL)
} , stuff )
} else if( all( ! METHOD$void ) ){
# none of the methods are void so we always return the result of
# .External
substitute(
{
docstring
.External(CppMethod__invoke_notvoid, class_pointer, pointer, .pointer, ...)
} , stuff )
} else {
# some are void, some are not, so the voidness is part of the result
# we get from internally and we need to deal with it
substitute( # #nocov start
{
docstring
dealWith( .External(CppMethod__invoke, class_pointer, pointer, .pointer, ...) )
} , stuff ) # #nocov end
}
}
body(f, where) <- extCall
f
}
## create a named list of the R methods to invoke C++ methods
## from the C++ class with pointer xp
cpp_refMethods <- function(CLASS, where) {
finalizer <- eval( substitute(
function(){
.Call( CppObject__finalize, class_pointer , .pointer )
},
list(
CLASS = CLASS@pointer,
CppObject__finalize = CppObject__finalize,
class_pointer = CLASS@pointer
)
) )
mets <- c(
sapply( CLASS@methods, method_wrapper, where = where ),
"finalize" = finalizer
)
mets
}
cpp_hasDefaultConstructor <- function(CLASS) {
.Call( Class__has_default_constructor, CLASS@pointer )
}
binding_maker <- function( FIELD, where ){
f <- function( x ) NULL
body(f) <- substitute({
if( missing( x ) )
.Call( CppField__get, class_pointer, pointer, .pointer)
else
.Call( CppField__set, class_pointer, pointer, .pointer, x)
}, list(class_pointer = FIELD$class_pointer,
pointer = FIELD$pointer,
CppField__get = CppField__get,
CppField__set = CppField__set ))
environment(f) <- where
f
}
cpp_fields <- function( CLASS, where){
sapply( CLASS@fields, binding_maker, where = where )
}
.CppClassName <- function(name) {
paste0("Rcpp_",name) # #nocov
}