R/nativeEnum.R

In duncantl/RCodeGen: Functionality to help creating code for R, C/C++

# Compare with code in REnum.R
#
# Generate the native code for an enum
#

# For a simple enum (not bitwise enum), we want to generate
# a routine that has a large switch statemnent with a case
# for each possible value. Each case sets the name (elName)
# Then we can can call a routine that creates the instance
#  R_makeEnum(value, elName,  className).
#

makeEnumConverter =
function(def, routineName = getEnumConvertRoutineName(def), prefix = character(), ...)
{
  funName = routineName


  def@values = def@values[ !duplicated(def@values) ]
  
  toR = c(paste("SEXP", funName, "(",  getName(getCanonicalType(def@type)),  " val)"),
          "{",
          "const char *elName = NULL;",
          "SEXP klass, ans;")
  
  toR = c(toR, 
          c("switch(val) {",
	     sapply(names(def@values),
	              function(id) {
	                paste("   case ", id, ":\n           ",  "elName = \"",  id, "\";\n       break;", collapse = "\n", sep = "")
	              }),
            "    default:",
            '\telName = "?";',
	    "\t}\n\n"))


  className = getRTypeName(def@type)
  toR = c(toR,
               "#if defined(USE_S4_ENUMS)", "",
               "SEXP tmp;",
               paste('PROTECT(klass = MAKE_CLASS("',  className, '"));', sep = ""),
               'PROTECT(ans = NEW(klass));',
               "PROTECT(tmp = Rf_ScalarInteger(val));",    
               "SET_NAMES(tmp, Rf_mkString(elName));",    
               'ans = SET_SLOT(ans, Rf_install(".Data"), tmp);',
               "UNPROTECT(3);",
               "",   
               "#else",
               "",
               "PROTECT(ans = Rf_ScalarInteger(val));",    
               "SET_NAMES(ans, Rf_mkString(elName));",
               "PROTECT(klass = NEW_CHARACTER(2));",    
               paste("SET_STRING_ELT(klass, 0, Rf_mkChar(", dQuote(className), "));", sep = ""),
               'SET_STRING_ELT(klass, 1, Rf_mkChar("EnumValue"));',
               "SET_CLASS(ans, klass);",
               "UNPROTECT(2);",
               "",
               "#endif",
               "",
               "return(ans);")

  toR = c(toR, "\n}\n")
  
  CRoutineDefinition(funName, toR, 1)
}



getEnumConvertRoutineName =
function(def)
{
 if(is(def, "CXType"))
    type = def
  else
    type = def@type

#if(grepl("CUfunc_cache", id <- getName(getCanonicalType(type)) ))   recover()
  
  sprintf("Renum_convert_%s", gsub("enum ", "", getName(getCanonicalType(type))))
}