[Rcpp-commits] r2133 - pkg/Rcpp/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Sep 18 00:54:36 CEST 2010
Author: jmc
Date: 2010-09-18 00:54:36 +0200 (Sat, 18 Sep 2010)
New Revision: 2133
Modified:
pkg/Rcpp/R/Module.R
Log:
use reference object env. to simplify and speed up fields and methods
Modified: pkg/Rcpp/R/Module.R
===================================================================
--- pkg/Rcpp/R/Module.R 2010-09-17 12:15:43 UTC (rev 2132)
+++ pkg/Rcpp/R/Module.R 2010-09-17 22:54:36 UTC (rev 2133)
@@ -102,45 +102,39 @@
# field
cpp_object_initializer <- function(CLASS){
function(.Object, ...){
+ selfEnv <- as.environment(.Object)
+ ## generate the C++-side object and store its pointer, etc.
if(identical(.Object at pointer, .emptyPointer)) {
- ## [John] is this different: .Call( "CppObject__needs_init", .Object at pointer, PACKAGE = "Rcpp" )
- ## [Romain] internally it checks against 0
- ## RCPP_FUNCTION_1( bool, CppObject__needs_init, SEXP xp ){
- ## return EXTPTR_PTR(xp) == 0 ;
- ## }
- ## and since
- ## > new( "externalptr" )
- ## <pointer: 0x0>
- ## I guess this is the same
-
fields <- getClass(class(.Object))@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)
+ ## <fixme> these should not be needed
.Object at module <- fields$.module
.Object at cppclass <- fields$.pointer
- .Object at pointer <- new_CppObject_xp(fields$.module, fields$.pointer, ...)
+ .Object at pointer <- pointer
+ ##</fixme>
}
- selfEnv <- .Object at .xData
- assign( ".self", .Object, envir = selfEnv )
-
- # <hack>
- # we replace the prototypes by active bindings that
- # call the internal accessors
+ ## for the C++ fields (only), create active bindings
fields <- CLASS at fields
fields_names <- names( fields )
- tryCatch( rm( list = fields_names, envir = selfEnv ), warning = function(e)e, error = function(e) e)
binding_maker <- function( FIELD ){
- function( x ){
- .self <- get( ".self", get("envir", sys.frame(-1L) ) )
+ f <- function( x ) NULL
+ body(f) <- substitute({
+ fieldPtr <- FIELD
if( missing( x ) ){
- FIELD$get( .self at pointer )
+ fieldPtr$get( .pointer )
} else {
- FIELD$set( .self at pointer, x )
+ fieldPtr$set( .pointer, x )
}
- }
+ }, list(FIELD = FIELD))
+ environment(f) <- selfEnv
+ f
}
for( i in seq_along(fields) ){
makeActiveBinding( fields_names[i], binding_maker( fields[[i]] ) , selfEnv )
}
- # </hack>
.Object
}
}
@@ -189,53 +183,53 @@
}
classes <- .Call( "Module__classes_info", xp, PACKAGE = "Rcpp" )
- for( i in seq_along(classes) ){
+ for( i in seq_along(classes) ){
## 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???
- CLASS <- classes[[i]]
- clname <- as.character(CLASS)
-
- interface <- cppInterfaceClass( clname )
- setClass( interface, where = where )
- cdef <- getClassDef( interface, where = where )
- classRep <- new( "C++ClassRepresentation",
- # grab the data from the generated classRepresentation
- className = cdef at className,
- virtual = TRUE,
- versionKey = cdef at versionKey,
- package = cdef at package,
- sealed = cdef at sealed,
-
- # Rcpp specific information
- pointer = CLASS at pointer,
- cpp_fields = CLASS at fields,
- cpp_methods = CLASS at methods
- # anything else ?
- )
-
- # [romain] perhaps we should have something like "C++Property"
- # instead of "ANY" with appropriate setAs/setIs methods
- # or maybe change setRefClass so that it takes a "refFields"
- # argument instead of the trio fieldClasses, fieldPrototypes, fieldReadOnly
- fc <- .Call( "CppClass__property_classes", CLASS at pointer, PACKAGE = "Rcpp" )
- class_names <- names( fc )
-
- fieldClasses <- rep( list( "ANY" ), length( class_names ) )
- names( fieldClasses ) <- class_names
-
- fieldPrototypes <- rep( list( NA ), length( class_names ) )
- names( fieldPrototypes ) <- class_names
-
+ CLASS <- classes[[i]]
+ clname <- as.character(CLASS)
+
+ interface <- cppInterfaceClass( clname )
+ setClass( interface, where = where )
+ cdef <- getClassDef( interface, where = where )
+ classRep <- new( "C++ClassRepresentation",
+ # grab the data from the generated classRepresentation
+ className = cdef at className,
+ virtual = TRUE,
+ versionKey = cdef at versionKey,
+ package = cdef at package,
+ sealed = cdef at sealed,
+
+ # Rcpp specific information
+ pointer = CLASS at pointer,
+ cpp_fields = CLASS at fields,
+ cpp_methods = CLASS at methods
+ # anything else ?
+ )
+
+ ## [romain] perhaps we should have something like "C++Property"
+ ## instead of "ANY" with appropriate setAs/setIs methods
+ ## or maybe change setRefClass so that it takes a "refFields"
+ ## argument instead of the trio fieldClasses, fieldPrototypes, fieldReadOnly
+ fc <- .Call( "CppClass__property_classes", CLASS at pointer, PACKAGE = "Rcpp" )
+ class_names <- names( fc )
+
+ fieldClasses <- rep( list( "ANY" ), length( class_names ) )
+ names( fieldClasses ) <- class_names
+
+ fieldPrototypes <- rep( list( NA ), length( class_names ) )
+ names( fieldPrototypes ) <- class_names
+
generator <- setRefClass( clname,
- fieldClasses = fieldClasses,
- fieldPrototypes = fieldPrototypes ,
- contains = "C++Object",
- interfaceClasses = classRep,
- where = where
- )
+ fieldClasses = fieldClasses,
+ fieldPrototypes = fieldPrototypes ,
+ contains = "C++Object",
+ interfaceClasses = classRep,
+ where = where
+ )
classRep at generator <- generator
classDef <- getClass(clname)
## non-public (static) fields in class representation
@@ -246,9 +240,9 @@
assignClassDef( interface, classRep, where)
setMethod( "initialize", clname, cpp_object_initializer(CLASS) , where = where )
-
- }
- module
+
+ }
+ module
}
.referenceMethods__cppclass <- function( classDef, where ){
@@ -259,7 +253,7 @@
here <- environment()
eval( substitute(
function(...) {
- res <- MET$invoke( .self at pointer, ... )
+ res <- MET$invoke( .pointer, ... )
RES
},
list(
More information about the Rcpp-commits
mailing list