R/S4dispatch.R

In omegahat/RGCCTranslationUnit: R interface to GCC source code information

collapseMethods =
  #
  # Takes a list whose elements are lists of methods for a given class
  # and unravels these into one single list but whose names are the 
  # names of the methods, i.e. no concatenating the class names, etc.
  # as unlist() would do.

function(methods)
{
  structure(unlist(methods, recursive = FALSE),
            names = as.character(unlist(lapply(methods, names))))
}

addDerivedMethods =
  #
  # Take the given "flat" set of methods and duplicate those that will 
  # be generated by the derived classes
  #
  # This can be used to get the dispatch parameter count properly taking into
  # account the additional methods.
  #
function(methods)
{
     #XXX eliminate constructors! We mirror these and add a SEXP parameter to each.
     # So I think we probably still need them.
     # But need to add a .finalizer argument. And remove the first parameter as it is not used in
     # the dispatch.
  w = sapply(methods, function(m) inherits(m, "ResolvedNativeClassMethod"))

  tmp =
   lapply(methods[w],
          function(m) {
               # XXX call a function!
             name = paste("R", m$className, sep = "")
             m$className = name
               # The @type slot is a ResolvedType and so will end up going back to its original version,
               # so we explicitly create it.
             m$parameters[[1]]$type@type = new("C++ClassDefinition", name = name, baseClasses = m$className, index = -1L) 
             m$parameters[[1]]$type@name = name

             m$parameters[[".inherited"]] = list(INDEX = NA, type = new("boolType"), defaultValue = "0")
             m
          })
  c(methods, tmp)
}


numUniqueArgs =
  #
  # This still doesn't handle the example in dispatch.R and dispatch.cc
  # which has a default argument that we should be able to differentiate.
  #
function(methods, 
         classHierarchy = NULL,
         maxNumArgs = NA,         
         sigTable = signatureTable(methods, maxNumArgs, rnames, defaultEl = NA),
         verbose = FALSE)
{
  methodNames = names(methods)

     # If we have methods with different names, do each group separately and return
  if(length(unique(methodNames)) > 1) {
    els = tapply(methods, methodNames, numUniqueArgs, classHierarchy)
    ans = do.call("rbind", els)
    rownames(ans) = NULL
    return(ans)
  }

  # At this point, methods is a list of methods with the same name.

    # Force sigTable to be evaluated now before we screw with the methods!
#  nrow(sigTable)
    
  rnames = makeMethodsSig(methods)
  
  isCons = sapply(methods, inherits, "ResolvedNativeClassConstructor")
      # For the constructors, remove the first parameter - the implicit this - and also change the class to drop the constructor
      # so that the signatures come out properly. Otherwise, the as(, "character") method will drop the first parameter which is really
      # the second now.
  methods[isCons] = lapply(methods[isCons], function(x) { x$parameters = x$parameters[-1]; structure(x, class = class(x)[-1])})
  rownames(sigTable) = rnames

    # Case where we only have one method with this name, so simple case.
  if(length(methods) == 1) {
    m = methods[[1]]
    ans = data.frame(numArgs = if(length(m$parameters)) sum(sapply(m$parameters, function(x) is.na(x$defaultValue))) else 0,
                     methodName = names(methods),
                     inClass = if("className" %in% names(m))
                                                     m$className
                                                 else
                                                     NA, signature = makeMethodsSig(methods), stringsAsFactors = TRUE)
    class(ans) = c("ParameterDispatchCountTable", class(ans))
    return(ans)
  }
  

    # The idea is to sweep over the columns of the signature table and successively group the
    # methods based on the type of that argument. When a group has only one element, then it is
    # disambiguated from the others and so can be considered resolved and we store its number of arguments
    # needed to reach this stage for that method.
  ans = rep(0, nrow(sigTable))

  groups = list(1:nrow(sigTable))
  i = 1
  totalLeft = length(ans)

  identity = function(x) x
  
  processGroup =
  function(g, i) {
    if(verbose) {    
      cat("<group> step", i, "\n")
      print(as.integer(g))
      print(rownames(sigTable)[g])
    }
    
        types = sigTable[g, i]

          # missing value mean that method is finished/eliminated.
        na = is.na(types)
        if(any(na)) {
          ans[g[na]] <<- i - 1
          cat("<processGroup> Finished with", paste(rownames(sigTable)[g[na]], collapse = ", "), "\n")

          g = g[! na]
          types = types[!na]
        }

     if(length(g) == 0)
       return(NULL)


        # need to collect the types into compatible

        gg = by(g, types, function(x) {
                            if(length(x) == 1) {
                              ans[x] <<- i
cat("<processGroup in numUniqueArgs> Finished because only 1\n")

                              return(NULL)
                            }

                             # Check for one lone default value which would make that method identifiable at this point.
                            
#                            hasDefaultValue = !sapply(methods[x], function(x) is.na(x$parameters[[i]]$defaultValue))
                            hasDefaultValue = !sapply(methods[x], function(x) { if(length(x$parameters) > i)
                                                                                   is.na(x$parameters[[i+1]]$defaultValue) || inherits(x$parametes[[i+1]], "UnusedParameter")
                                                                                else
                                                                                   TRUE
                                                                             })
#      print(i);  print(matrix(c(sapply(methods[x], as, "character"), hasDefaultValue),,2))
                              # if only one method has a default value for this parameter position,
                              # then we can eliminate that one from the next round.
                            if(sum(hasDefaultValue) == 1) {
                               k = x[which(hasDefaultValue)]
#                               cat("Dropping ", as(methods[[ k ]], "character"), "level", i , "pos", k, "\n")
                               ans[k] <<- i 
                               x = x[ - which(hasDefaultValue)]
                            }
                            x
                         })
    if(verbose)
      cat("</group>", i, "\n")

    gg[!sapply(gg, is.null)]
  }

    # nrow or ncol???
  while(i <= nrow(sigTable) && sum(ans == 0) > 0 && length(groups) > 0) {
    gg = lapply(groups, processGroup, i)
    groups = unlist(gg, recursive = FALSE)
    if(verbose)
      print(groups)
    i = i + 1
    if(verbose) {
      cat("Stage", i, "# new groups", length(groups), "\n")
      print(names(groups))
    }
  }

  if(sum(ans == 0) > 1) #XXX Create one of our own conditions.
    stop("Conflicting methods using the primary approach to C++ method dispatch using S4.\nYou will have to eliminate conflicting methods or use a different dispatch mechanism,\ne.g. name functions for class methods with the class name as a prefix.\nProblems in the following methods: ", paste(sapply(methods[ans == 0], as, "character"), collapse = "\n"))

  ans = data.frame(numArgs = ans, methodName = names(methods),
                       inClass = sapply(methods,  function(x)
                                                 if("className" %in% names(x))
                                                     x$className
                                                 else
                                                     NA),
                       signature = rownames(sigTable), stringsAsFactors = FALSE)

  
  class(ans) = c("ParameterDispatchCountTable", class(ans))
  ans
}


if(FALSE) {
  # Maybe not needed, so not finished yet.
checkConflictWithInheritedMethod =
function(m, argNum, sigTable, classHierarchy)
{
  ancestors = classHierarchy[m$className,]
  
}
}


makeMethodsSig =
  #
  # This creates a text representation of the methods for use in indexing a table.
function(methods)
{
    # convert method to character representation and strip away the return type.
  gsub("^[^\\(]*\\(", "\\(", sapply(methods,as, "character"), perl = TRUE)
}

signatureTable =
  #
  # For a collection of methods, compute a matrix giving the parameter types
  # for all the methods with each row giving the parameter type by name
  #
function(methods, maxNumArgs = NA, rowNames = makeMethodsSig(methods), defaultEl = as.character(NA), collapse = NA)
{

  if(is.na(collapse) && is.list(methods) && is(methods[[1]], "ResolvedClassMethods"))
   methods = unlist(methods, recursive = FALSE)

  
  if(is.na(maxNumArgs))
    maxNumArgs = max(sapply(methods, function(x) length(x$parameters)))
 
 types = matrix(as.character(defaultEl), length(methods), maxNumArgs,
                 dimnames = list(rowNames, NULL))
 sapply(seq(along = methods),
         function(i) {

            params = methods[[i]]$parameters
            if(length(params)) {
              if(FALSE)  x = getSignature(methods[[i]])
              else {
                x = sapply(params, function(p) getRTypeName(p$type))
                if(length(x)) 
                  types[i, seq(along = x)] <<- x
              }
            }
         })

  
   #??? All of them or any of them And we don't want to remove the first column for all!
 if(FALSE && all(sapply(methods, inherits, "ResolvedNativeClassConstructor")))
   types = types[,-1]

 types
}

if(FALSE)
setMethod("getSignature", "ResolvedRoutine",
          function(methods, nodes, typeMap = list()) {
             sapply(params, function(p) getRTypeName(p$type))            
          })


getParameterDispatchCount =
  #
  # mm = c(collapseMethods(resolved.methods), routines)
  # info = numUniqueArgs(mm)
  # getParameterDispatchCount(mm[[3]], info)
  #
function(m, info)
{
   # just for methods for now.
   # Deal with routines.

  if(is.null(info) || nrow(info) == 0)
    return(NA)
  
  if(inherits(m, "ResolvedNativeRoutine"))
      # look only at the rows with an NA in the class.
    i = is.na(info$inClass)
  else {
   if(is.na(m$className))
    i = is.na(info$inClass)
   else {
    info = info[ !is.na(info$inClass) ,]
    i = m$className == info$inClass & m$name == info$methodName
   }
  }

  info = info[i, ]
  
  if(nrow(info) == 1)
    return(info[1, "numArgs"])

  # match signatures
  w = makeMethodsSig(list(m)) == info$signature
  if(!any(w))
    return(NA)   

  info[w, "numArgs"]
}



findMIAmbiguities =
  #
  # The intent, if not effect, of derived is to ask whether it is a problem in C++
  # or only a problem for our derived class generation mechanism, i.e. in the code we generate.
  # It is only an issue for us if the method name has a virtual method; otherwise, we won't generate code for it.
  #
function(classDefs, methods, classHierarchy = getClassHierarchyMatrix(classDefs, TRUE), derived = TRUE)
{
  i = sapply(classDefs, function(x) length(x@baseClasses)) > 1

  if(!any(i))
    return(list())

  ans = lapply(classDefs[i],
                function(def)
                   findMIClassAmbiguities(def, unlist(methods[c(def@name, def@ancestorClasses)], recursive = FALSE),
                                           sapply(def@ancestorClasses, function(id)
                                                                        colnames(classHierarchy)[classHierarchy[id, ]]), derived = derived))

  ans = sapply(ans, function(x) x[x])
  ans = ans[sapply(ans, length) > 0]
  
  ans
}

findMIClassAmbiguities =
  #
  # Identifies methods in classes that are derived from multiple 
  # classes which are shared across two or more of these base classes
  # and so require precise specificity about the base class to
  # which the caller refers in a call of the form
  #     method()
  # See inst/examples/
function(classDef, methods, ancestors, derived = TRUE)
{
    # break the methods down by name
    #    Then look at each of the methods and get the class in which it is defined
    #     and see from which line of ancestors it comes.
    #    If it comes from more than one
 # methods = methods[sapply(methods, function(x) x$virtual)]
 tapply(methods, sapply(methods, el, "name"),
               function(methodList) {
                     # for this collection of same-named methods, find the different classes
                     # to see if there is more than one
                   classes = unique(sapply(methodList, el, "className"))
                   if(length(classes) == 1)
                     return(FALSE)

                    # So we only care about this if we are going to 
                   num = sum(sapply(classes, function(k) sapply(ancestors, function(x) k %in% x)))
                   if(derived) # ??? think more about this.
                     num > 1 && any(sapply(methodList, function(x) x$virtual)) 
                   else
                     num > 1
               })

}