Support for user-defined operator definitions (opDefs)

nCompiler/R/NF_InternalsClass.R

@@ -15,7 +15,8 @@ NF_InternalsClass <- R6::R6Class(
     isMethod = FALSE,
     uniqueName = character(),
     cpp_code_name = character(),
-    ## template = NULL, replaced with compileInfo$matchDef
+    ## template = NULL, replaced with default_matchDef
+    default_matchDef = NULL,
     code = NULL,
     RcppPacket = NULL,
     Rwrapper = NULL,
@@ -96,13 +97,7 @@ NF_InternalsClass <- R6::R6Class(
       ##   in the "decoration" system.  They could be put in "value" argument.
       ##  Either a named "value" or a ... is in all types.
 
-      ## not used until much later
-      if(is.null(self$compileInfo$opDef))
-        self$compileInfo$opDef <- list()
-      if(is.null(self$compileInfo$opDef$matchDef)) {
-        self$compileInfo$opDef$matchDef <- Rarguments_2_function(arguments, body = quote({}))
-      }
-      # self$template <- Rarguments_2_function(arguments, body = quote({})) ## generateTemplate()
+      self$default_matchDef <- Rarguments_2_function(arguments, body = quote({})) ## generateTemplate()
       returnTypeInfo <- nf_extractReturnType(code)
       returnTypeDecl <- returnTypeInfo$returnType
       if(is.null(returnTypeDecl)) {

nCompiler/R/NF_Utils.R

@@ -50,8 +50,9 @@ nGet <- function(name, where) {
     ## switch where to be the generator's parent_env
     where <- where$parent_env
   }
-  if(exists(name, envir = where, inherits = TRUE))
-    get(name, envir = where, inherits = TRUE)
-  else
-    NULL
+  get0(name, envir = where)
+  # if(exists(name, envir = where, inherits = TRUE))
+  #   get(name, envir = where, inherits = TRUE)
+  # else
+  #   NULL
 }

nCompiler/R/compile_aaa_operatorLists.R

@@ -94,12 +94,19 @@ updateOperatorDef <- function(ops, field, subfield = NULL, val) {
   }
 }
 
+getOperatorField <- function(opDef, field = NULL, subfield = NULL) {
+  if (is.null(opDef)) return(NULL)
+  if (is.null(field)) return(opDef)
+  if (is.null(opDef[[field]])) return(NULL)
+  if (is.null(subfield)) return(opDef[[field]])
+  opDef[[field]][[subfield]]
+}
+
 getOperatorDef <- function(op, field = NULL, subfield = NULL) {
-  opInfo <- get0(op, envir=operatorDefUserEnv)
-#  opInfo <- operatorDefEnv[[op]]
-  if (is.null(opInfo) || is.null(field)) return(opInfo)
-  if (is.null(opInfo[[field]]) || is.null(subfield)) return(opInfo[[field]])
-  return(opInfo[[field]][[subfield]])
+  opDef <- get0(op, envir=operatorDefUserEnv)
+#  opDef <- operatorDefEnv[[op]]
+  if(is.null(opDef)) return(NULL)
+  getOperatorField(opDef, field, subfield)
 }
 
 assignOperatorDef(
@@ -122,7 +129,7 @@ assignOperatorDef(
 )
 
 assignOperatorDef(
-  'NFCALL_', # This is used for non-method nFunctions in normalizeCalls and for any (including method) nFunctions after normalizeCalls
+  'nFunction_default', # This is used for non-method nFunctions in normalizeCalls and for any (including method) nFunctions after normalizeCalls
   list(
     labelAbstractTypes = list(
       handler = 'nFunction_or_method_call'),
@@ -133,17 +140,17 @@ assignOperatorDef(
   )
 )
 
-assignOperatorDef(
-  'NCMETHOD_', # This is a transient label that only exists within normalizeCalls
-  list(
-    ## labelAbstractTypes = list(
-    ##   handler = 'nFunction_or_method_call'),
-    normalizeCalls = list(
-      handler = 'nFunction_or_method_call')#, # becomes NFCALL_
-    ## cppOutput = list(
-    ##   handler = 'Generic_nFunction')
-  )
-)
+# assignOperatorDef(
+#   'NCMETHOD_', # This is a transient label that only exists within normalizeCalls
+#   list(
+#     ## labelAbstractTypes = list(
+#     ##   handler = 'nFunction_or_method_call'),
+#     normalizeCalls = list(
+#       handler = 'nFunction_or_method_call')#, # becomes NFCALL_
+#     ## cppOutput = list(
+#     ##   handler = 'Generic_nFunction')
+#   )
+# )
 
 assignOperatorDef(
   c('dim'),

nCompiler/R/compile_eigenization.R

@@ -73,21 +73,27 @@ compile_eigenize <- function(code,
       return(invisible(NULL))
     }
 
-    handlingInfo <- getOperatorDef(code$name, "eigenImpl")
+    opInfo <- check_cachedOpInfo(code, where=auxEnv$where, update=TRUE)
+    handlingInfo <- getOperatorField(opInfo$opDef, "eigenImpl")
+#    handlingInfo <- getOperatorDef(code$name, "eigenImpl")
     # operatorDefEnv[[code$name]]
     # if(!is.null(opInfo)) {
     #   handlingInfo <- opInfo[["eigenImpl"]]
       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)
         }
       }
@@ -110,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

@@ -85,7 +85,18 @@ compile_generateCpp <- function(code,
       ans[[length(code$args) + 2]] <- paste0(indent, '}')
     return(ans)
   }
-  handler <- getOperatorDef(code$name, "cppOutput", "handler")
+  # All calls must have valid opInfo or be a core DSL operator
+  # This compiler stage is called from cppDefs' generate() methods,
+  # so where$auxEnv is not available.
+  # This means that any penultimate compiler stages that changed the 
+  # call name to something non-core (and hence potentially the handler) 
+  # must update the cachedOpInfo.
+  # or we must add a final pass to do so.
+  # An example is changes made in eigenization, such as inserting `index[`.
+  # This is a core operator so it will be found in the check_cachedOpInfo with update=TRUE.
+  opInfo <- check_cachedOpInfo(code, where=baseenv(), update=TRUE, allowFail = TRUE)
+  handler <- getOperatorField(opInfo$opDef, "cppOutput", "handler")
+  #  handler <- getOperatorDef(code$name, "cppOutput", "handler")
   # opInfo <- operatorDefEnv[[code$name]]
   # if(!is.null(opInfo)) {
   #   handlingInfo <- opInfo[["cppOutput"]]
@@ -94,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:'))
@@ -165,10 +179,9 @@ inGenCppEnv(
 
 inGenCppEnv(
   Generic_nFunction <- function(code, symTab) {
-    innerCode <- code$args[['call']]
-    cpp_code_name <- code$aux$cpp_code_name
+    cpp_code_name <- code$aux$cachedOpInfo$obj_internals$cpp_code_name
     paste0(cpp_code_name,
-           '(', paste0(unlist(lapply(innerCode$args,
+           '(', paste0(unlist(lapply(code$args,
                                      compile_generateCpp,
                                      symTab,
                                      asArg = TRUE) ),

nCompiler/R/compile_labelAbstractTypes.R

@@ -100,7 +100,10 @@ compile_labelAbstractTypes <- function(code,
       return(invisible(NULL))
     }
 
-    handlingInfo <- getOperatorDef(code$name, "labelAbstractTypes")
+    opInfo <- check_cachedOpInfo(code, where=auxEnv$where, update=TRUE)
+    handlingInfo <- getOperatorField(opInfo$opDef, "labelAbstractTypes")
+
+#    handlingInfo <- getOperatorDef(code$name, "labelAbstractTypes")
     # opInfo <- operatorDefEnv[[code$name]]
     # if(!is.null(opInfo)) {
     #   handlingInfo <- opInfo[["labelAbstractTypes"]]
@@ -109,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))
@@ -406,24 +412,11 @@ inLabelAbstractTypesEnv(
 inLabelAbstractTypesEnv(
   nFunction_or_method_call <-
     function(code, symTab, auxEnv, handlingInfo) {
-      # We have code = NFCALL_(foo(x, y))
-      # innerCall if foo(x,y)
-      # We'll set innerCall$type to symbolNF
-      # and we'll set code$type to the returnType of foo(x, y)
-      innerCall <- code$args[['call']]
-      if(is.null(innerCall))
-        stop(
-          exprClassProcessingErrorMsg(
-            code, paste('In nFunction_or_method_call: the nFunction (or method) ',
-                        code$name, 
-                        ' has NULL content.')
-          ), call. = FALSE
-        )
-      inserts <- recurse_labelAbstractTypes(innerCall, symTab, auxEnv,
+      inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv,
                                             handlingInfo)
-      obj_internals <- code$aux$obj_internals
-      nFunctionName <- code$aux$nFunctionName
-      innerCall$type <- symbolNF$new(name = nFunctionName)
+      obj_internals <- code$aux$cachedOpInfo$obj_internals
+#      nFunctionName <- obj_internals$nFunctionName
+#      code$aux$symbolNF <- symbolNF$new(name = nFunctionName)
       returnSym <- obj_internals$returnSym
       if(is.null(returnSym))
         stop(
@@ -435,24 +428,6 @@ inLabelAbstractTypesEnv(
         )
       code$type <- returnSym$clone() ## Not sure if a clone is needed, but it seems safer to make one.
       inserts
-
-      # useArgs <- c(FALSE, rep(TRUE, length(code$args)-1))
-      # inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv,
-      #                                       handlingInfo, useArgs)
-      # obj_internals <- code$args[[1]]$aux$obj_internals
-      # nFunctionName <- code$args[[1]]$aux$nFunctionName
-      # code$args[[1]]$type <- symbolNF$new(name = nFunctionName)
-      # returnSym <- obj_internals$returnSym
-      # if(is.null(returnSym))
-      #   stop(
-      #     exprClassProcessingErrorMsg(
-      #       code, paste('In nFunction_or_method_call: the nFunction (or method) ',
-      #                   code$name,
-      #                   ' does not have a valid returnType.')
-      #     ), call. = FALSE
-      #   )
-      # code$type <- returnSym$clone() ## Not sure if a clone is needed, but it seems safer to make one.
-      # invisible(NULL)
     }
 )