#  File src/library/methods/R/methodsTable.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2018 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

### merge version called from namespace imports code.  Hope to avoid using generic
.mergeMethodsTable2 <- function(table, newtable, envir, metaname) {
    old <- as.list(table, all.names=TRUE)
    mm <- 1
    for( what in old) {
      if(is(what, "MethodDefinition")) {
          mm <- length(what@defined)
          break
      }
    }
    new <- as.list(newtable, all.names=TRUE)
    ## check that signature length doesn't change
    canStore <- TRUE
    for(what in new) {
        if(is(what, "MethodDefinition") &&
           length(what@defined) != mm) {
            canStore <- FALSE
            break
        }
    }
    if(canStore) {
        list2env(new, table)
        table
    }
    else { # rats! have to get the generic function
        f <- gsub(".__T__(.*):([^:]+)", "\\1", metaname)
        package <- gsub(".__T__(.*):([^:]+(.*))", "\\2", metaname)
        generic <- getGeneric(f, TRUE, envir, package)
        .mergeMethodsTable(generic, table, newtable, TRUE)
        table
    }
}

## action on attach, detach to merge methods tables
.mergeMethodsTable <- function(generic, table, newtable, add = TRUE) {
  fenv <- environment(generic)
##  signature <- generic@signature
  if(!exists(".SigLength", envir = fenv, inherits = FALSE))
     .setupMethodsTables(generic)
  allTable <- if(!add) get(".AllMTable", envir = fenv) ## else NULL
                                        # .AllMTable but only if required
  n <- get(".SigLength", envir = fenv)
  anySig <- rep("ANY", n) # assert doesn't need to be a real signature
##  anyLabel <- .sigLabel(anySig)
  newMethods <- names(newtable)
  for(what in newMethods) {
    obj <- newtable[[what]]
    if(is.primitive(obj))
      sig <- anySig
    else if(is(obj, "MethodDefinition"))
      sig <- obj@defined
    else if(is.environment(obj)) {
       objsWhat <- as.list(obj, all.names=TRUE, sorted=TRUE)
       if(length(objsWhat) == 0)
           next # empty environment, ignore
       isDef <- vapply(objsWhat, is, logical(1L), "MethodDefinition")
       if (any(isDef)) {
           sig <- objsWhat[[utils::tail(which(isDef), 1L)]]@defined
       } else {
           sig <- anySig
       }
    }
    else
      stop(gettextf("invalid object in meta table of methods for %s, label %s, had class %s",
                    sQuote(generic@generic),
                    sQuote(what),
                    dQuote(class(obj))),
           domain = NA)
    ns <- length(sig)
    if(ns == n) {}
    else {
      if(ns < n) {
        nadd <- n - ns
        sigPackage <- packageSlot(sig)
        if(length(sigPackage)< ns) # probably out of date?
            sigPackage <- c(sigPackage, rep("", ns - length(sigPackage)))
        sig <-  .simpleSignature(c(sig, rep("ANY", nadd)),
                    names = generic@signature[1:n],
                    packages = c(sigPackage, rep("methods", nadd)))
        obj <- .xpdSignature(obj, sig, n-ns)
        what <- .sigLabel(sig)
        ns <- n
      }
      else if(add) { # and ns > n
        signames <- generic@signature
        length(signames) <- ns
        .resetTable(table, ns, signames)
        fenv[[".SigLength"]] <- ns
        n <- ns
      }
    }
    if(add) {
        if(exists(what, envir = table, inherits = FALSE)) {
            obj <- .newOrMultipleMethod(obj, what, table)
            ## must replace in .AllMTable also
            if(is.null(allTable))
                allTable <- get(".AllMTable", envir = fenv)
            allTable[[what]] <- obj
        }
        table[[what]] <- obj
    }
    else if(exists(what, envir = table, inherits = FALSE) &&
            !all(obj@defined == "ANY") ) {
        ## remove methods, but not the default
        remove(list = what, envir = allTable)
        remove(list = what, envir = table)
    }
    ## else warning?
  }
  NULL
}

.xpdSignature <- function(obj, sig, nadd) {
    if(is(obj, "MethodDefinition")) {
        obj@defined <- sig
        obj@target <- sig
    }
    else if(is.environment(obj)) {
##        xtrPkg <- rep("methods", nadd)
        for(what in names(obj)) {
            objw <- get(what, envir = obj)
            if(is(objw, "MethodDefinition")) {
                sigw <- objw@defined
                pkgw <- packageSlot(sigw)
                if(length(pkgw) < length(sigw))
                    pkgw <- c(pkgw, rep("", length(sigw) - length(pkgw)))
                sigw <- .simpleSignature( c(sigw, rep("ANY", nadd)),
                        names = names(sig),
                        packages = c(pkgw, rep("methods", nadd)))
                objw@defined <- objw@target <- sigw
                remove(list = what, envir = obj)
                var <- .pkgMethodLabel(objw)
                if(nzchar(var)) obj[[var]] <- objw
            }
        }
    }
    obj
}

## a simpler version of setting up a signature object
## For better or worse, the initialize() method expects
## a function definition and calls .MakeSignature()
.simpleSignature <- function(classes, names, packages) {
    object <- new("signature")
    object@.Data <- classes
    object@names <- names
    object@package <- packages
    object
}

.newOrMultipleMethod <- function(obj, what, table) {
    if(!.duplicateClassesExist())
        return(obj)
    current <- get(what, envir = table)
    if(is.environment(current)) {
        if(is.environment(obj))
            list2env(as.list(obj, all.names=TRUE), current)
        else if(is(obj, "MethdodDefinition")) {
            var <- .pkgMethodLabel(obj)
            if(nzchar(var)) assign(var, obj, envir = current)
        }
        current
    }
    else if(is(current, "MethodDefinition")) {
        curPkg <- packageSlot(current@defined)
        if(is(obj, "MethodDefinition")) {
            objPkg <- packageSlot(obj@defined)
            if(is.null(curPkg) || is.null(objPkg) ||
               identical(curPkg, objPkg))
                return(obj)
            else {
                merge <- new.env()
                var <- .pkgMethodLabel(obj)
                if(nzchar(var)) assign(var, obj, envir = merge)
                var <- .pkgMethodLabel(current)
                if(nzchar(var)) assign(var, current, envir = merge)
                return(merge)
            }
        }
        else if(is.environment(obj)) {
            merge <- new.env()
            assign(.pkgMethodLabel(current), current, envir = merge)
            list2env(as.list(obj, all.names=TRUE), merge)
            return(merge)
        }
        ## else adding a primitive, should do nothing
        else
            current
    }
}


.mlistAddToTable <- function(generic, mlist, table = new.env(TRUE, fenv), add = TRUE) {
  fenv <- environment(generic)
  signature <- generic@signature
    if(!exists(".SigLength", envir = fenv, inherits = FALSE))
     .setupMethodsTables(generic)
  n <- get(".SigLength", envir = fenv, inherits = FALSE)
  .storeMlist(table, rep("ANY", n), mlist, 1,  add, fenv)
  ## check for more args in the mlist than in the table
  nNow <- get(".SigLength", envir = fenv, inherits = FALSE)
  if(nNow > n) {
    length(signature) <- nNow
    .resetTable(table, nNow, signature)
  }
  table
}

## utility now *only* called once above
.storeMlist <- function(table, sig, mlist, i, add, fenv) {
    ## once generic functions are installed from 2.11.0 or later, this should
    ## only be called with mlist a method or NULL.
    if(is.null(mlist)) return(table)
    m <- if(is(mlist, "MethodsList")) { .MlistDefunct(); mlist@methods }
	 else list(ANY=mlist)

  ## once MethodsList is defunct, this should be rewritten (and renamed!)

  ## the methods slot is a list named by class, with elements either
  ## method definitions or mlists
  classes <- names(m)
  for(j in seq_along(m)) {
    el <- m[[j]]
    sig[[i]] <- classes[[j]]
    if(is(el, "MethodDefinition") || is.primitive(el)) {
      if(add)
        assign(.sigLabel(sig), el, envir = table)
      else
        remove(list = .sigLabel(sig), envir = table)
    }
    else if(is(el,"MethodsList")) {
	.MlistDefunct()
      i1 <- i+1
      if(i1 >= length(sig)) {
        ## a reset of the labels will be needed
        assign(".SigLength", i1, envir = fenv)
        sig <- c(sig, rep("ANY", i1-length(sig)))
      }
      Recall(table, sig, el, i1, add, fenv)
    }
    else
      stop(gettextf(
   "invalid mlist element for signature %s at level %d (should be MethodDefinition or .Primitive, had class %s)",
                    sQuote(classes[[j]]),
                    i,
                    dQuote(class(el))),
           domain = NA)
  }
  table
}

.cacheMethodInTable <- function(fdef, sig, def,
                                table = get(".AllMTable", envir = fenv)) {
    ## store method in cache table.
    ## called from setMethod()
    ## also Called from cacheMethod (from as(), as<-())
  fenv <- environment(fdef)
  if(missing(table) && !exists(".AllMTable", envir = fenv, inherits = FALSE))
    .setupMethodsTables(fdef)
  sig <- .matchSigLength(sig, fdef, fenv, TRUE)
  label <- .sigLabel(sig)
  isCurrent <- exists(label, envir = table, inherits = FALSE)
  if(is.null(def)) { # remove the method (convention for setMethod)
      if(isCurrent)
          remove(list = label, envir = table)
  }
  else {
      dupl <- .duplicateClassesExist()
      ## ensure that a valid object is assigned:  if duplicate classes
      ## exist, may need a table by package label; else, make sure
      ## the target and defined slots are complete
      ## IF we believed all methods up to date, the call could be conditional
      ##    if(dupl || isCurrent)
      def <- .methodPackageSlots(def, label, table, dupl, isCurrent)
      assign(label, def, envir = table)
  }
}

## check for duplicate classes and embed method in an environment if so
.methodPackageSlots <- function(def, ...) def

## the real version
..methodPackageSlots <- function(def, label, table, duplicatesExist, isCurrent) {
    sig <- def@target
    dups <- FALSE
    if(duplicatesExist) {
        def <- .fixPackageSlot(def, sig)
        for(cl in sig) {
            if(exists(cl, envir = .classTable, inherits = FALSE) && is.list(get(cl, envir = .classTable))) {
                dups <- TRUE
                break
            }
        }
        if(isCurrent) { # check that this is overwriting identical signature
            current <- get(label, envir = table)
            dups <- dups || !identical(current@target, sig)
        }
        if(dups) {
            if(isCurrent) {
                if(is(current, "MethodDefinition")) {
                    pkg <- attr(current@target, "package")
                    if(length(pkg) == 0)
                        current <- .fixPackageSlot(current, current@target)
                    env <- new.env()
                    ## zero-length seen 2011-07-29
                    var <- .pkgMethodLabel(current)
                    if(nzchar(var)) assign(var, current, envir = env)
                }
                else if(is.environment(current))
                    env <- current
                else
                    stop(
                         gettextf("bad method object stored in method table, class %s",
                                  dQuote(class(current))),
                         domain = NA)
            }
            else
                env <- new.env()
            assign(.pkgMethodLabel(def), def, envir = env)
            env
        }
        else # no change
            def
    }
    else # no duplicate classes
        def
}

.fixPackageSlot <- function(def, sig) {
    ## check the pkg slot
    pkgs <- attr(sig, "package")
    if(is.null(pkgs))
        pkgs <- character(length(sig))
    fixme <- !nzchar(pkgs)
    if(any(fixme)) {
        for(i in seq_along(pkgs)[fixme])
            pkgs[[i]] <- getClass(sig[[i]], .Force = TRUE)@package
        attr(sig, "package") <- pkgs
        def@target <- sig
        ## check the defined signature as well
        sig <- def@defined
        pkgs <- attr(sig, "package")
        if(is.null(pkgs))
            pkgs <- character(length(sig))
        fixme <- !nzchar(pkgs)
        if(any(fixme)) {
            for(i in seq_along(pkgs)[fixme])
                pkgs[[i]] <- getClass(sig[[i]], .Force = TRUE)@package
            attr(sig, "package") <- pkgs
            def@defined <- sig
        }
    }
    def
}

.okMethodLabel <- function(method) {
    if(is(method, "MethodDefinition")) {
        pkgs <- packageSlot(method@target)
        length(pkgs) > 0 && all(nzchar(pkgs))
    }
    else
        TRUE # primitive or environment
}


.pkgMethodLabel <- function(method) {
    sig <- method@target
    pkgs <- packageSlot(sig)
    if( (length(pkgs) < length(as.character(sig))) || any(!nzchar(pkgs)))
        stop("package slot missing from signature for generic ",
             sQuote(method@generic), "\n",
             "and classes ", paste(sig, collapse = ", "), "\n",
             "cannot use with duplicate class names (the package may need to be re-installed)",
             call. = FALSE, domain = NA)
    paste(pkgs, collapse = "#")
}

.resetTable <- function(table, n, signames) {
    ## protect this computation, in case it's resetting
    ## something used in the computation
    primMethods <- .allowPrimitiveMethods(FALSE)
    on.exit(.allowPrimitiveMethods(primMethods))
    ## after updating a methods table, the maximum no. of arguments in
    ## the signature increased to n.  Reassign any objects whose label
    ## does not match n classes from the defined slot
    anyLabel <- rep("ANY", n)
    anyPkg <- rep("methods", n)
    seqN <- 1L:n
    labels <- names(table)
    for(what in labels) {
        method <- get(what, envir = table)
        if(is.primitive(method)) # stored as default ?
            newSig <- anyLabel
        else if(is(method, "MethodDefinition"))
            newSig <- method@defined
        else if(is(method, "environment")) {
            newSig <- strsplit(what, "#", fixed = TRUE)[[1]]
            .resetTable(method, n, signames)
        }
        else
            stop(gettextf("invalid object in methods table (%s), expected a method, got an object of class %s",
                          sQuote(what),
                          dQuote(class(method))),
                 domain = NA)

        if(is(method, "MethodDefinition")) {
            pkgs <- packageSlot(newSig)
            newSig <- as(ifelse(seqN > length(newSig), anyLabel, newSig), "signature")
            newSig@names <- signames
            newSig@package <-  ifelse(seqN > length(pkgs), anyPkg, pkgs)
            method@defined <- method@target <- newSig
            newLabel <- .sigLabel(newSig)
        }
        else
            newLabel <- .sigLabel(ifelse(seqN > length(newSig), anyLabel, newSig))
        remove(list=what, envir = table)
        assign(newLabel, method, envir = table)
    }
    NULL
}

### the tag associated with a method signature.
### Should perhaps use the same C code as dispatch, for consistency,
### however, that code breaks out early in the collapse loop if no match.
### This code is not used for quick matching, so efficiency less critical.
.sigLabel <- function(sig)
  paste(sig, collapse = "#")

.fillSignatures <- function(sigs, n) {
    siglens <- lengths(strsplit(sigs, "#", fixed=TRUE))
    short <- n > siglens
    suffix <- vapply(n - siglens[short],
                     function(ni) paste(rep("ANY", ni), collapse="#"),
                     character(1L))
    sigs[short] <- paste(sigs[short], suffix, sep="#")
    sigs
}

## workhorse of selectMethod() [ -> ../Methods.R ] "
.findInheritedMethods <-
    function(classes, fdef, mtable = NULL,
             table = get(".MTable", envir = environment(fdef)),
             excluded = NULL, useInherited,
             simpleOnly = .simpleInheritanceGeneric(fdef), verbose = FALSE,
             doCache = is.environment(mtable),
             where = environment(fdef))
{
    ## to avoid infinite recursion, and somewhat for speed, turn off S4 methods for primitives
    primMethods <- .allowPrimitiveMethods(FALSE)
    on.exit(.allowPrimitiveMethods(primMethods))
    ## classes is a list of the class(x) for each arg in generic
    ## signature, with "missing" for missing args
    if(!is.environment(table)) {
        if(is(fdef, "standardGeneric"))
          stop(gettextf("invalid or unset methods table in generic function %s", sQuote(fdef@generic)), damain = NA)
        else
          stop("trying to find a methods table in a non-generic function")
    }
    hasGroup <- length(fdef@group) > 0L
    if(hasGroup)
      groupGenerics <- .getAllGroups(list(fdef))
    doExcluded <- length(excluded) > 0L
    if(verbose) {
	plist <- function(x) paste(x, collapse = ", ")
	cat(" .findInheritedMethods(): (hasGroup, doCache, doExcluded)= (",
	    plist(c("f","T")[1+c(hasGroup, doCache, doExcluded)]), ")\n",
	    if(hasGroup) paste0(" Group generics: ",
				plist(vapply(groupGenerics, slot,
					     character(1), "generic")), "\n"),
	    sep='')
    }
    nargs <- length(classes)
    if(!missing(useInherited) && length(useInherited) < nargs)
      useInherited <- rep(useInherited, length.out = nargs)
    if(hasGroup && !doExcluded) {
        ## first try for an exact match in a group generic
        ## If this matches &  is cached, it then will be treated as a non-inherited method
        ## so no further calls here should occur.
        ##
        ## doExcluded is the findNextMethod case; we don't regard group methods as
        ## inherited in the nextMethod sense, since they have the same signature
        label <- .sigLabel(classes)
        direct <- .getGroupMethods(label, groupGenerics, FALSE)
	if(length(direct)) {
	    if(doCache)
		assign(label, direct[[1L]], envir = mtable)
	    return(direct)
	}
        ## else, continue because we may want all defined methods
    }
    cl1 <- classes[[1L]]
    def <- getClass(cl1, where = where, .Force = TRUE)
    labels <-
      if(missing(useInherited) || useInherited[[1L]])
          c(cl1, .eligibleSuperClasses(def@contains, simpleOnly), "ANY")
      else cl1
    supersList <- list(labels)
    classDefs <- vector("list", nargs)
    classDefs[[1L]] <- def
    if(nargs > 1) { ## further arguments
        for(i in 2:nargs) {
            cc <- classDefs[[i]] <- getClass(classes[[i]], where = where,
                                             .Force = TRUE)
            allLabels <- if(missing(useInherited) || useInherited[[i]])
                c(cc@className, .eligibleSuperClasses(cc@contains, simpleOnly),
                  "ANY")
            else cc@className
            labels <- outerLabels(labels, allLabels)
            supersList <- c(supersList, list(allLabels))
        }
    }
    labels <- labels[-1L] # drop exact match
    labels <- unique(labels)# only needed while contains slot can have duplicates(!)
    if(verbose) {
	cat(" .fI> length(unique(method labels)) = ", length(labels))
	if(verbose >= 2) { cat(";  labels = \n") ; print(labels) }
    }
    allMethods <- names(table)
    m <- match(labels, .fillSignatures(allMethods, length(classes)))
    found <- !is.na(m)
    methods <- mget(allMethods[m[found]], table)
    if(verbose) cat(" >> found: ", length(methods), "\n")
    if(hasGroup) {
        ##  add the  group methods recursively found but each time
        ## only those not already included in found.
        groupmethods <- .getGroupMethods(labels, groupGenerics, found)
        fromGroup <- c(rep(FALSE, length(methods)),
                       rep(TRUE,  length(groupmethods)))
        if(verbose) cat(" .fI> #{additional group methods}:",
                        length(groupmethods),"\n")
        methods <- c(methods, groupmethods)
    }
    else
      fromGroup <- rep(FALSE, length(methods))
    ## resolve any duplicate-class ambiguities
    if(.duplicateClassesExist()) {
        found <- integer()
        nm <- names(methods)
        for(i in seq_along(methods)) {
            m <- methods[[i]]
            if(is.environment(m)) {
                methods[[i]] <- .checkDuplicateMethodClasses(classDefs, m, nm[[i]])
                found <- c(found, i)
            }
        }
        if(length(found))
            methods <- unlist(methods, recursive = FALSE)
        if(!is.list(methods)) # reduced to a single method?
            methods <- list(methods)
    }
    if(doExcluded)
      methods <- methods[is.na(match(names(methods), as.character(excluded)))]
    ## remove default (ANY,..,ANY) if its not the only method:
    if(length(methods) > 1L) {
        defaultLabel <- paste(rep.int("ANY", nargs), collapse = "#")
        i <- match(defaultLabel, names(methods), 0L)
        if(i > 0L) {
            methods <- methods[-i]
            fromGroup <- fromGroup[-i]
        }
    }
    if(length(methods) > 1L) {
        if(verbose) cat(" .fI> length(methods) = ", length(methods),
                        " --> ambiguity\n")
        ## have ambiguity to resolve
        select <- .getBestMethods(methods, supersList, fromGroup, verbose=verbose)
        ##         --------------
        if(length(select) > 1L) {
            if(verbose) cat(" .fI> found", length(select)," best methods\n")

##            target <- .sigLabel(classes)
            condAction <- getOption("ambiguousMethodSelection")
            if(is.null(condAction))
              condAction <- .ambiguousMethodMessage
            else if(!is.function(condAction))
              stop(gettextf("the \"ambiguousMethodSelection\" option should be a function to be called as the condition action; got an object of class %s",
                            dQuote(class(condAction))),
                   domain = NA)

            select <- withCallingHandlers(
                                          .disambiguateMethods(classes, select, fdef@generic,
                                                               methods, supersList, fromGroup,
                                                               classDefs, verbose),
                                          ambiguousMethodSelection=condAction)
        }
        methods <- methods[select]
    }
    if(simpleOnly && length(methods) == 0L) {
	## Seems to be *unused* [below, 'simpleOnly' argument was missing for years!]
	methods <- Recall(classes, fdef, mtable, table, excluded, useInherited,
			  simpleOnly, verbose, FALSE)
        if(length(methods) > 0L)
          message(gettextf("No simply inherited methods found for function %s; using non-simple method",
                           sQuote(fdef@generic)),
                  domain = NA)
    }
    if(length(methods)) {
        tlabel <- .sigLabel(classes)
        m <- methods[[1L]]
        if(is(m, "MethodDefinition"))  { # else, a primitive
            m@target <- .newSignature(classes, fdef@signature)
            ## if any of the inheritance is not simple, must insert coerce's in method body
            coerce <- .inheritedArgsExpression(m@target, m@defined, body(m))
            if(!is.null(coerce))
              body(m) <- coerce
            methods[[1L]] <- m
        }
	if(doCache) {
	    if(verbose) cat(" .fI> caching newly found methods ..\n")
	    assign(tlabel, m, envir = mtable)
	}
    }
    methods
}

.checkDuplicateMethodClasses <- function(classDefs, env, label){
    supers <- strsplit(label, "#", TRUE)[[1]]
    sigs <- sort(names(env))
    plabels <- strsplit(sigs, "#", TRUE)
    hasSubclass <- vapply(plabels, .hasThisSubclass, logical(1L),
                          classDefs=classDefs, supers=supers)
    mget(sigs[hasSubclass], env)
}

.hasThisSubclass <- function(classDefs, supers, plabel) {
    for(i in seq_along(plabel)) {
        pkg <- classDefs[[i]]@package
        cl <- classDefs[[i]]@className
        si <- supers[[i]]
        pki <- plabel[[i]]
        if(identical(si, "ANY") ||
           (identical(cl, si) && identical(pkg, pki)))
            next
        cli <- getClassDef(si, package = pki)
        if(is.null(cli)) return(FALSE)
        sub <- cli@subclasses[[cl]]
        if(is.null(sub) || !identical(pkg, sub@package))
            return(FALSE)
    }
    TRUE
}

.ambiguousMethodMessage <- function(cond) {
  selected <- attr(cond, "selected")
  if(is.null(selected)) {# not properly set up, so just use the message
    message(cond$message)
  }
  else {
    possible <- attr(cond, "candidates")
    message(gettextf("Note: method with signature %s chosen for function %s,\n target signature %s.\n %s would also be valid",
                     sQuote(selected),
                     sQuote(attr(cond, "generic")),
                     sQuote(attr(cond, "target")),
		     paste0('"', possible[is.na(match(possible, selected))], '"',
			    collapse=", ")),
            domain = NA)
  }
}

.simpleInheritanceGeneric <- function(fdef) {
    identical(attr(fdef@signature, "simpleOnly"), TRUE)
}

.eligibleSuperClasses <- function(contains, simpleOnly) {
    what <- names(contains)
    if(!length(what))
      what
    else {
	eligible <-
	    vapply(contains,
		   if(simpleOnly)
		   function(x) (is.logical(x) && x) || x@simple
		   else # eliminate conditional inheritance
		   function(x) (is.logical(x) && x) || x@simple || isTRUE(body(x@test)), NA)
	what[eligible]
    }
}

.newSignature <- function(classes, names) {
  ## a simple version to deal with boostrapping stage, used in new() etc
    n <- min(length(classes), length(names))
  i <- seq_len(n)
    ## a corresponding set of package names
    ## <FIXME> There should be a "<unknown>" package name instead of "methods"
    ## but this requires a way to deal with that generally </FIXME>
    pkgs <- lapply(classes[i], packageSlot)
    pkgs[vapply(pkgs, is.null, logical(1L))] <- "methods"

  ## Simplified version ...
  .asS4(structure(as.character(classes)[i],
            class = .signatureClassName,
            names = as.character(names)[i],
            package = as.character(pkgs) ))
 }

.findNextFromTable <- function(method, f, optional, envir, prev = character())
{
    fdef <- getGeneric(f, where = envir)
    env <- environment(fdef)
##    target <- method@target
    n <- get(".SigLength", envir = env)
    defined <- method@defined
    m <- length(defined)
    if(m > n)
        length(defined) <- n
  else if(n > m)
      ## will only really need this to be a signature when the elements
      ## have package attribute--see .sigLabel
      defined <-  new("signature", fdef, c(defined@.Data, rep("ANY", n-m)))
    excluded <- c(prev, .sigLabel(defined))
    allTable <- .getMethodsTable(fdef, inherited = TRUE)
    methods <- .findInheritedMethods(defined, fdef, mtable = NULL,
                                     table = allTable,
                                     excluded = excluded,
                                     where = envir)
    if(length(methods) == 0L) # use default method, maybe recursively.
        methods <- list(finalDefaultMethod(fdef@default)) #todo: put a label on it?
    if(length(methods) > 1L)
        warning(sprintf(ngettext(length(methods),
                                 "found %d equally good next method",
                                 "found %d equally good next methods"),
                        length(methods)),
                domain = NA)
    ## excluded slot is a list, but with methods tables, elements are just labels
    new("MethodWithNext", method, nextMethod = methods[[1L]],
        excluded = as.list(excluded))
}


  ## get the classes of the args

.InheritForDispatch <- function(classes, fdef, mtable) {
  methods <- .findInheritedMethods(classes, fdef, mtable)
  if(length(methods) == 1L)
    return(methods[[1L]]) # the method
  else if(length(methods) == 0L) {
    cnames <- paste0("\"", vapply(classes, as.character, ""), "\"",
		     collapse = ", ")
    stop(gettextf("unable to find an inherited method for function %s for signature %s",
                  sQuote(fdef@generic),
                  sQuote(cnames)),
         domain = NA)
  }
  else
    stop("Internal error in finding inherited methods; didn't return a unique method", domain = NA)
}

.findMethodForFdef <- function(signature, table, fdef = NULL) {
    value <- .findMethodInTable(signature, table, fdef)
    if(is.null(value) && is(fdef, "genericFunction")) { # try without expanding signature
        fullSig <- .matchSigLength(signature, fdef, environment(fdef), FALSE)
        if(!identical(fullSig, signature))
            value <- .findMethodInTable(signature, table, fdef, FALSE)
    }
    value
}

.findMethodInTable <- function(signature, table, fdef = NULL , expdSig = TRUE)
{
    if(is(fdef, "genericFunction") && expdSig)
        signature <- .matchSigLength(signature, fdef, environment(fdef), FALSE)
    label <- .sigLabel(signature)
##     allMethods <- objects(table, all.names=TRUE)
##     if(match(label, allMethods, nomatch = 0L))
    if(!is.null(value <- table[[label]])) {
        if(is.environment(value)) {
            pkgs <- names(value)
            if(length(pkgs) == 1)
                value <- value[[pkgs]]
            else if(length(pkgs) == 0)
                value <- NULL
            ## else, return the environment indicating multiple possibilities
        }
        value
    } # else, NULL
}

## inheritance distances:  0 for the class, 1 for immediate contains, 2 for other contains
##    and 3 for ANY
.inhDistances <- function(classDef) {
  contains <- classDef@contains
  allNames <-  unique(names(contains)) # bug allows duplicates in contains
  dist <- rep(2, length(allNames))
  for(i in seq_along(dist)) {
    ci <- contains[[i]]
    dist[[i]] <- ci@distance
  }
  dist <- c(0, dist, NA)
  names(dist) <- c(classDef@className, allNames, "ANY")
  dist
}

.leastMethodDistance <- function(methods, supersList, classDefs, fromGroup, verbose = FALSE) {
    n <- length(methods)
    dist <- rep(0, n)
    nArg <- length(classDefs)
    defClasses <- matrix("ANY", nArg, n)
    for(j in 1L:n) {
	cl <- methods[[j]]@defined@.Data
	defClasses[seq_along(cl), j] <- cl
    }
    containsDist <- lapply(classDefs, .inhDistances)
    maxDist <- max(unlist(containsDist), na.rm = TRUE) + 1
    if(verbose) { cat("** individual arguments' distances:\n"); print(containsDist) }
    ## add up the inheritance distances for each argument (row of defClasses)
    for(i in 1L:nArg) {
	ihi <- containsDist[[i]]
	ihi[is.na(ihi)] <- maxDist
	cli <- defClasses[i,]
	dist <- dist + ihi[match(cli, names(ihi))]
    }
    ## These should be integers, so we do not need to worry about a decimal point
    if(verbose) cat("** final methods' distances: (",
		    paste(formatC(dist), collapse= ", "), ")\n", sep='')
    best <- dist == min(dist)
    ## of the least distance methods, choose direct, rather than group
    ## methods, unless all the best methods are from group generics
    if(any(fromGroup[best]) && !all(fromGroup[best]))
	best <- best & !fromGroup
    (1:n)[best]
}

## currently called exactly once from .findInheritedMethods() :
.getBestMethods <- function(methods, supersList, fromGroup, verbose = FALSE) {
    n <- length(methods)      ## >= 2
    nArg <- length(supersList)## >= 1
    sigs <- matrix("ANY", nArg, n)
    for(i in 1:n) {
      sig <- methods[[i]]@defined
      if(length(sig) < nArg) { # is this still possible? --> show 'verbose'
	if(verbose) cat(sprintf(" .. method %d: length(sig) = %d < nArg = %d\n",
				i, length(sig), nArg))
	sigs[seq_along(sig), i] <- sig
      }
      else
        sigs[,i] <- sig
    }
    if(nArg < 2) { # the easy case
      return(which.min(match(sigs[1L,], supersList[[1L]])))
    }
    ## else  nArg >= 2
    pos <- matrix(0L, nArg, n)
    for(i in 1:nArg) {
        pos[i,] <- match(sigs[i,], supersList[[i]])
    }
    valid <- colSums(is.na(pos)) == 0L
    best <- valid
    dominated <- !valid
    ## pairwise comparison of columns of pos.  Any way to vectorize?
    seqn <- seq_len(n)
    for(i in seqn[valid]) {
      for(j in seqn[-i][valid[-i]]) {
        diffs <- pos[,j] - pos[,i]
	if(any(diffs < 0))  { best[i] <- FALSE; if(dominated[i]) break }
	if(all(diffs <= 0)) { dominated[i] <- TRUE; if(!best[i]) break }
      }
    }
    if(verbose)
	cat(if(any(best)) paste(" have best ones",
				paste(format(seqn[best]),collapse=","))
	    else if(any(dominated)) paste(" can eliminate dominated ones,",
				    paste(format(seqn[dominated]),collapse=",")),
	    "\n")
    ## a best method is as early in the superclasses as any other on all arguments
    ## Because the signatures are not duplicated, there can be at most one.
    if(any(best))
      seqn[best]
    ## eliminate those methods dominated by another
    else
      seqn[!dominated]
}

## currently called exactly once from .findInheritedMethods() :
.disambiguateMethods <- function(target, which, generic, methods, supersList,
                                 fromGroup, classDefs, verbose)
{
  ## save full set of possibilities for condition object
  candidates <- methods[which]
  note <- character()
  ## choose based on total generational distance
  which2 <- .leastMethodDistance(candidates, supersList, classDefs,
                                 fromGroup[which])
  if(length(which2) < length(which)) {
    note <- c(sprintf(ngettext(which2,
                               "Selecting %d method of minimum distance",
                               "Selecting %d methods of minimum distance"),
                      which2))
    which <- which[which2]
  }
  ## if some are group methods, eliminate those
  if(length(which) > 1 && any(fromGroup[which]) && !all(fromGroup[which])) {
    which <- which[!fromGroup]
    note <- c(note,  sprintf(ngettext(length(which),
                                      "Selecting %d non-group method",
                                      "Selecting %d non-group methods"),
                             length(which)))
  }
  ## prefer partially direct methods
  if(length(which) > 1) {
    direct <- vapply(methods[which], function(x, target)
                     (is(x, "MethodDefinition") && any(target == x@defined)),
		     NA, target = target)
    if(any(direct) && !all(direct)) {
      which <- which[direct]
      note <- c(note, sprintf(ngettext(length(which),
                                       "Selecting %d partially exact-matching method",
                                       "Selecting %d partially exact-matching methods"),
                              length(which)))
    }
  }
  which <- which[[1L]]
  if(identical(as.character(generic), "coerce"))
      return(which) # as() computations not currently consistent w. selection (R 2.15.2)
  selected <- names(methods)[[which]]
  ## FIXME (?): This is not shown to the user
  msg <- sprintf(ngettext(length(candidates),
                          "Choosing method %s from %d ambiguous possibility",
                          "Choosing method %s from %d ambiguous possibilities"),
                 sQuote(selected), length(candidates))
  condObject <- simpleCondition(msg)
  ## would be nice to use an S4 class eventually
  class(condObject) <- c("ambiguousMethodSelection", class(condObject))
  attributes(condObject) <-
      c(attributes(condObject),
	list("candidates" = names(candidates),
	     "target"	  = .sigLabel(target),
	     "selected"	  = selected,
	     "generic"	  = generic,
	     "notes" = if(length(note)) paste(note, collapse ="; ") else ""))
  if(verbose) cat("   .disambiguateM*(): notes =\n\t",
		  attr(condObject, "notes"), "\n")
  signalCondition(condObject)
  which
}

# add objects to the generic function's environment that allow
# table-based dispatch of methods
.setupMethodsTables <- function(generic,
		initialize = !exists(".MTable", envir = env, inherits = FALSE))
{
    env <- environment(generic)
    if(initialize || !exists(".SigLength", envir = env, inherits = FALSE)) {
        nsig <- 1
        ## check that groups of generics agree on .SigLength; otherwise
        ## labels won't match
        for(gp in generic@group) {
            gpDef <- getGeneric(gp)
            if(is(gpDef, "genericFunction")) {
                .getMethodsTable(gpDef) # force initialization
                nsig <- max(nsig, get(".SigLength", envir = environment(gpDef)))
            }
        }
        assign(".SigLength", nsig, envir = env)
    }
    argSyms <- lapply(generic@signature, as.name)
    assign(".SigArgs", argSyms, envir = env)
    if(initialize) {
        mlist <- generic@default # from 2.11.0: method, primitive or NULL, not MethodsList
        mtable <- .mlistAddToTable(generic, mlist) # by default, adds to an empty table
        assign(".MTable", mtable, envir = env)
    }
    else ## the current .MTable
        mtable <- getMethodsForDispatch(generic)
    .resetInheritedMethods(env, mtable)
    if(is(generic, "groupGenericFunction")) {
        for(gp in generic@groupMembers) {
            gpDef <- getGeneric(gp)
            if(is(gpDef, "genericFunction"))
                .getMethodsTable(gpDef) # force initialization w. group methods
        }
    }
    NULL
}

.updateMethodsInTable <- function(generic, where, attach) {
  fenv <- environment(generic)
  reset <- identical(attach, "reset")
  if(is.null(mtable <- fenv$.MTable)) {
      .setupMethodsTables(generic)
      mtable <- get(".MTable", envir = fenv)
  }
  if(!reset) {
    env <- as.environment(where)
    tname <- .TableMetaName(generic@generic, generic@package)
    if(!is.null(tt <- env[[tname]])) {
      .mergeMethodsTable(generic, mtable, tt, attach)
    }
    ## else used to warn, but the generic may be implicitly required
    ## by class inheritance, without any explicit methods in this package
  }
  if(length(generic@group)) {
      groups <- as.list(generic@group)
      generics <- vector("list", length(groups))
      for(i in seq_along(groups))
        generics[[i]] <- getGeneric(groups[[i]])
    .checkGroupSigLength(groups, generics)
  }
  if(is(generic, "groupGenericFunction")) {
      .checkGroupSigLength(list(generic@generic), list(generic))
      for(g in getGroupMembers(generic))
          .updateMethodsInTable(getGeneric(g), where, attach)
  }
  .resetInheritedMethods(fenv, mtable)
  mtable
}

.resetInheritedMethods <- function(fenv, mtable) {
    allObjects <- character()
    direct <- names(mtable)
    if(!is.null(allTable <- fenv$.AllMTable)) {
        ## remove all inherited methods.  Note that code (e.g. setMethod) that asigns
        ## a new method to mtable is responsible for copying it to allTable as well.
        allObjects <- names(allTable)
        remove(list = setdiff(allObjects, direct), envir = allTable)
    }
    else {
        allTable <- new.env(TRUE, fenv)
        assign(".AllMTable", allTable, envir = fenv)
    }
    ## check for missing direct objects; usually a non-existent AllMTable?
    if(any(is.na(match(direct, allObjects)))) {
        list2env(as.list(mtable, all.names=TRUE), allTable)
    }
    for (d in direct) {
        m <- allTable[[d]]
        if (is(m, "MethodWithNext"))
            allTable[[d]] <- as(m, "MethodDefinition")
    }
    NULL
}

## In the following, consider separate "compute" and "print" functions/methods:
## Wish: alternative to 'classes' allow  "wild-card signature", e.g.,
##       showMethods("coerce", signature = c("dgeMatrix", "*"))
.showMethodsTable <- function(generic, includeDefs = FALSE, inherited = FALSE,
                              classes = NULL, showEmpty = TRUE, printTo = stdout())
{
    cf <- function(...) cat(file = printTo, sep = "", ...)
    sigString <- function(sig)
	paste0(names(sig), "=\"", as.character(sig), "\"", collapse = ", ")
##    qs <- function(what) paste0('"', what, '"', collapse = ", ")
    doFun <- function(func, pkg) cf("Function: ", func, " (package ", pkg, ")\n")
    env <- environment(generic)
##    signature <- generic@signature
    table <- get(if(inherited) ".AllMTable" else ".MTable", envir = env)
    f <- generic@generic
    p <- packageSlot(f)
    if(is.null(p)) p <- "base"
    deflt <- new("signature", generic, "ANY")
    labels <- sort(names(table))
    if(!is.null(classes) && length(labels) > 0L) {
	sigL <- strsplit(labels, split = "#")
	keep <- !vapply(sigL, function(x, y) all(is.na(match(x, y))), NA, y=classes)
	labels <- labels[keep]
    }
    if(length(labels) == 0L) {
	if(showEmpty) {
	    doFun(f,p)
	    cf("<No methods>\n\n")
	}
	return(invisible())
    }
    ## else: non-empty methods list
    doFun(f,p)
    for(m in mget(labels, table)) {
        pkgs <- NULL
	if(is.environment(m)) {  ## duplicate class case -- compare .findMethodInTable()
            pkgs <- names(m)
            m <- m[[pkgs[1L]]]
        }
	if( is(m, "MethodDefinition")) {
	    t <- m@target
	    if(length(t) == 0L)
		t <- deflt
	    d <- m@defined
	    if(length(d) == 0L)
		d <- deflt
	    cf(sigString(t), "\n")
	    if(!identical(t, d))
		cf("    (inherited from: ", sigString(d), ")\n")
            if(!.identC(m@generic, f) && length(m@generic) == 1L &&
               nzchar(m@generic))
		cf("    (definition from function \"", m@generic, "\")\n")
            if(length(pkgs) > 1)
                cf("  (", length(pkgs), " methods defined for this signature, with different packages)\n")
	}
	if(includeDefs && is.function(m)) {
	    if(is(m, "MethodDefinition"))
		m <- m@.Data
	    cat(deparse(m), sep="\n", "\n", file = printTo)
	}
    }
    cat("\n", file = printTo)
}

## temporary switch for tables
useMTable <- function(onOff = NA)
  .Call(C_R_set_method_dispatch, as.logical(onOff))

## get all the group generic functions, in breadth-first order since
## direct group inheritance is closer than indirect (all existing
## groups are mutually exclusive, but multiple group membership is
## allowed)
.getAllGroups <- function(funs) {
  start <- length(funs)
  for(i in seq_along(funs)) {
    groups <- funs[[i]]@group
    funs <- c(funs, lapply(groups,
                           function(what) {
                             f <- getGeneric(what)
                             if(!is.function(f))
                               stop("failed to find expected group generic function: ",
                                    what)
                             f
                           }))
    }
    ## now the next generations recusively
    if(length(funs) > start) {
      nmore <- length(funs) - start
      more <- Recall(funs[(start+1):length(funs)])
      ## did we add any groups?
      if(length(more) > nmore)
        funs <- c(funs, more[(nmore+1):length(more)])
    }
    funs
}

.getGroupMethods <- function(labels, generics, found) {
  methods <- list()
  for(i in seq_along(generics)) {
    gen <- generics[[i]]
    if(!is(gen,"genericFunction"))
      stop(gettextf("invalid group generic function in search for inherited method (class %s)",
                    dQuote(class(gen))),
           domain = NA)
    table <- .getMethodsTable(gen)
    allMethods <- sort(names(table))
    ## TODO:  possible for .SigLength to differ between group &
    ## members.  Requires expanding labels to max. length
    newFound <- rep(FALSE, length(found))
    newFound[!found] <- labels[!found] %in% allMethods
    found <- found | newFound
    methods[labels[newFound]] <- mget(labels[newFound], table)
  }
  methods
}

.getMethodsTable <- function(fdef, env = environment(fdef),
                             check = TRUE, inherited = FALSE)
{
    name <- if(inherited) ".AllMTable" else ".MTable"
    if(check && !exists(name, envir = env, inherits = FALSE)) {
	.setupMethodsTables(fdef, initialize = TRUE)
	if(!exists(name, envir = env, inherits = FALSE))
	    stop("invalid methods table request")
    }
    get(name, envir = env)
}

.getGenericSigLength <- function(fdef, env = environment(fdef), check = TRUE) {
    if(check && !exists(".SigLength", envir = env, inherits = FALSE))
      .setupMethodsTables(fdef)
    get(".SigLength", envir = env)
}


.checkGroupSigLength <- function(gnames, generics = lapply(gnames, getGeneric)) {
  funs <- gnames
  recall <- FALSE
  for(i in seq_along(gnames)) {
    what <- gnames[[i]]
    fdef <- generics[[i]]
    if(!is(fdef, "groupGenericFunction")) {
      warning(gettextf("trying to check signature length of group generic '%s', but it is not a group generic", what),
              domain = NA)
      next
    }
    if(length(fdef@group))  {# push up the check one level
      gnames[[i]] <- fdef@group
      generics[[i]] <- lapply(fdef@group, getGeneric)
      recall <- TRUE
      next
    }
    funs <- c(funs, getGroupMembers(fdef, TRUE, FALSE))
  }
  if(recall)
    return(Recall(unlist(gnames, FALSE), unlist(generics, FALSE)))
  funs <- unique(funs)
  fdefs <- lapply(funs, function(x) {
    if(is.character(x) && length(x) == 1L) getGeneric(x)
    else x})
  ## now compare the sig lengths
  sigs <- rep(0,length(funs))
  for(i in seq_along(sigs)) {
    what <- funs[[i]]
    fdef <- fdefs[[i]]
    if(is.null(fdef))
      next # getGroupMembers returns NULL if  member is not defined
    if(!is(fdef, "genericFunction"))
      warning(gettextf("trying to check signature length of generic '%s', but it is not a generic function: i = %d, funs = %s, gnames = %s",
                       what,  i, paste(unlist(funs), collapse = ", "),
                       paste(as.character(gnames), collapse = ", ")),
              domain = NA)
    else {
      ev <- environment(fdef)
      if(is.null(sigl <- ev$.SigLength)) {
	  .setupMethodsTables(fdef)
	  sigl <- get(".SigLength", envir = ev)
      }
      sigs[i] <- sigl
    }
  }
  n <- max(sigs)
    reset <- sigs < n & sigs > 0 # all the  sigs  for defined funs & less than max.
  if(any(reset)) {
    funs <- funs[reset]
    fdefs <- fdefs[reset]
    for(fdef in fdefs) {
        .resetSigLength(fdef, n)
    }
  }
  funs
}

## a simplified outer of paste
outerLabels <- function(labels, new) {
    ## WARNING: This code incorporates the definition of .sigLabel
    ## and so must change if that does (e.g. to include package)
    n <- length(labels)
    m <- length(new)
    paste(labels[rep.int(1L:n, rep.int(m,n))], new[rep.int(1L:m,n)], sep ="#")
}


.matchSigLength <- function(sig, fdef, fenv, reset = FALSE) {
  nargs <- .getGenericSigLength(fdef, fenv, TRUE)
  n <- length(sig)
  pkgs <- packageSlot(sig)
  if(n < nargs) {
      more <- nargs - n
      pkgs <- c(pkgs, rep("methods", more))
      sig <- c(as.character(sig), rep("ANY", more))
  }
  else if(n > nargs) { #reset table?
    if(all(sig[(nargs+1):n] == "ANY")) {
        length(sig) <- nargs
        if (!is.null(pkgs))
            length(pkgs) <- nargs
    } else {
      while(sig[[n]] == "ANY")
        n <- n-1
      if(reset)
        .resetSigLength(fdef, n)
      length(sig) <- n
      if (!is.null(pkgs))
          length(pkgs) <- n
    }
  }
  packageSlot(sig) <- pkgs
  sig
}

.resetSigLength <- function(fdef, n) {
    fenv <- environment(fdef)
    assign(".SigLength", n, envir = fenv)
    mtable <- .getMethodsTable(fdef, fenv, check = FALSE)
    signames <- fdef@signature
    length(signames) <- n
    .resetTable(mtable, n, signames)
    .resetInheritedMethods(fenv, mtable)
}

.TableMetaName <- function(name, package)
  methodsPackageMetaName("T", paste(name, package, sep=":"))

.TableMetaPrefix <- function()
    methodsPackageMetaName("T","")

# regexp for matching table names; semi-general but assumes the
# meta pattern starts with "." and has no other special characters
.TableMetaPattern <- function()
    paste0("^[.]",substring(methodsPackageMetaName("T",""),2))

.addToMetaTable <- function(fdef, signature, definition, where, nSig) {
  return()
}

## the real version
..addToMetaTable <- function(fdef, signature, definition, where,
                             nSig = .getGenericSigLength(fdef)) {
    ## TODO:  nSig should be a slot in the table
  tname <- .TableMetaName(fdef@generic, fdef@package)
  where <- as.environment(where)
  if(!is.null(table <- where[[tname]])) {
    if(length(signature) > nSig)
      .resetTable(table, length(signature), fdef@signature[seq_along(signature)])
  }
  else {
    table <- new.env(TRUE, environment(fdef))
    assign(tname, table, envir = where)
  }
  .cacheMethodInTable(fdef, signature, definition, table)
}

.removeMethodsMetaTable <- function(generic, where) {
    ## does not warn if none exists, on the theory that a generic may be created
    ## but no methods defined to create a table.  The use of implicitGeneric's is an example.
    tname <- .TableMetaName(generic@generic, generic@package)
    if(exists(tname, where, inherits = FALSE))
      rm(list=tname, pos = where)
}

.getGenericSigArgs <- function(fdef, env = environment(fdef), check = TRUE) {
    if(check && !exists(".SigLength", envir = env, inherits = FALSE))
      .setupMethodsTables(fdef)
    n <- get(".SigLength", envir = env)
    args <-  get(".SigArgs", envir = env)
    length(args) <- n
    args
}


## the most simple part of listFromMethods() below; not yet exported
tableNames <- function(generic, where, table) {
    fdef <- getGeneric(generic)
    if(missing(table))
	table <-
	    if(missing(where)) .getMethodsTable(fdef)
	    else get(.TableMetaName(fdef@generic, fdef@package),
                     envir = as.environment(where), inherits = FALSE)
    names(table)
}

listFromMethods <- function(generic, where, table) {
    fdef <- getGeneric(generic)
    if(missing(table))
	table <-
	    if(missing(where)) .getMethodsTable(fdef)
	    else get(.TableMetaName(fdef@generic, fdef@package),
		     envir = as.environment(where), inherits = FALSE)
    fev <- environment(fdef)
    nSigArgs <- .getGenericSigLength(fdef, fev)
    methods <- as.list(table, all.names=TRUE)
    names <- names(methods)
    if(nSigArgs > 1) {
        n <- length(names)
        sigs <- vector("list", n)
        namesCon <- textConnection(names)
        for(i in seq_len(n))
            sigs[[i]] <- scan(namesCon, "", sep ="#", nmax = nSigArgs, quiet=TRUE)
    }
    else
      sigs <- as.list(names)
    new("LinearMethodsList", classes=sigs, methods=methods,
        arguments = .getGenericSigArgs(fdef, fev), generic = fdef)
}

.makeMlist1 <- function(arg, objects, j = 1) {
    .MlistDefunct(".makeMlist1()")
    mnames <- character(length(objects))
    for(i in seq_along(objects)) {
        what <- objects[[i]]
        if(is.primitive(what))
          sig <- "ANY"
        else
          sig <- what@defined
        mnames[[i]] <- (if(length(sig) < j) "ANY" else sig[[j]])
    }
    names(objects) <- mnames
    new("MethodsList", argument = arg, methods = objects, allMethods = objects)
}

.makeMlist2 <- function(args, objects, j = 1) {
    ## make a list according to  argument j, convert these as needed
    .MlistDefunct(".makeMlist2()")
    mlists <- list()
    for(what in objects) {
        sig <- if(!is.primitive(what)) what@defined # else NULL
        if(length(sig) <= j)
            arg1 <- arg2 <- "ANY"
        else {
            arg1 <- sig[[j]]
            arg2 <- sig[[j+1]]
        }
        x <- list(what)
        el <- mlists[[arg1, exact = TRUE]]
        mlists[[arg1]] <- (if(is.null(el)) x else c(el, x))
    }
    jNext <- j+1
    if(jNext < length(args))
      for(i in seq_along(mlists))
          mlists[[i]] <- .makeMlist2(args, mlists[[i]], jNext)
    else {
        arg2 <- as.name(args[[jNext]])
        for(i in seq_along(mlists))
          mlists[[i]] <- .makeMlist1(arg2, mlists[[i]], jNext)
    }
    new("MethodsList", argument = as.name(args[[1L]]),
        methods = mlists, allMethods = mlists)
}

.makeMlistFromTable <- function(generic, where = NULL) {
    .MlistDefunct(".makeMlistFromTable()")
    if(is.null(where)) {
        what <- ".MTable"
        where <- environment(generic)
    }
    else {
        where <- as.environment(where)
        what <-  .TableMetaName(generic@generic, generic@package)
    }
    if(exists(what, envir = where, inherits= FALSE))
        table <- get(what, envir = where)
    else
        table <- new.env()
    value <- new("MethodsList", argument = as.name(generic@signature[[1]]))
    allNames <- sort(names(table))
    if(length(allNames) == 0L)
      return(value)
    argNames <- generic@signature
    ## USES THE PATTERN OF class#class#.... in the methods tables
    nargs <- nchar(unique(gsub("[^#]","", allNames)))+1
    if(length(nargs) > 1L) {
	warning("something weird:  inconsistent number of args in methods table strings:",
		paste(nargs,collapse = ", ")," (using the largest value)",
                domain = NA)
        nargs <- max(nargs)
    }
    length(argNames) <- nargs # the number of args used
    if(nargs == 1)
        .makeMlist1(as.name(argNames[[1L]]), mget(allNames, table))
    else
      .makeMlist2(argNames, mget(allNames, table))
 }

## assign a methods meta-data table, by default (and usually) a copy of the table
## from the generic function with the initial methods, if any.
.assignMethodsTableMetaData <- function(name, generic, where, table) {
    what <-  .TableMetaName(generic@generic, generic@package)
    if(missing(table))
	table <- .copyEnv(.getMethodsTable(generic))
    assign(what, table, envir = as.environment(where))
}

.getMethodsTableMetaData <-  function(generic, where, optional = FALSE) {
    what <- .TableMetaName(generic@generic, generic@package)
    if(!is.null(f <- get0(what, envir = where, inherits = FALSE)))
	f
    else if(optional)
      NULL
    else
      stop(gettextf("no methods table for generic %s from package %s in package %s",
                    sQuote(generic@generic),
                    sQuote(generic@package),
                    sQuote(getPackageName(where))),
           domain = NA)
}

setPackageSlot <- function(x, value) {
    packageSlot(x) <- value
    x
}

.inheritedArgsExpression <- function(target, defined, body) {
    expr <- substitute({}, list(DUMMY = "")) # bug if you use quote({})--is overwritten!!
    args <- names(defined)
    for(i in seq_along(defined)) {
        ei <- extends(setPackageSlot(target [[i]], packageSlot(target)[[i]]),
                      setPackageSlot(defined[[i]], packageSlot(defined)),
                      fullInfo = TRUE)
        if(is(ei, "SClassExtension")  && !ei@simple)
          expr[[length(expr) + 1L]] <-
            substitute(ARG <- as(ARG, DEFINED, strict = FALSE),
                       list(ARG = as.name(args[[i]]),
                            DEFINED = as.character(defined[[i]])))
    }
    if(length(expr) > 1L) {
       expr[length(expr) + 1L] <- list(body) # body could be NULL!
       expr
   }
    else
        NULL
}

testInheritedMethods <- function(f, signatures, test = TRUE,  virtual = FALSE,
                                 groupMethods = TRUE,  where = .GlobalEnv)
{
  ## Function relevantClasses is defined here to set object .undefClasses
  ## in testInheritedMethods as a marker to warn about undefined subclasses
  .relevantClasses <- function(classes, excludeVirtual, where, doinheritance) {
    classDefs <- lapply(classes, getClassDef, where)
    undefs <- vapply(classDefs, is.null, NA)
    if(any(undefs)) {
      .undefClasses <<- unique(c(.undefClasses, classes[undefs]))
      classes <- classes[!undefs]
      classDefs <- classDefs[!undefs]
    }
    if(doinheritance) {
      allSubs <- lapply(classDefs,  function(what) names(what@subclasses))
      allSubs <- unique(unlist(allSubs))
      pattern <- sapply(allSubs, .matchSubsPattern, classes, excludeVirtual)
      ## exclude virtuals
      if(excludeVirtual) {
        excl <- nzchar(pattern)
        pattern <- pattern[excl]
        allSubs <- allSubs[excl]
      }
      if(length(allSubs)>0)
        allSubs <- sapply(split(allSubs, pattern), `[[`,1)
      else
        allSubs <- character()
    }
    else
      allSubs <- character()
    ## prepend the classes themselves, as appropriate
    iAny <- match( "ANY", classes, 0)
    if(iAny > 0) {
      classes[[iAny]] <- ".Other" # non-virtual placeholder for ANY
      classDefs[[iAny]] <- getClassDef(".Other")
    }
    if(excludeVirtual)
      classes <- classes[vapply(classDefs, function(def) isFALSE(def@virtual), NA)]
    unique(c(classes, allSubs))
  }
  ## end of .relevantClasses

  if(!is(f, "genericFunction"))
    f <- getGeneric(f)
  fname <- f@generic
  if(missing(signatures)) {
    mdefs <- findMethods(f)
    mnames <- names(mdefs)
    sigs <-  findMethodSignatures(methods = mdefs)
    if(groupMethods) {
      groups <- getGroup(f, recursive = TRUE)
      for(group in groups) {
        fg <- getGeneric(group)
        mg <- findMethods(fg)
        sigsg <- findMethodSignatures(methods = mg)
        newSigs <- is.na(match(names(mg), mnames))
        mg <- mg[newSigs]
        mdefs <- c(mdefs, mg[newSigs])
        sigs <- rbind(sigs, sigsg[newSigs,])
        mnames <- c(mnames, names(mg)[newSigs])
      }
    }
    if(length(sigs) == 0)
      return(new("MethodSelectionReport", generic = fname))
    ## possible selection of which args to include with inheritance
    ok <- if(fname %in% c("coerce", "coerce<-"))
	match(colnames(sigs), "from", 0) > 0 else rep.int(TRUE, ncol(sigs))
    for(j in seq_len(ncol(sigs))) {
      classesj <- unique(sigs[,j])
      .undefClasses <- character()
      subclasses <- .relevantClasses(classesj, !virtual, where, ok[[j]])
      nj <- length(subclasses)
      ##       if(nj == 0) {  ##FIXME, wrong test
      ##         warning(gettextf("No eligible subclasses for argument '%s' found, so no contribution to analysis",
      ##                          colnames(sigs)[[j]]), domain  = NA)
      ##         next
      ##       }
      if(j > 1) {
        ## replicate all the previous elements of subclasses a la outer
        subclasses <- rep(subclasses, rep.int(ncomb, nj))
        ncomb <- ncomb * nj
        sigLabels <- paste(rep(sigLabels, times = nj), subclasses, sep = "#")
      }
      else {
        sigLabels <- subclasses
        ncomb <- nj
      }

      if(length(.undefClasses)) {
        warning(gettextf("undefined classes (%s) will be ignored for argument '%s'",
                         paste0('"',unique(.undefClasses),'"', collapse=", "),
                         colnames(sigs)[[j]]), domain = NA)
        .undefClasses <- character()
      }
    } ## loop on j
    ## now split the individual labels back into signatures
    signatures <- strsplit(sigLabels, "#", fixed = TRUE)
  } ## end of missing(signatures) case
  else if(is(signatures, "matrix") && typeof(signatures) == "character"
       && ncol(signatures) <= length(f@signature)) {
      ## turn signatures back into a list
      siglist <- vector("list", nrow(signatures))
      for(i in seq_len(nrow(signatures)))
        siglist[[i]] <- signatures[i,]
      signatures <- siglist
  }
  else stop("argument 'signatures' must be a character matrix whose rows are method signatures")
  ambig_target <- character()
  ambig_candidates <- list()
  ambig_selected <- character()
  ambig_note <- character()
  if(test) {
    ## define a handler that accumulates the attributes from the condition object
    warninghandler <- function(cond) {
      ambig_target <<- c(ambig_target, attr(cond, "target"))
      ambig_candidates <<- c(ambig_candidates, list(attr(cond, "candidates")))
      ambig_selected <<- c(ambig_selected, attr(cond, "selected"))
      ambig_note <<- c(ambig_note, attr(cond, "note"))
    }
    ambigOpt <- options(ambiguousMethodSelection = warninghandler)
    on.exit(options(ambigOpt))
    doSelect <-  function(sig) {
      x <- selectMethod(f = f, sig, optional = TRUE)
      if(is(x, "MethodDefinition")) {
        nsig <- x@defined
        if(length(nsig) < length(sig))
          c(nsig, rep("ANY", length(sig) - length(nsig)))
        else
          nsig
      }
      else if(is.null(x))
        rep_len("<NONE>", length(sig))
      else # primitive
        rep_len("ANY", length(sig))
    }
    signatures <- lapply(signatures, doSelect)
  }
  signatures <- sapply(signatures, paste0, collapse = "#")
  names(signatures) <- sigLabels

  new("MethodSelectionReport", generic = fname, allSelections = signatures,
      target = ambig_target, selected = ambig_selected,
      candidates = ambig_candidates, note = ambig_note)
}

.matchSubsPattern <- function(what, matchto, excludeVirtual) {
  def <- getClass(what)
  if(excludeVirtual & def@virtual)
    return("")
  matches <- match(names(def@contains), matchto, 0)
  matches <- matches[matches>0]
  paste(matches, collapse=".")
}