Skip to content

Commit 2784e26

Browse files
perrydvperrydv
authored
Update from Rf_findVar and Rf_findVarInFrame while maintaining backward compatibility if possible (#1616)
1 parent 6b2c5bd commit 2784e26

10 files changed

Lines changed: 325 additions & 413 deletions

File tree

‎packages/nimble/R/cppDefs_nimbleList.R‎

Lines changed: 15 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -59,7 +59,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
5959
## ptrToSmartPtrBase = dynamic_cast<nimSmartPtrBase*>(ptrToSmartPtr);
6060
## ptrToPtr = ptrToSmartPtr->getVoidPtrToRealPtr();
6161
## reinterpret_cast<nfRefClass_84*>(*static_cast<void**>(ptrToPtr))->NO_hw();
62-
62+
6363
## PROTECT(SptrToSmartPtrBase = R_MakeExternalPtr(ptrToSmartPtrBase, R_NilValue, R_NilValue));
6464
## PROTECT(SptrToPtr = R_MakeExternalPtr(ptrToPtr, R_NilValue, R_NilValue));
6565
## PROTECT(Sans = Rf_allocVector(VECSXP,2));
@@ -83,11 +83,11 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
8383
'PROTECT(SptrToSmartPtrBase = R_MakeExternalPtr(ptrToSmartPtrBase, R_NilValue, R_NilValue));',
8484
'PROTECT(SptrToPtr = R_MakeExternalPtr(ptrToPtr, R_NilValue, R_NilValue));'))
8585
allocVectorLine <- cppLiteral(paste0('PROTECT(Sans = Rf_allocVector(VECSXP,', 2, '));'))
86-
86+
8787
packListLines <- cppLiteral(c('SET_VECTOR_ELT(Sans,0,SptrToSmartPtrBase);',
8888
'SET_VECTOR_ELT(Sans,1,SptrToPtr);'
8989
))
90-
90+
9191
codeLines <- substitute({
9292
## Finalizer registration now happens through nimble's finalizer mapping system.
9393
UNPROTECT(3)
@@ -99,7 +99,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
9999
args = args,
100100
code = cppCodeBlock(code = allCode, objectDefs = CBobjectDefs, skipBrackets = TRUE),
101101
returnType = cppSEXP(),
102-
externC = TRUE)
102+
externC = TRUE)
103103
},
104104
buildSEXPgenerator = function(finalizer = NULL) {
105105
## Build a function that will provide a new object and return an external pointer.
@@ -197,7 +197,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
197197
listElementTable <- symbolTable()
198198
listElementTable$addSymbol(cppSEXP(name = "S_newNimList"))
199199
listElementTable$addSymbol(cppSEXP(name = "S_listName"))
200-
200+
201201
newListLine[[1]] <- substitute({PROTECT(S_listName <- Rf_allocVector(STRSXP, 1));
202202
SET_STRING_ELT(S_listName, 0, PROTECT(Rf_mkChar(LISTNAME)));},
203203
list(LISTNAME = nimCompProc$nimbleListObj$className))
@@ -225,28 +225,28 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
225225
listElementTable <- symbolTable()
226226
numElements <- length(elementNames)
227227
conditionalLineList <- list()
228-
228+
229229
conditionalClauseStart <- list(quote(cppLiteral('if (!RCopiedFlag){')))
230230
conditionalClauseEnd <- list(quote(cppLiteral('}')))
231-
environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment
231+
environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment
232232
listElementTable$addSymbol(cppSEXP(name = environmentCPPName))
233233
envLine <- substitute({PROTECT(ENVNAME <- Rf_allocVector(STRSXP, 1));
234234
SET_STRING_ELT(ENVNAME, 0, PROTECT(Rf_mkChar(".xData")));},
235235
list(ENVNAME = as.name(environmentCPPName)))
236-
236+
237237
for(i in seq_along(elementNames)){
238238
Snames[i] <- Rname2CppName(paste0('S_', elementNames[i]))
239239
listElementTable$addSymbol(cppSEXP(name = Snames[i]))
240240
elementSymTab <- nimCompProc$symTab$getSymbolObject(elementNames[i])
241241
conditionalLineList <- c(conditionalLineList, generateConditionalLines(nimCompProc$symTab$getSymbolObject(elementNames[i]),
242242
listElementTable$getSymbolObject(Snames[i])))
243-
243+
244244
copyToListLines[[i]] <- substitute(Rf_defineVar(Rf_install(ELEMENTNAME), VALUE, PROTECT(GET_SLOT(ROBJ, XDATA))),
245245
list(ELEMENTNAME = elementNames[i], VALUE = as.name(Snames[i]),
246246
ROBJ = as.name('RObjectPointer'),
247247
XDATA = as.name(environmentCPPName)))
248248
}
249-
249+
250250
setFlagLine <- list(substitute(RCopiedFlag <- true,
251251
list()))
252252
returnLine <- list(substitute(return(ROBJ),
@@ -276,7 +276,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
276276
listElementTable <- symbolTable()
277277
storeSexpLine <- list(quote(cppLiteral('R_PreserveObject(RObjectPointer = S_nimList_);')))
278278

279-
environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment
279+
environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment
280280
listElementTable$addSymbol(cppSEXP(name = environmentCPPName))
281281
envLine <- substitute({PROTECT(ENVNAME <- Rf_allocVector(STRSXP, 1));
282282
SET_STRING_ELT(ENVNAME, 0, PROTECT(Rf_mkChar(".xData")));},
@@ -285,8 +285,8 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
285285
for(i in seq_along(argNames)) {
286286
Snames[i] <- Rname2CppName(paste0('S_', argNames[i]))
287287
listElementTable$addSymbol(cppSEXP(name = Snames[i]))
288-
copyFromListLines[[i]] <- substitute(PROTECT(SVAR <- Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, XDATA)), Rf_install(ARGNAME))),
289-
list(ARGNAME = argNames[i],
288+
copyFromListLines[[i]] <- substitute(PROTECT(SVAR <- NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, XDATA)), Rf_install(ARGNAME))),
289+
list(ARGNAME = argNames[i],
290290
SVAR = as.name(Snames[i]),
291291
XDATA = as.name(environmentCPPName)))
292292
copyLine <- buildCopyLineFromSEXP(listElementTable$getSymbolObject(Snames[i]),
@@ -295,7 +295,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
295295
}
296296
numArgs <- length(argNames)
297297
unprotectLine <- substitute(UNPROTECT(N), list(N = 2 * numArgs + 1 + 1))
298-
allCode <- embedListInRbracket(c(storeSexpLine, envLine,
298+
allCode <- embedListInRbracket(c(storeSexpLine, envLine,
299299
copyFromListLines, copyLines,
300300
list(unprotectLine)))
301301
functionDefs[[paste0(name, "_copyFrom")]] <<- cppFunctionDef(name = "copyFromSEXP",
@@ -311,7 +311,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
311311
elementNames <- nimCompProc$symTab$getSymbolNames()
312312
resetNestedFlagLines <- list()
313313
listElementTable <- symbolTable()
314-
314+
315315
resetFlagLine <- list(substitute(RCopiedFlag <- false,
316316
list()))
317317

0 commit comments

Comments
 (0)