split a string basic type away from symbolBase

nCompiler/R/compile_labelAbstractTypes.R

@@ -1471,7 +1471,7 @@ inLabelAbstractTypesEnv(
         if(auxEnv$returnSymbol$nDim==0) {
           # if the return is a literal, check for a case like return(2) <integer> with return type "double"
           if(code$args[[1]]$isLiteral) {
-            # What other cases are there here?
+            # Are there additional cases to warn on for literals other than returning an integer to a double?
             # returning anything to a logical is ok
             type_mismatch <- FALSE
             if(auxEnv$returnSymbol$type == "integer" && code$type$type == "double")

nCompiler/R/symbolTable.R

@@ -35,6 +35,23 @@ symbolBase <- R6::R6Class(
   )
 )
 
+symbolVoid <- R6::R6Class(
+  classname = 'symbolVoid',
+  inherit = symbolBase,
+  portable = TRUE,
+  public = list(
+    initialize = function(...) {
+      super$initialize(type = 'void', ...)
+    },
+    shortPrint = function()"void",
+    uniqueID = function() "void",
+    print = function() "void",
+    genCppVar = function() {
+      cppVoid()
+    }
+  )
+)
+
 ## nDim and size are redundant for convenience with one exception:
 ## nDim = 0 must have size = 1 and means it is a true scalar -- NOT sure this is correct anymore...
 ## nDim = 1 with size = 1 means it is a 1D vector that happens to be length 1
@@ -43,9 +60,9 @@ symbolBase <- R6::R6Class(
 ##   In cases such as x[3:3, 2:4] or x[c(3), 2:4], nimble's system for 
 ##   symbolic sizeExprs determines that 3:3 or c(3) have sizeExpr "1"
 ##   and then the bracket processing will drop the index (if drop=TRUE)
-symbolBasic <-
+symbolScalarOrTensor <-
   R6::R6Class(
-    classname = 'symbolBasic',
+    classname = 'symbolScalarOrTensor',
     inherit = symbolBase,
     portable = TRUE,
     public = list(
@@ -66,14 +83,8 @@ symbolBasic <-
         self$isConst <- isConst
         self
       },
-      shortPrint = function() {
-        paste0(switch(self$type,
-                      double = 'D',
-                      integer = 'I',
-                      logical = 'L',
-                      AD = 'AD',
-                      'Other'),
-               self$nDim)
+      shortPrint = function(prefix = '') {
+        paste0(prefix, self$nDim)
       },
       uniqueID = function(...) {
         self$shortPrint()
@@ -91,20 +102,9 @@ symbolBasic <-
                      )
         }
       },
-      genCppVar = function() {
+      genCppVar = function(cType = NULL) {
+        if(is.null(cType)) stop("should not be calling symbolScalarOrTensor$genCppVar without a cType")
         isArg <- self$isArg
-        type <- self$type
-        if(type == 'void') return(cppVoid())
-        else if(type == 'integer') cType <- 'int'
-        else if(type == 'double') cType <- 'double'
-        else if(type == 'logical') cType <- 'bool'
-        else if(type == 'AD') cType <- 'CppAD::AD<double>'
-        else if(type == 'string') cType <- 'std::string'
-        else warning(paste("in genCppVar method for",
-                           self$name,
-                           "in symbolBasic class,",
-                           "type", type,"unrecognized\n"),
-                     FALSE)
         if(self$nDim == 0) {
           if(identical(self$name, "pi"))
             return(cppVarFullClass$new(baseType = cType,
@@ -144,6 +144,58 @@ symbolBasic <-
     )
   )
 
+symbolBasic <- R6::R6Class(
+  classname = "symbolBasic",
+  inherit = symbolScalarOrTensor,
+  portable = TRUE,
+  public = list(
+    initialize = function(...) {
+      super$initialize(...)
+    },
+    shortPrint = function() {
+      prefix <- switch(self$type,
+                    double = 'D',
+                    integer = 'I',
+                    logical = 'L',
+                    AD = 'AD',
+                    'Other')
+      super$shortPrint(prefix = prefix)
+    },
+    genCppVar = function() {
+      cType <- NULL
+      type <- self$type
+      if(type == 'integer') cType <- 'int'
+      else if(type == 'double') cType <- 'double'
+      else if(type == 'logical') cType <- 'bool'
+      else if(type == 'AD') cType <- 'CppAD::AD<double>'
+      else warning(paste("in genCppVar method for",
+                    self$name,
+                    "in symbolBasic class,",
+                    "type", type,"unrecognized\n"),
+              FALSE)
+      super$genCppVar(cType = cType)
+    }
+
+  )
+)
+
+symbolBasicString <- R6::R6Class(
+  classname = "symbolBasicString",
+  inherit = symbolScalarOrTensor,
+  portable = TRUE,
+  public = list(
+    initialize = function(...) {
+      super$initialize(..., type = "string")
+    },
+    shortPrint = function() {
+      super$shortPrint(prefix = 'S')
+    },
+    genCppVar = function() {
+      super$genCppVar(cType = 'std::string')
+    }
+  )
+)
+
 symbolBlank <- R6::R6Class(
   classname = "symbolBlank",
   inherit = symbolBase,
@@ -666,8 +718,7 @@ symbolSparse <- R6::R6Class(
     genCppVar = function() {
       isArg <- self$isArg
       type <- self$type
-      if(type == 'void') return(cppVoid())
-      else if(type == 'integer') cType <- 'int'
+      if(type == 'integer') cType <- 'int'
       else if(type == 'double') cType <- 'double'
       else if(type == 'logical') cType <- 'bool'
       else if(type == 'AD') cType <- 'CppAD::AD<double>'

nCompiler/R/typeDeclarations.R

@@ -306,10 +306,10 @@ typeDeclarationList <- list(
     nTypeBasic("logical", nDim, ...)
   },
   void = function(...) {
-    nTypeBasic("void", 0, ...)
+    symbolVoid$new(...)
   },
   string = function(...) {
-    nTypeBasic("string", 0, ...)
+    symbolBasicString$new(nDim = 0, ...)
   },
   ##
   SEXP = function(...) {

nCompiler/tests/testthat/types_tests/test-RcppTypes.R

@@ -256,11 +256,11 @@ test_that("RcppS4 works in nFunctions", {
     }
   )
   nfs4C <- nCompile(nfs4)
-  
+
   # Taken from ?setClass
   track <- setClass("track", slots = c(x="numeric", y="numeric"))
   t1 <- track(x = 1:10, y = 1:10 + rnorm(10))
-  
+
   expect_true(nfs4C(t1))
 })
 
@@ -281,7 +281,7 @@ test_that("RcppFunction works", {
   set.seed(505)
   result1_Correct <- rnorm(10)
   expect_equal(result1, result1_Correct)
-  
+
   result2 <- nffnC(logit, 0.4)
   result2_correct <- logit(0.4)
   expect_equal(result2, result2_correct)
@@ -413,9 +413,9 @@ test_that("RcppNumericVector works in nClasses", {
     classname = "test_RcppNumericVector",
     Cpublic = list(
       x = "RcppNumericVector",
-      set_x = nFunction(fun = function(new_x = "RcppNumericVector") { 
+      set_x = nFunction(fun = function(new_x = "RcppNumericVector") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -436,9 +436,9 @@ test_that("RcppNumericMatrix works in nClasses", {
     classname = "test_RcppNumericMatrix",
     Cpublic = list(
       x = "RcppNumericMatrix",
-      set_x = nFunction(fun = function(new_x = "RcppNumericMatrix") { 
+      set_x = nFunction(fun = function(new_x = "RcppNumericMatrix") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -459,9 +459,9 @@ test_that("RcppIntegerVector works in nClasses", {
     classname = "test_RcppIntegerVector",
     Cpublic = list(
       x = "RcppIntegerVector",
-      set_x = nFunction(fun = function(new_x = "RcppIntegerVector") { 
+      set_x = nFunction(fun = function(new_x = "RcppIntegerVector") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -482,9 +482,9 @@ test_that("RcppIntegerMatrix works in nClasses", {
     classname = "test_RcppIntegerMatrix",
     Cpublic = list(
       x = "RcppIntegerMatrix",
-      set_x = nFunction(fun = function(new_x = "RcppIntegerMatrix") { 
+      set_x = nFunction(fun = function(new_x = "RcppIntegerMatrix") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -505,9 +505,9 @@ test_that("RcppCharacterVector works in nClasses", {
     classname = "test_RcppCharacterVector",
     Cpublic = list(
       x = "RcppCharacterVector",
-      set_x = nFunction(fun = function(new_x = "RcppCharacterVector") { 
+      set_x = nFunction(fun = function(new_x = "RcppCharacterVector") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -528,9 +528,9 @@ test_that("RcppCharacterMatrix works in nClasses", {
     classname = "test_RcppCharacterMatrix",
     Cpublic = list(
       x = "RcppCharacterMatrix",
-      set_x = nFunction(fun = function(new_x = "RcppCharacterMatrix") { 
+      set_x = nFunction(fun = function(new_x = "RcppCharacterMatrix") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -551,9 +551,9 @@ test_that("RcppComplexVector works in nClasses", {
     classname = "test_RcppComplexVector",
     Cpublic = list(
       x = "RcppComplexVector",
-      set_x = nFunction(fun = function(new_x = "RcppComplexVector") { 
+      set_x = nFunction(fun = function(new_x = "RcppComplexVector") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -574,9 +574,9 @@ test_that("RcppComplexMatrix works in nClasses", {
     classname = "test_RcppComplexMatrix",
     Cpublic = list(
       x = "RcppComplexMatrix",
-      set_x = nFunction(fun = function(new_x = "RcppComplexMatrix") { 
+      set_x = nFunction(fun = function(new_x = "RcppComplexMatrix") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -597,9 +597,9 @@ test_that("RcppLogicalVector works in nClasses", {
     classname = "test_RcppLogicalVector",
     Cpublic = list(
       x = "RcppLogicalVector",
-      set_x = nFunction(fun = function(new_x = "RcppLogicalVector") { 
+      set_x = nFunction(fun = function(new_x = "RcppLogicalVector") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -620,9 +620,9 @@ test_that("RcppLogicalMatrix works in nClasses", {
     classname = "test_RcppLogicalMatrix",
     Cpublic = list(
       x = "RcppLogicalMatrix",
-      set_x = nFunction(fun = function(new_x = "RcppLogicalMatrix") { 
+      set_x = nFunction(fun = function(new_x = "RcppLogicalMatrix") {
         x <- new_x
-        return(0) 
+        return(0)
       }, returnType = "integerScalar"
       )
     )
@@ -668,26 +668,26 @@ test_that("RcppLogicalMatrix works in nClasses", {
 #     classname = "test_RcppDatetimeVector",
 #     Cpublic = list(
 #       x = "RcppDatetimeVector",
-#       set_x = nFunction(fun = function(new_x = "RcppDatetimeVector") { 
+#       set_x = nFunction(fun = function(new_x = "RcppDatetimeVector") {
 #         x <- new_x
-#         return(0) 
+#         return(0)
 #       }, returnType = "integerScalar"
 #       )
 #     )
 #   )
 #   ncC <- nCompile(nc)
 #   my_nc <- ncC$new()
-#   test_x1 <- as.POSIXct(c(1593166562, 1593066562, 1592166562, 159316562), 
+#   test_x1 <- as.POSIXct(c(1593166562, 1593066562, 1592166562, 159316562),
 #                         origin = as.Date("1950-01-01"))
 #   my_nc$set_x(test_x1)
 #   expect_equal(my_nc$x, test_x1)
-#   test_x2 <- as.POSIXct(c(1493166562, 1593066562, 2592166562, 159316562), 
+#   test_x2 <- as.POSIXct(c(1493166562, 1593066562, 2592166562, 159316562),
 #                         origin = as.Date("1950-01-01"))
 #   my_nc$x <- test_x2
 #   expect_equal(my_nc$x, test_x2)
 # })
-# 
-# 
+#
+#
 test_that("RcppDataFrame works in nClasses", {
   nc <- nClass(
     classname = "test_RcppDataFrame",

nCompiler/tests/testthat/types_tests/test-types.R

@@ -462,6 +462,7 @@ test_that("Trap error from duplicate setting of isRef. (This should show a warni
   ## Error-trapping:
   ## Duplicate setting of ref
   a <- quote(ref(numericVector(5)))
+  cat("expecting an error:\n")
   expect_error(
     `:::`("nCompiler", "type2symbol")(O(!!a),
                                name = "a",
@@ -474,6 +475,7 @@ test_that("Trap error from duplicate setting of isRef. (This should show a warni
   ## Type incompatible with default
   a <- quote(matrix(1:4, nrow = 2, ncol = 2))
   aExplicit <- nType(numericVector())
+  cat("expecting an error:\n")
   expect_error(suppressWarnings( # this gives a warning and an error, so for testing we suppress the warning
     `:::`("nCompiler", "type2symbol")(O(!!a),
                                name = "a",
@@ -547,7 +549,7 @@ test_that("list arguments handled correctly",
   ## void() (return type default)
   vSym <- `:::`("nCompiler", "type2symbol")(quote(void()))
   expect_identical(vSym$type, "void")
-  expect_identical(vSym$nDim, 0)
+#  expect_identical(vSym$nDim, 0)
 })
 
 test_that("symbolTBD works",
@@ -634,3 +636,13 @@ test_that("types as objects work with an nClass", {
   obj$nf(1:3)
   expect_identical(obj$nf(1:3), 2:4)
 })
+
+test_that("string type works in nFunctions", {
+    foo <- nFunction(
+        fun=function(mystr = 'string'){
+            return(mystr)
+        }, returnType = 'string'
+    )
+    cfoo <- nCompile(foo)
+    expect_identical(cfoo("hw"),"hw")
+})