##############################################################
## Section for outputting C++ code from an exprClass object ##
##############################################################
cppOutputCalls <- c(makeCallList(binaryMidOperators, 'cppOutputMidOperator'),
makeCallList(binaryMidLogicalOperators, 'cppOutputMidOperator'),
makeCallList(binaryOrUnaryOperators, 'cppOutputBinaryOrUnary'),
makeCallList(assignmentOperators, 'cppOutputMidOperator'),
makeCallList(nonNativeEigenProxyCalls, 'cppOutputNonNativeEigen'),
makeCallList(eigProxyCalls, 'cppOutputEigMemberFunction'),
makeCallList(eigCalls, 'cppOutputMemberFunction'),
makeCallList(c('setSize', 'size', 'getPtr', 'dim', 'getOffset', 'strides', 'isMap', 'mapCopy', 'setMap'), 'cppOutputMemberFunction'),
makeCallList(eigOtherMemberFunctionCalls, 'cppOutputEigMemberFunctionNoTranslate'),
makeCallList(eigProxyCallsExternalUnary, 'cppOutputEigExternalUnaryFunction'),
list('for' = 'cppOutputFor',
'if' = 'cppOutputIfWhile',
'while' = 'cppOutputIfWhile',
'[' = 'cppOutputBracket',
mvAccessRow = 'cppOutputBracket',
'(' = 'cppOutputParen',
## setSize = 'cppOutputMemberFunction',
resize = 'cppOutputMemberFunctionDeref',
nfMethod = 'cppOutputNFmethod',
nfVar = 'cppOutputNFvar',
getsize = 'cppOutputMemberFunctionDeref',
## size = 'cppOutputMemberFunction',
resizeNoPtr = 'cppOutputMemberFunction',
## getPtr = 'cppOutputMemberFunction',
## dim = 'cppOutputMemberFunction',
## strides = 'cppOutputMemberFunction',
AssignEigenMap = 'cppOutputEigenMapAssign',
chainedCall = 'cppOutputChainedCall',
template = 'cppOutputTemplate',
nimPrint = 'cppOutputCout',
return = 'cppOutputReturn',
cppPtrType = 'cppOutputPtrType', ## mytype* (needed in templates like myfun<a*>(b)
cppDereference = 'cppOutputDereference', ## *(arg)
cppMemberDereference = 'cppOutputMidOperator', ## arg1->arg2
## access = 'cppOutputAccess',
## mvAccess = 'cppOutputMVAccess',
## nimFunListAccess = 'cppOutputNimFunListAccess',
'[[' = 'cppOutputDoubleBracket',
as.integer = 'cppOutputCast',
as.numeric = 'cppOutputCast',
numListAccess = 'cppOutputNumList',
blank = 'cppOutputBlank',
callC = 'cppOutputEigBlank', ## not really eigen, but this just jumps over a layer in the parse tree
eigBlank = 'cppOutputEigBlank'
)
)
cppOutputCalls[['pow']] <- 'cppOutputPow'
##cppMidOperators <- list('%*%' = ' * ', '*' = ' * ','+' = ' + ', '<-' = ' = ', '==' = ' == ')
cppMidOperators <- midOperators
cppMidOperators[['%*%']] <- ' * '
##cppMidOperators[['%%']] <- ' % '
cppMidOperators[['cppMemberDereference']] <- '->'
cppMidOperators[['nfVar']] <- '->'
cppMidOperators[['&']] <- ' && '
cppMidOperators[['|']] <- ' || '
for(v in c('$', ':')) cppMidOperators[[v]] <- NULL
for(v in assignmentOperators) cppMidOperators[[v]] <- ' = '
nimCppKeywordsThatFillSemicolon <- c('{','for',ifOrWhile)
## In the following list, the names are names in the parse tree (i.e. the name field in an exprClass object)
## and the elements are the name of the function to use to generate output for that name
## e.g. if the parse tree has "dim(A)" (meaning there is an exprClass object with name = "dim", isCall = TRUE, and a single
## argument that is an exprClass object with name = "A" and isName = TRUE)
## then cppOutputMemberFunction will be called, which will generate A.dim()
## Main function for generating C++ output
nimGenerateCpp <- function(code, symTab = NULL, indent = '', showBracket = TRUE, asArg = FALSE) {
if(is.numeric(code)) return(code)
# if(is.numeric(code)) return( if(code == as.integer(code)) paste0(code, ".") else code)
if(is.character(code)) return(paste0('\"', gsub("\\n","\\\\n", code), '\"'))
if(is.null(code)) return('R_NilValue')
if(is.logical(code) ) return(code)
if(is.list(code) ) stop("Error generating C++ code, there is a list where there shouldn't be one. It is probably inside map information.", call. = FALSE)
if(length(code$isName) == 0) browser()
if(code$isName) return(exprName2Cpp(code, symTab, asArg))
if(code$name == '{') {
iOffset <- as.integer(showBracket)
ans <- vector('list', length(code$args) + 2*iOffset)
if(showBracket) ans[[1]] <- paste0(indent, '{')
newInd <- if(showBracket) paste0(indent, ' ') else indent
for(i in seq_along(code$args)) {
oneEntry <- nimGenerateCpp(code$args[[i]], symTab, newInd, FALSE)
if(code$args[[i]]$isCall) if(!(code$args[[i]]$name %in% nimCppKeywordsThatFillSemicolon)) oneEntry <- pasteSemicolon(oneEntry)
ans[[i + iOffset]] <- if(showBracket) addIndentToList(oneEntry, newInd) else oneEntry
}
if(showBracket) ans[[length(code$args) + 2]] <- paste0(indent, '}')
return(ans)
}
operatorCall <- cppOutputCalls[[code$name]]
if(!is.null(operatorCall)) return(eval(call(operatorCall, code, symTab)))
return(cppOutputCallAsIs(code, symTab))
}
exprName2Cpp <- function(code, symTab, asArg = FALSE) {
if(!is.null(symTab)) {
sym <- symTab$getSymbolObject(code$name, inherits = TRUE)
if(!is.null(sym)) return(sym$generateUse(asArg = asArg))
return(code$name)
} else {
return(code$name)
}
}
cppOutputBlank <- function(code, symTab) NULL
cppOutputEigBlank <- function(code, symTab) {
paste0('(', nimGenerateCpp(code$args[[1]], symTab), ')')
}
cppOutputNumList <- function(code, symTab) {
paste0( nimGenerateCpp(code$args[[1]], symTab))
}
cppOutputReturn <- function(code, symTab) {
if(length(code$args) == 0) {
return('return')
}
cppOutputCallAsIs(code, symTab)
}
cppOutputCout <- function(code, symTab) {
paste0('std::cout <<', paste0(unlist(lapply(code$args, nimGenerateCpp, symTab, asArg = TRUE) ), collapse = '<<'), '<<\"\\n\"')
}
cppOutputChainedCall <- function(code, symTab) {
firstCall <- nimGenerateCpp(code$args[[1]], symTab)
## now similar to cppOutputCallAsIs
paste0(firstCall, '(', paste0(unlist(lapply(code$args[-1], nimGenerateCpp, symTab, asArg = TRUE) ), collapse = ', '), ')' )
}
cppOutputFor <- function(code, symTab) {
if(code$args[[2]]$name != ':') stop('Error: for now for loop ranges must be defined with :')
begin <- nimGenerateCpp(code$args[[2]]$args[[1]], symTab)
end <- nimGenerateCpp(code$args[[2]]$args[[2]], symTab)
iterVar <- nimGenerateCpp(code$args[[1]], symTab)
part1 <- paste0('for(', iterVar ,'=', begin,'; ', iterVar, '<=', end, '; ++', iterVar,')')
part2 <- nimGenerateCpp(code$args[[3]], symTab)
if(is.list(part2)) {
part2[[1]] <- paste(part1, part2[[1]])
return(part2)
} else {
return(paste(part1, part2))
}
}
cppOutputIfWhile <- function(code, symTab) {
part1 <- paste0(code$name,'(', nimGenerateCpp(code$args[[1]], symTab), ')')
part2 <- nimGenerateCpp(code$args[[2]], symTab)
if(is.list(part2)) {
part2[[1]] <- paste(part1, part2[[1]])
} else {
part2 <- list(paste(part1, part2))
}
if(length(code$args)==2) return(part2)
part3 <- nimGenerateCpp(code$args[[3]], symTab)
if(is.list(part3)) {
part2[[length(part2)]] <- paste(part2[[length(part2)]], 'else', part3[[1]])
part3 <- c(part2, part3[-1])
return(part3)
} else {
part2[[length(part2)]] <- paste(part2[[length(part2)]], 'else', part3)
return(part2)
}
stop('Error in cppOutputIf')
}
cppOutputEigenMapAssign <- function(code, symTab) {
useStrides <- length(code$args) > 5
strideTemplateDec <- if(useStrides) {
if(!(is.numeric(code$args[[6]]) & is.numeric(code$args[[7]]) ) ) {
bothStridesDyn <- TRUE
paste0('EigStrDyn')
} else {
bothStridesDyn <- FALSE
paste0(', Stride<', if(is.numeric(code$args[[6]])) code$args[[6]] else 'Dynamic', ', ', if(is.numeric(code$args[[7]])) code$args[[7]] else 'Dynamic','>')
}
} else character()
strideConstructor <- if(useStrides) {
paste0(strideTemplateDec, '(', nimGenerateCpp(code$args[[6]], symTab),', ', nimGenerateCpp(code$args[[7]], symTab), ')')
} else character()
MapType <- if(!useStrides) {
paste0('Map< ', code$args[[3]]$name,' >')
} else {
if(bothStridesDyn) 'EigenMapStr'
else paste0('Map< ', code$args[[3]]$name, ', Unaligned, ', strideTemplateDec,' >')
}
paste0('new (&', nimGenerateCpp(code$args[[1]], symTab),') ', MapType, '(', paste(c(nimGenerateCpp(code$args[[2]], symTab), nimGenerateCpp(code$args[[4]], symTab), nimGenerateCpp(code$args[[5]], symTab), strideConstructor), collapse = ','), ')')
}
cppOutputMemberFunction <- function(code, symTab) {
paste0( nimGenerateCpp(code$args[[1]], symTab), '.', paste0(code$name, '(', paste0(unlist(lapply(code$args[-1], nimGenerateCpp, symTab) ), collapse = ', '), ')' ))
}
cppOutputEigExternalUnaryFunction <- function(code, symTab) {
info <- eigProxyTranslateExternalUnary[[code$name]]
if(length(info) != 3) stop(paste0("Invalid information entry for outputting eigen version of ", code$name), call. = FALSE)
paste0( '(', nimGenerateCpp(code$args[[1]], symTab), ').unaryExpr(std::ptr_fun<',info[2],', ',info[3],'>(', info[1], '))')
}
## like cppOutputCallAsIs but using eigProxyTranslate on the name
cppOutputNonNativeEigen <- function(code, symTab) {
paste0(eigProxyTranslate[code$name], '(', paste0(unlist(lapply(code$args, nimGenerateCpp, symTab, asArg = TRUE) ), collapse = ', '), ')' )
}
cppOutputEigMemberFunction <- function(code, symTab) {
paste0( '(', nimGenerateCpp(code$args[[1]], symTab), ').', paste0(eigProxyTranslate[code$name], '(', paste0(unlist(lapply(code$args[-1], nimGenerateCpp, symTab) ), collapse = ', '), ')' ))
}
cppOutputEigMemberFunctionNoTranslate <- function(code, symTab) {
paste0( '(', nimGenerateCpp(code$args[[1]], symTab), ').', paste0(code$name, '(', paste0(unlist(lapply(code$args[-1], nimGenerateCpp, symTab) ), collapse = ', '), ')' ))
}
cppOutputMemberFunctionDeref <- function(code, symTab) {
paste0( nimGenerateCpp(code$args[[1]], symTab), '->', paste0(code$name, '(', paste0(unlist(lapply(code$args[-1], nimGenerateCpp, symTab) ), collapse = ', '), ')' ))
}
cppOutputNFvar <- function(code, symTab) {
if(length(code$args) != 2) stop('Error: expecting 2 arguments for operator ',code$name)
paste0( nimGenerateCpp(code$args[[1]], symTab), '.', code$args[[2]] ) ## No nimGenerateCpp on code$args[[2]] because it should be a string
}
cppOutputNFmethod <- function(code, symTab) {
if(length(code$args) < 2) stop('Error: expecting at least 2 arguments for operator ',code$name)
paste0( nimGenerateCpp(code$args[[1]], symTab), '.', code$args[[2]]) ##, ## No nimGenerateCpp on code$args[[2]] because it should be a string
##'(', paste0(unlist(lapply(code$args[-c(1,2)], nimGenerateCpp, symTab)), collapse = ','), ')' )
## This used to take method args in this argList. But now they are in a chainedCall
}
cppOutputMidOperator <- function(code, symTab) {
if(length(code$args) != 2) stop('Error: expecting 2 arguments for operator ',code$name)
if(is.null(code$caller)) useParens <- FALSE
else {
thisRank <- operatorRank[[code$name]]
callingRank <- if(!is.null(code$caller)) operatorRank[[code$caller$name]] else NULL
useParens <- FALSE ## default to FALSE - possibly dangerous if we've missed a case
if(!is.null(callingRank)) {
if(!is.null(thisRank)) {
if(callingRank <= thisRank) useParens <- TRUE
}
}
}
useDoubleCast <- FALSE
if(code$name == '/') ## cast the denominator to double if it is any numeric or if it is an scalar integer expression
if(is.numeric(code$args[[2]]) ) useDoubleCast <- TRUE
else if(identical(code$args[[2]]$type, 'integer'))
if(identical(code$args[[2]]$nDim, 0)) useDoubleCast <- TRUE
secondPart <- nimGenerateCpp(code$args[[2]], symTab)
if(useDoubleCast) secondPart <- paste0('static_cast<double>(', secondPart, ')')
if(useParens)
paste0( '(',nimGenerateCpp(code$args[[1]], symTab), cppMidOperators[[code$name]],secondPart,')' )
else
paste0( nimGenerateCpp(code$args[[1]], symTab), cppMidOperators[[code$name]],secondPart)
}
cppOutputBinaryOrUnary <- function(code, symTab) {
if(length(code$args) == 2) return(cppOutputMidOperator(code, symTab))
cppOutputCallAsIs(code, symTab)
}
cppMinusOne <- function(x) {
if(is.numeric(x)) return(x-1)
##RparseTree2ExprClasses(substitute(A-1, list(A = x)))
paste0('(',x,') - 1')
}
cppOutputBracket <- function(code, symTab) {
brackets <- if(length(code$args) <= 2) c('[',']') else c('(',')')
paste0( nimGenerateCpp(code$args[[1]], symTab), brackets[1], paste0(unlist(lapply(code$args[-1], function(x) cppMinusOne(nimGenerateCpp(x, symTab) ) ) ), collapse = ', '), brackets[2] )
}
cppOutputDoubleBracket <- function(code, symTab) {
## right now the only case is from a functionList, so we'll go straight there.
cppOutputNimFunListAccess(code, symTab)
}
cppOutputNimFunListAccess <- function(code, symTab) {
paste0( '(*', nimGenerateCpp(code$args[[1]], symTab), '[', cppMinusOne(nimGenerateCpp(code$args[[2]], symTab) ), '])' )
}
cppOutputParen <- function(code, symTab) {
paste0('(', paste0(unlist(lapply(code$args, nimGenerateCpp, symTab) ), collapse = ', '), ')' )
}
cppOutputCall <- function(code, symTab) {
paste0(cppCalls[[code$name]], '(', paste0(unlist(lapply(code$args, nimGenerateCpp, symTab ), collapse = ', '), ')' ))
}
cppOutputPow <- function(code, symTab) {
useStaticCase <- if(is.numeric(code$args[[2]]) ) TRUE else identical(code$args[[2]]$nDim, 0)
if(useStaticCase)
paste0(exprName2Cpp(code, symTab), '( static_cast<double>(',nimGenerateCpp(code$args[[1]], symTab, asArg = TRUE),'),', nimGenerateCpp(code$args[[2]], symTab, asArg = TRUE),')')
else
paste0(exprName2Cpp(code, symTab), '(',nimGenerateCpp(code$args[[1]], symTab, asArg = TRUE),',', nimGenerateCpp(code$args[[2]], symTab, asArg = TRUE),')')
}
cppOutputCallAsIs <- function(code, symTab) {
paste0(exprName2Cpp(code, symTab), '(', paste0(unlist(lapply(code$args, nimGenerateCpp, symTab, asArg = TRUE) ), collapse = ', '), ')' )
}
cppOutputCast <- function(code, symTab) {
paste0('static_cast<', cppCasts[[code$name]], '>(', nimGenerateCpp(code$args[[1]], symTab), ')')
}
cppOutputCallWithName <- function(code, symTab, name) {
paste0(name, '(', paste0(unlist(lapply(code$args, nimGenerateCpp, symTab, asArg = TRUE) ), collapse = ', '), ')' )
}
cppOutputPtrType <- function(code, symTab) {
paste0( nimGenerateCpp(code$args[[1]], symTab), '*' )
}
cppOutputDereference <- function(code, symTab) {
cppOutputCallWithName(code, symTab, '*')
}
cppOutputTemplate <- function(code, symTab) {
paste0(code$args[[1]]$name, '<', paste0(unlist(lapply(code$args[-1], nimGenerateCpp, symTab, asArg = TRUE) ), collapse = ', '), '>' )
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.