tests and cleanup for user-defined opDefs

Author: perrydv

nCompiler/R/compile_eigenization.R

@@ -82,14 +82,18 @@ compile_eigenize <- function(code,
       if(!is.null(handlingInfo)) {
         beforeHandler <- handlingInfo[['beforeHandler']]
         if(!is.null(beforeHandler)) {
-          setupExprs <- c(setupExprs,
-                          eval(call(beforeHandler,
-                                    code,
-                                    symTab,
-                                    auxEnv,
-                                    workEnv,
-                                    handlingInfo),
-                               envir = eigenizeEnv))
+          if(is.function(beforeHandler))
+            setupExprs <- c(setupExprs,
+                            beforeHandler(code, symTab, auxEnv, workEnv, handlingInfo))
+          else
+            setupExprs <- c(setupExprs,
+                            eval(call(beforeHandler,
+                                      code,
+                                      symTab,
+                                      auxEnv,
+                                      workEnv,
+                                      handlingInfo),
+                                envir = eigenizeEnv))
           # return(if(length(setupExprs) == 0) NULL else setupExprs)
         }
       }
@@ -112,14 +116,18 @@ compile_eigenize <- function(code,
       if(!is.null(handlingInfo)) {
         handler <- handlingInfo[['handler']]       
         if(!is.null(handler)) {
-          setupExprs <- c(setupExprs,
-                          eval(call(handler,
-                                    code,
-                                    symTab,
-                                    auxEnv,
-                                    workEnv,
-                                    handlingInfo),
-                               envir = eigenizeEnv))
+          if(is.function(handler))
+            setupExprs <- c(setupExprs,
+                            handler(code, symTab, auxEnv, workEnv, handlingInfo))
+          else
+            setupExprs <- c(setupExprs,
+                            eval(call(handler,
+                                      code,
+                                      symTab,
+                                      auxEnv,
+                                      workEnv,
+                                      handlingInfo),
+                                envir = eigenizeEnv))
         }
       }
     # }

nCompiler/R/compile_generateCpp.R

@@ -105,10 +105,13 @@ compile_generateCpp <- function(code,
       if(!is.null(handler)) {
         if (logging)
           appendToLog(paste('Calling handler', handler, 'for', code$name))
-        res <- eval(call(handler,
-                         code,
-                         symTab),
-                    envir = genCppEnv)
+        if(is.function(handler))
+          res <- handler(code, symTab)
+        else
+          res <- eval(call(handler,
+                          code,
+                          symTab),
+                      envir = genCppEnv)
         if (logging) {
           appendToLog(paste('Finished handling', handler, 'for',
                             code$name, 'with result:'))

nCompiler/R/compile_labelAbstractTypes.R

@@ -112,8 +112,11 @@ compile_labelAbstractTypes <- function(code,
         if(!is.null(handler)) {
           if (logging)
             appendToLog(paste('Calling handler', handler, 'for', code$name))
-          ans <- eval(call(handler, code, symTab, auxEnv, handlingInfo),
-                      envir = labelAbstractTypesEnv)
+          if(is.function(handler))
+            ans <- handler(code, symTab,  auxEnv, handlingInfo)
+          else
+            ans <- eval(call(handler, code, symTab, auxEnv, handlingInfo),
+                        envir = labelAbstractTypesEnv)
           nErrorEnv$stateInfo <- character()
           if (logging) {
             appendToLog(paste('Finished handling', handler, 'for', code$name))

nCompiler/R/compile_normalizeCalls.R

@@ -169,7 +169,7 @@ update_cachedOpInfo <- function(code, where, allowFail=FALSE) {
   if(is.null(opDef)) {
     ## At this point, we have not found an nFunction or nClass method.
     if(is_NCgenerator) {
-      opDef <- where$compileInfo$opDefs[[code$name]]
+      opDef <- NCinternals(where)$compileInfo$opDefs[[code$name]]
       if(!is.null(opDef)) {
         cachedOpInfo$case <- "nClass method" # this could be a pure keyword or an nFunction with opDef provided at the nClass level
         # a pure keyword will have obj_internals == NULL, providing a way to 

nCompiler/tests/testthat/nCompile_tests/test-compileNimble.R

@@ -33,61 +33,3 @@ test_that("compileNimble bridge works for one nimbleFunction object", {
 ## add nClass to nCompiler:::compileNimble
 ##
 ## document, document, document
-
-test_that("registering a user-defined operator definition (opDef) works", {
-  ## first version: provide a function
-  nimArrayHandler <- function(code,...) {
-    code$name <- 'nArray'
-    NULL
-  }
-  # This test works by:
-  # providing a handler to relpace "nimArray" with "nArray"
-  # and a handler to replace "nimArray2" with "nArray" to
-  # check on handling multiple cases.
-  registerOpDef(
-    list(nimArray =
-           list(
-             matchDef = function(value=0, dim=c(1,1), init=TRUE,
-                                 fillZeros=TRUE, recycle=TRUE, nDim,
-                                 type="double") {},
-             #    normalizeCalls=list(handler='skip'),
-             simpleTransformations=list(handler = nimArrayHandler))))
-  expect_equal(ls(`:::`("nCompiler", "operatorDefUserEnv")), "nimArray")
-
-  registerOpDef(
-    list(nimArray2 =
-           list(
-             matchDef = function(value=0, dim=c(1,1), init=TRUE,
-                                 fillZeros=TRUE, recycle=TRUE, nDim,
-                                 type="double") {},
-             simpleTransformations=list(handler = 'replace',
-                                        replacement = 'nArray'))))
-  expect_equal(ls(`:::`("nCompiler", "operatorDefUserEnv")), c("nimArray", "nimArray2"))
-
-  nc <- nClass(
-    Cpublic = list(
-      foo = nFunction(
-        function() {
-          ans <- nimArray( 6, dim = 2)
-          ans2 <- nArray(value = 5, dim = 2)
-          return(ans)
-          returnType('double(1)')
-        }
-      ),
-      foo2 = nFunction(
-        function() {
-          ans <- nimArray2(3,dim = 2)
-          return(ans)
-          returnType('double(1)')
-        })
-      ))
-  Cnc <- nCompile(nc)
-  obj <- Cnc$new()
-  expect_identical(obj$foo(), c(6, 6))
-  expect_identical(obj$foo2(), c(3, 3))
-  rm(obj); gc()
-  #
-  deregisterOpDef("nimArray")
-  deregisterOpDef("nimArray2")
-  expect_equal(length(ls(`:::`("nCompiler", "operatorDefUserEnv"))), 0)
-})