Nothing
cppNimbleListClass <- setRefClass('cppNimbleListClass',
contains = 'cppNimbleClassClass',
fields = list(
ptrCastFun = 'ANY',
ptrCastToPtrPairFun = 'ANY',
predefined = 'ANY'
),
methods = list(
initialize = function(nimCompProc, debugCpp = FALSE, fromModel = FALSE, ...) {
callSuper(nimCompProc, debugCpp, fromModel, ...)
predefined <<- nimCompProc$nimbleListObj$predefined
inheritance <<- c(inheritance, 'pointedToBase')
},
getDefs = function() {
if(predefined) {
## Prevent redefinition of nimbleList classes that live
## in predefinedNimbleLists.h and predefinedNumbleLists.cpp.
return(list())
} else if(name == 'EIGEN_SVDCLASS' || name == 'EIGEN_EIGENCLASS') {
## Handle these two EIGEN_ classes specially. They are implemented as an inheritance hierarchy,
## so we cannot generate the class definitions (Nick and Perry understand why).
## Note that this section of code is only ever run under the control of generateStaticCode.R to
## regenerate C++ code in predefinedNimbleLists.h and predefinedNimbleLists.cpp.
defs <- c(SEXPgeneratorFun, ptrCastFun, ptrCastToPtrPairFun)
if(!inherits(SEXPfinalizerFun, 'uninitializedField')) {
defs <- c(defs, SEXPfinalizerFun)
}
return(defs)
} else {
return(c(callSuper(), ptrCastFun, ptrCastToPtrPairFun))
}
},
buildCastPtrToNamedObjectsPtrFun = function() {
## Creating code like:
## SEXP nfRefClass_84_castPtrPtrToNamedObjectsPtrSEXP ( SEXP input ) {
## return( R_MakeExternalPtr(dynamic_cast<NamedObjects*>(reinterpret_cast<nfRefClass_84*>(*static_cast<void**>(R_ExternalPtrAddr(input)))), R_NilValue, R_NilValue));
##}
newName <- paste0(name, "_castPtrPtrToNamedObjectsPtrSEXP")
args = list(cppSEXP(name = 'input'))
allCodeList <- list(cppLiteral(paste0("return( R_MakeExternalPtr(dynamic_cast<NamedObjects*>(reinterpret_cast<",name,"*>(*static_cast<void**>(R_ExternalPtrAddr(input)))), R_NilValue, R_NilValue));")))
allCode <- putCodeLinesInBrackets(allCodeList)
ptrCastFun <<- cppFunctionDef(name = newName,
args = args,
code = cppCodeBlock(code = allCode, objectDefs = list(), skipBrackets = TRUE),
returnType = cppSEXP(),
externC = TRUE)
},
buildCastPtrToPtrPairFun = function() {
## example of code being generated:
## SEXP nfRefClass_84_castDerivedPtrPtrToPairOfPtrsSEXP ( SEXP input ) {
## nimSmartPtrBase * ptrToSmartPtrBase;
## nimSmartPtr<nfRefClass_84> * ptrToSmartPtr;
## void * ptrToPtr;
## SEXP SptrToSmartPtrBase;
## SEXP SptrToPtr;
## SEXP Sans;
## ptrToSmartPtr = static_cast<nimSmartPtr<nfRefClass_84> *>(R_ExternalPtrAddr(input));
## ptrToSmartPtrBase = dynamic_cast<nimSmartPtrBase*>(ptrToSmartPtr);
## ptrToPtr = ptrToSmartPtr->getVoidPtrToRealPtr();
## reinterpret_cast<nfRefClass_84*>(*static_cast<void**>(ptrToPtr))->NO_hw();
## PROTECT(SptrToSmartPtrBase = R_MakeExternalPtr(ptrToSmartPtrBase, R_NilValue, R_NilValue));
## PROTECT(SptrToPtr = R_MakeExternalPtr(ptrToPtr, R_NilValue, R_NilValue));
## PROTECT(Sans = Rf_allocVector(VECSXP,2));
## SET_VECTOR_ELT(Sans,0,SptrToSmartPtrBase);
## SET_VECTOR_ELT(Sans,1,SptrToPtr);
## UNPROTECT(3);
## return(Sans);
## }
newName <- paste0(name, "_castDerivedPtrPtrToPairOfPtrsSEXP")
args = list(input = cppSEXP(name = 'input'))
CBobjectDefs <- list(cppVarFull(name = 'ptrToSmartPtrBase', baseType = 'nimSmartPtrBase', ptr = 1),
cppVarFull(name = 'ptrToSmartPtr', baseType = 'nimSmartPtr', templateArgs = name, ptr = 1),
cppVarFull(name = 'ptrToPtr', baseType = 'void', ptr = 1),
SptrToSmartPtrBase = cppSEXP(name = 'SptrToSmartPtrBase'),
SptrToPtr = cppSEXP(name = 'SptrToPtr'),
Sans = cppSEXP(name = 'Sans'))
newCodeLine <- cppLiteral(c(paste0('ptrToSmartPtr = static_cast<nimSmartPtr<',name,'>* >(R_ExternalPtrAddr(input));'),
'ptrToSmartPtrBase = dynamic_cast<nimSmartPtrBase*>(ptrToSmartPtr);',
'ptrToPtr = ptrToSmartPtr->getVoidPtrToRealPtr();',
'PROTECT(SptrToSmartPtrBase = R_MakeExternalPtr(ptrToSmartPtrBase, R_NilValue, R_NilValue));',
'PROTECT(SptrToPtr = R_MakeExternalPtr(ptrToPtr, R_NilValue, R_NilValue));'))
allocVectorLine <- cppLiteral(paste0('PROTECT(Sans = Rf_allocVector(VECSXP,', 2, '));'))
packListLines <- cppLiteral(c('SET_VECTOR_ELT(Sans,0,SptrToSmartPtrBase);',
'SET_VECTOR_ELT(Sans,1,SptrToPtr);'
))
codeLines <- substitute({
## Finalizer registration now happens through nimble's finalizer mapping system.
UNPROTECT(3)
return(Sans)
}, list())
allCodeList <- list(newCodeLine, allocVectorLine, packListLines, codeLines)
allCode <- putCodeLinesInBrackets(allCodeList)
ptrCastToPtrPairFun <<- cppFunctionDef(name = newName,
args = args,
code = cppCodeBlock(code = allCode, objectDefs = CBobjectDefs, skipBrackets = TRUE),
returnType = cppSEXP(),
externC = TRUE)
},
buildSEXPgenerator = function(finalizer = NULL) {
## Build a function that will provide a new object and return an external pointer.
##
## This differs from general cppClassDef case
## because we will return a pointer to a smartPtr to a nimbleList object.
## The pointer to the smartPtr will be case to base class nimSmartPtrBase, which has a virtual casting
## member function.
##
## We'll also return a ptr to a the realPtr (a double pointer to the object).
##
## Example output:
##
## SEXP new_nfRefClass_84 ( ) {
## nimSmartPtr<nfRefClass_84> * ptrToSmartPtr;
## nfRefClass_84 * newObj;
## SEXP SptrToSmartPtr;
##
## newObj = new nfRefClass_84 ;
## ptrToSmartPtr = new nimSmartPtr<nfRefClass_84>;
## ptrToSmartPtr->setPtrFromT(newObj);
## (*ptrToSmartPtr)->NO_hw();
##
## PROTECT(SptrToSmartPtr = R_MakeExternalPtr(ptrToSmartPtr, R_NilValue, R_NilValue));
## UNPROTECT(1);
## return(nfRefClass_84_castDerivedPtrPtrToPairOfPtrsSEXP(SptrToSmartPtr));
## }
extPtrTypes <<- c('ptrToSmartPtr','ptrToPtrToObject')
CBobjectDefs <- list(cppVarFull(name = 'ptrToSmartPtr', baseType = 'nimSmartPtr', templateArgs = name, ptr = 1),
cppVarFull(name = 'newObj', baseType = name, ptr = 1),
SptrToSmartPtr = cppSEXP(name = 'SptrToSmartPtr'),
Sans = cppSEXP(name = "Sans"))
newCodeLine <- cppLiteral(c(paste('newObj = new ',name,';'),
paste0('ptrToSmartPtr = new nimSmartPtr<',name,'>;'),
'ptrToSmartPtr->setPtrFromT(newObj);',
'PROTECT(SptrToSmartPtr = R_MakeExternalPtr(ptrToSmartPtr, R_NilValue, R_NilValue));'))
# String pasting required to get the format PROTECT(Y = f(X)) instead of Y = PROTECT(f(X)).
# It might not matter, but we are being careful to make the PROTECT's look just like in Tomas Kalibera's blog post (and CRAN's code analysis)
codeLines <- cppLiteral(c(paste0('PROTECT(Sans = ', ptrCastToPtrPairFun$name, '(SptrToSmartPtr));'),
'UNPROTECT(2);',
'return(Sans);'))
## codeLines <- substitute({
## ## Finalizer registration now happens through nimble's finalizer mapping system.
## Sans = PROTECT(ptrCastToPtrPairFun(SptrToSmartPtr))
## UNPROTECT(2)
## return(Sans)
## }, list(ptrCastToPtrPairFun = as.name(ptrCastToPtrPairFun$name)))
allCodeList <- list(newCodeLine, codeLines)
allCode <- putCodeLinesInBrackets(allCodeList)
SEXPgeneratorFun <<- cppFunctionDef(name = paste0('new_',name),
args = list(),
code = cppCodeBlock(code = allCode, objectDefs = CBobjectDefs, skipBrackets = TRUE),
returnType = cppSEXP(),
externC = TRUE)
},
buildCmultiInterface = function(dll = NULL) {
sym <- if(!is.null(dll))
getNativeSymbolInfo(SEXPgeneratorFun$name, dll)
else
SEXPgeneratorFun$name
CmultiInterface <<- CmultiNimbleListClass(compiledNodeFun = .self, basePtrCall = sym, project = nimbleProject)
},
buildRgenerator = function(where = globalenv(), dll = NULL) {
sym <- if(!is.null(dll))
getNativeSymbolInfo(SEXPgeneratorFun$name, dll)
else
SEXPgeneratorFun$name
Rgenerator <<- buildNimbleListInterface(paste0(name,'_refClass'), .self, sym, where = where)
},
addListSymbols = function(){
RPointerSymbol <- symbolSEXP(name = 'RObjectPointer')
objectDefs$addSymbol(RPointerSymbol$genCppVar())
RCopiedSymbol <- symbolBasic(name = 'RCopiedFlag', type = 'logical',
nDim = 0)
objectDefs$addSymbol(RCopiedSymbol$genCppVar())
},
buildAll = function(where = where) {
addListSymbols()
buildCastPtrToNamedObjectsPtrFun()
buildCastPtrToPtrPairFun()
if(!predefined){
buildCopyFromSexp()
buildCopyToSexp()
buildCreateNewSexp()
buildResetFlags()
addCopyFromRobject()
}
callSuper(where)
},
buildCreateNewSexp = function(){
interfaceArgs <- symbolTable()
newListLine <- list()
listElementTable <- symbolTable()
listElementTable$addSymbol(cppSEXP(name = "S_newNimList"))
listElementTable$addSymbol(cppSEXP(name = "S_listName"))
newListLine[[1]] <- substitute({PROTECT(S_listName <- Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(S_listName, 0, PROTECT(Rf_mkChar(LISTNAME)));},
list(LISTNAME = nimCompProc$nimbleListObj$className))
newListLine[[2]] <- substitute(PROTECT(S_newNimList <- makeNewNimbleList(S_listName)),
list())
newListLine[[3]] <- quote(cppLiteral('R_PreserveObject(RObjectPointer = S_newNimList);'))
newListLine[[4]] <- substitute(UNPROTECT(2+1), list())
allCode <- embedListInRbracket(c(newListLine))
functionDefs[[paste0(name, "_createNewSEXP")]] <<- cppFunctionDef(name = "createNewSEXP",
args = interfaceArgs,
returnType = cppVoid(),
code = cppCodeBlock(code = RparseTree2ExprClasses(allCode), objectDefs = listElementTable),
externC = FALSE,
CPPincludes = list(nimbleIncludeFile("RcppUtils.h"),
nimbleIncludeFile("smartPtrs.h")))
},
buildCopyToSexp = function(){
interfaceArgs <- symbolTable()
elementNames <- nimCompProc$symTab$getSymbolNames()
protectLines <- list()
writeToSexpLines <- list()
copyToListLines <- list()
Snames <- character(length(elementNames))
listElementTable <- symbolTable()
numElements <- length(elementNames)
conditionalLineList <- list()
conditionalClauseStart <- list(quote(cppLiteral('if (!RCopiedFlag){')))
conditionalClauseEnd <- list(quote(cppLiteral('}')))
environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment
listElementTable$addSymbol(cppSEXP(name = environmentCPPName))
envLine <- substitute({PROTECT(ENVNAME <- Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(ENVNAME, 0, PROTECT(Rf_mkChar(".xData")));},
list(ENVNAME = as.name(environmentCPPName)))
for(i in seq_along(elementNames)){
Snames[i] <- Rname2CppName(paste0('S_', elementNames[i]))
listElementTable$addSymbol(cppSEXP(name = Snames[i]))
elementSymTab <- nimCompProc$symTab$getSymbolObject(elementNames[i])
conditionalLineList <- c(conditionalLineList, generateConditionalLines(nimCompProc$symTab$getSymbolObject(elementNames[i]),
listElementTable$getSymbolObject(Snames[i])))
copyToListLines[[i]] <- substitute(Rf_defineVar(Rf_install(ELEMENTNAME), VALUE, PROTECT(GET_SLOT(ROBJ, XDATA))),
list(ELEMENTNAME = elementNames[i], VALUE = as.name(Snames[i]),
ROBJ = as.name('RObjectPointer'),
XDATA = as.name(environmentCPPName)))
}
setFlagLine <- list(substitute(RCopiedFlag <- true,
list()))
returnLine <- list(substitute(return(ROBJ),
list(ROBJ = as.name('RObjectPointer'))))
unprotectLine <- list(substitute(UNPROTECT(N), list(N = 2 * numElements + 1 + 1)))
allCode <- embedListInRbracket(c(conditionalClauseStart, list(envLine), conditionalLineList,
copyToListLines, setFlagLine, unprotectLine,
conditionalClauseEnd, returnLine))
functionDefs[[paste0(name, "_copyTo")]] <<- cppFunctionDef(name = "copyToSEXP",
args = interfaceArgs,
code = cppCodeBlock(code = RparseTree2ExprClasses(allCode), objectDefs = listElementTable),
returnType = cppSEXP(),
externC = FALSE,
CPPincludes = list(nimbleIncludeFile("RcppUtils.h"),
nimbleIncludeFile("smartPtrs.h")))
},
buildCopyFromSexp = function(){
functionArgName <- Rname2CppName(paste0('S_nimList_'))
interfaceArgs <- symbolTable()
interfaceArgs$addSymbol(cppSEXP(name = functionArgName))
objects <- symbolTable2cppVars(nimCompProc$symTab)
argNames <- nimCompProc$symTab$getSymbolNames() ##not actually arg names any more, but names of nimbleListElements
copyFromListLines <- list()
copyLines <- list()
Snames <- character(length(argNames))
returnType <- "void"
listElementTable <- symbolTable()
storeSexpLine <- list(quote(cppLiteral('R_PreserveObject(RObjectPointer = S_nimList_);')))
environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment
listElementTable$addSymbol(cppSEXP(name = environmentCPPName))
envLine <- substitute({PROTECT(ENVNAME <- Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(ENVNAME, 0, PROTECT(Rf_mkChar(".xData")));},
list(ENVNAME = as.name(environmentCPPName)))
for(i in seq_along(argNames)) {
Snames[i] <- Rname2CppName(paste0('S_', argNames[i]))
listElementTable$addSymbol(cppSEXP(name = Snames[i]))
copyFromListLines[[i]] <- substitute(PROTECT(SVAR <- Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, XDATA)), Rf_install(ARGNAME))),
list(ARGNAME = argNames[i],
SVAR = as.name(Snames[i]),
XDATA = as.name(environmentCPPName)))
copyLine <- buildCopyLineFromSEXP(listElementTable$getSymbolObject(Snames[i]),
nimCompProc$symTab$getSymbolObject(argNames[i]))
copyLines <- c(copyLines, copyLine)
}
numArgs <- length(argNames)
unprotectLine <- substitute(UNPROTECT(N), list(N = 2 * numArgs + 1 + 1))
allCode <- embedListInRbracket(c(storeSexpLine, envLine,
copyFromListLines, copyLines,
list(unprotectLine)))
functionDefs[[paste0(name, "_copyFrom")]] <<- cppFunctionDef(name = "copyFromSEXP",
args = interfaceArgs,
code = cppCodeBlock(code = RparseTree2ExprClasses(allCode), objectDefs = listElementTable),
returnType = cppVoid(),
externC = FALSE,
CPPincludes = list(nimbleIncludeFile("RcppUtils.h"),
nimbleIncludeFile("smartPtrs.h")))
},
buildResetFlags = function(){
interfaceArgs <- symbolTable()
elementNames <- nimCompProc$symTab$getSymbolNames()
resetNestedFlagLines <- list()
listElementTable <- symbolTable()
resetFlagLine <- list(substitute(RCopiedFlag <- false,
list()))
for(i in seq_along(elementNames)){
elementSymTab <- nimCompProc$symTab$getSymbolObject(elementNames[i])
isList <- inherits(elementSymTab, 'symbolNimbleList')
if(isList){
resetRCopiedFlag <- paste0(elementSymTab$name,"->resetFlags();")
resetRCopiedFlagLine <- substitute(cppLiteral(resetText), list(resetText = resetRCopiedFlag))
resetNestedFlagLines <- c(resetNestedFlagLines,
resetRCopiedFlagLine)
}
}
resetRObjLines <- list(quote(cppLiteral("if(RObjectPointer) R_ReleaseObject(RObjectPointer); RObjectPointer=NULL;")))
allCode <- embedListInRbracket(c(resetFlagLine, resetNestedFlagLines, resetRObjLines))
functionDefs[[paste0(name, "_resetFlags")]] <<- cppFunctionDef(name = "resetFlags",
args = interfaceArgs,
code = cppCodeBlock(code = RparseTree2ExprClasses(allCode), objectDefs = listElementTable),
returnType = cppVoid(),
externC = FALSE,
CPPincludes = list(nimbleIncludeFile("RcppUtils.h"),
nimbleIncludeFile("smartPtrs.h")))
}
)
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.