swh:1:snp:cae2596088bc8b92147ee77a766423472ecb4710
Tip revision: e068f009926a6e7e8599a1d12a6d941b9e869131 authored by Dirk Eddelbuettel and Romain Francois on 24 February 2011, 09:00:14 UTC
version 0.9.2
version 0.9.2
Tip revision: e068f00
Module.R
# Copyright (C) 2010 - 2011 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) {
## 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))
}
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, ...)
}
.Object
})
.get_Module_function <- function(x, name, pointer = .getModulePointer(x) ){
pointer <- .getModulePointer(x)
info <- .Call( Module__get_function, pointer, name )
fun_ptr <- info[[1L]]
doc <- info[[3L]]
sign <- info[[4L]]
formal_args <- info[[5L]]
f <- function(...) NULL
stuff <- list( fun_pointer = fun_ptr, InternalFunction_invoke = InternalFunction_invoke )
body(f) <- if( info[[2]] ) {
substitute( {
.External( InternalFunction_invoke, fun_pointer, ... )
invisible(NULL)
}, stuff )
} 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
}
out
}
.get_Module_Class <- function( x, name, pointer = .getModulePointer(x) ){
value <- .Call( Module__get_class, pointer, name )
value@generator <- get("refClassGenerators",envir=x)[[as.character(value)]]
value
}
setMethod( "$", "Module", function(x, name){
pointer <- .getModulePointer(x)
storage <- get( "storage", envir = as.environment(x) )
storage[[ name ]]
} )
new_CppObject_xp <- function(module, pointer, ...) {
.External( class__newInstance, module, pointer, ... )
}
new_dummyObject <- function(...)
.External( "class__dummyInstance", ...)
# class method for $initialize
cpp_object_initializer <- function(.self, .refClassDef, ...){
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 <- new_CppObject_xp(fields$.module, fields$.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) {
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
}
Module <- function( module, PACKAGE = getPackageName(where), where = topenv(parent.frame()), mustStart = FALSE ) {
if(is(module, "Module")) {
xp <- .getModulePointer(module, FALSE)
if(!missing(PACKAGE))
warning("ignoring PACKAGE argument in favor of internal package from Module object")
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
moduleName <- .Call( Module__name, xp )
module <- new("Module", pointer = xp, packageName = PACKAGE,
moduleName = moduleName)
} else if(is(module, "character")) {
moduleName <- module
xp <- .badModulePointer
module <- 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(is(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 <- as.character(CLASS)
fields <- cpp_fields( CLASS, where )
methods <- cpp_refMethods(CLASS, where)
generator <- 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)
}
)
rm( .self, .refClassDef )
classDef <- 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) ) ) ){
if( "[[" %in% names( CLASS@methods ) ){
setMethod( "[[", clname, function(x, i, j, ..., exact = TRUE){
x$`[[`( i )
}, where = where )
}
if( "[[<-" %in% names( CLASS@methods ) ){
setReplaceMethod( "[[", clname, function(x, i, j, ..., exact = TRUE, value){
x$`[[<-`( i, value )
x
} , where = where )
}
}
}
if(length(classes)) {
module$refClassGenerators <- generators
}
for( i in seq_along(classes) ){
clname <- as.character(classes[[i]])
demangled_name <- sub( "^Rcpp_", "", clname )
storage[[ demangled_name ]] <- .get_Module_Class( module, demangled_name, xp )
}
# functions
functions <- .Call( Module__functions_names, xp )
for( fun in functions ){
storage[[ fun ]] <- .get_Module_function( module, fun, xp )
}
assign( "storage", storage, envir = as.environment(module) )
module
}
dealWith <- function( x ) if(isTRUE(x[[1]])) invisible(NULL) else x[[2]]
method_wrapper <- function( METHOD, where ){
f <- function(...) NULL
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("")
)
extCall <- 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(
{
docstring
dealWith( .External(CppMethod__invoke, class_pointer, pointer, .pointer, ...) )
} , stuff )
}
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 )
}