#  File src/library/methods/R/RMethodUtils.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2016 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/

## The real version of makeGeneric, to be installed after there are some
## generic functions to boot the definition (in particular, coerce and coerce<-)

.makeGeneric <-
## Makes a generic function object corresponding to the given function name.
## and definition.
  function(f, fdef,
           fdefault = fdef,
           group = list(),
           valueClass = character(),
           package = getPackageName(environment(fdef)),
           signature = NULL,
           genericFunction = NULL,
           simpleInheritanceOnly = NULL)
{
    checkTrace <- function(fun, what, f) {
        if(is(fun, "traceable")) {
            warning(gettextf("the function being used as %s in making a generic function for %s is currently traced; the function used will have tracing removed",
                             what,
                             sQuote(f)),
                    domain = NA)
            .untracedFunction(fun)
        }
        else
            fun
    }
    if(missing(fdef)) {
        if(missing(fdefault))
            stop(gettextf("must supply either a generic function or a function as default for %s",
                          sQuote(f)),
                 domain = NA)
        else if(isBaseFun(fdefault)) {
            fun <- genericForBasic(f)
            if (is.function(fun)) {
                return(fun)
            }
        }
        fdef <- fdefault
        body(fdef) <- substitute(standardGeneric(NAME), list(NAME = f))
        environment(fdef) <- .NamespaceOrPackage(package)
    }
    ## give the function a new environment, to cache methods later
    ev <- new.env()
    parent.env(ev) <- environment(fdef)
    environment(fdef) <- ev
    packageSlot(f) <- package
    assign(".Generic", f, envir = ev)
    fdef <- checkTrace(fdef)
    if(length(valueClass))
        fdef <- .ValidateValueClass(fdef, f, valueClass)
    group <- .asGroupArgument(group)
    if(is.null(genericFunction))
        value <- new("standardGeneric")
    else if(is(genericFunction, "genericFunction"))
        value <- genericFunction
    else
        stop(gettextf("the %s argument must be NULL or a generic function object; got an object of class %s",
                      sQuote("genericFunction"),
                      dQuote(class(genericFunction))),
             domain = NA)
    value@.Data <- fdef
    value@generic <- f
    value@group <- group
    value@valueClass <- valueClass
    value@package <- package
    args <- formalArgs(fdef)
    if(is.null(signature))
        signature <- args
    else if(any(is.na(match(signature, args))))
        stop(sprintf(ngettext(sum(is.na(match(signature, args))),
                              "non-argument found in the signature: %s",
                              "non-arguments found in the signature: %s"),
                     paste(signature[is.na(match(signature, args))], collapse = ", ")),
             domain = NA)
    dots <- match("...", signature)
    if(!is.na(dots)) { # remove "..." unless it is the only element of the signature
        if(length(signature) > 1L)
            signature <- signature[-dots]
    }
    if(length(signature) == 0L)
        stop("no suitable arguments to dispatch methods in this function")
    attr(signature, "simpleOnly") <- simpleInheritanceOnly # usually NULL
    value@signature <- signature
##    name <- signature[[1L]]
    if(is.null(fdefault))
        {} # pre 2.11.0: methods <- MethodsList(name)
    else {
        fdefault <- checkTrace(fdefault)
        if(!identical(formalArgs(fdefault), formalArgs(fdef)) &&
           !is.primitive(fdefault))
            stop(sprintf(ngettext(length(fdef),
	"the formal argument of the generic function for %s (%s) differs from that of the non-generic to be used as the default (%s)",
	"the formal arguments of the generic function for %s (%s) differ from those of the non-generic to be used as the default (%s)"),
			 f,
			 paste(formalArgs(fdef), collapse = ", "),
			 paste(formalArgs(fdefault), collapse = ", ")),
                 domain = NA)
        fdefault <- asMethodDefinition(fdefault, fdef = value)
        if(is(fdefault, "MethodDefinition"))
            fdefault@generic <- value@generic
        ## pre 2.11.0 methods <- MethodsList(name, fdefault)
    }
    value@default <- fdefault # pre 2.11.0 methods
    assign(".Methods", fdefault, envir = ev) ## ? why
    .setupMethodsTables(value, TRUE)
    value@skeleton <- generic.skeleton(f, fdef, fdefault)
    value
}

## stripped down version of asS4 in base (asS4 can't be used until the methods
## namespace is available -- no longer true)
.asS4 <- function (object)
    asS4(object, TRUE, 0L)

.notS4 <- function (object)
    asS4(object, FALSE, 0L)


## the bootstrap version: "#----" brackets lines that replace parts of the real version
makeGeneric <-
      function(f, fdef,
           fdefault = getFunction(f, generic = FALSE, mustFind = FALSE),
           group = list(), valueClass = character(), package, signature = NULL,
           genericFunction = NULL, simpleInheritanceOnly = NULL)
{
    ## give the function a new environment, to cache methods later
    ev <- new.env()
    parent.env(ev) <- environment(fdef)
    environment(fdef) <- ev
    packageSlot(f) <- package
    assign(".Generic", f, envir = ev)
    if(length(valueClass))
        fdef <- .ValidateValueClass(fdef, f, valueClass)
    group <- .asGroupArgument(group)
###--------
    value <- .asS4(fdef)
    if(is.null(genericFunction))
        class(value) <- .classNameFromMethods("standardGeneric")
    else
        class(value) <- class(genericFunction)
    slot(value, "generic", FALSE) <- f
    slot(value, "group", FALSE) <- group
    slot(value, "valueClass", FALSE) <- valueClass
    slot(value, "package", FALSE) <- package
###--------
    args <- formalArgs(fdef)
    if(is.null(signature))
        signature <- args
    else if(any(is.na(match(signature, args))))
        stop(sprintf(ngettext(sum(is.na(match(signature, args))),
                              "non-argument found in the signature: %s",
                              "non-arguments found in the signature: %s"),
                     paste(signature[is.na(match(signature, args))], collapse = ", ")),
             domain = NA)
    attr(signature, "simpleOnly") <- simpleInheritanceOnly # usually NULL
    dots <- match("...", signature)
    if(!is.na(dots)) ## ... is not currently supported in method signatures
        signature <- signature[-dots]
    if(length(signature) == 0L)
        stop("no suitable arguments to dispatch methods in this function")
###--------
    slot(value, "signature", FALSE) <- signature
###--------
    name <- signature[[1L]]
    if(is.null(fdefault))
      {}
    else
        fdefault <- asMethodDefinition(fdefault, fdef = value)
        if(is(fdefault, "MethodDefinition"))
            fdefault@generic <- value@generic
        ## pre 2.11.0 methods <- MethodsList(name, fdefault)
###--------
    assign(".Methods", fdefault, envir = ev)
    slot(value, "default", FALSE) <- fdefault
    slot(value, "skeleton", FALSE) <- generic.skeleton(f, fdef, fdefault)
###--------
    value
}

### FIXME: Not used by methods, but exposed through namespace. Deprecate?
makeStandardGeneric <-
  ## a utility function that makes a valid function calling
  ## standardGeneric for name f Works (more or less) even if the
  ## actual definition, fdef, is not a proper function, that is, it is
  ## a primitive or internal
  function(f, fdef)
{
    fgen <- fdef
    body(fgen) <- substitute(standardGeneric(FNAME), list(FNAME=f))
    ## detect R specials and builtins:  these don't provide an argument list
    if(typeof(fdef) != "closure") {
        ## Look in a list of pre-defined functions (and also of
        ## functions for which methods are prohibited)
        fgen <- genericForBasic(f)
        message(gettextf("making a generic for special function %s",
                         sQuote(f)),
                domain = NA)
        setPrimitiveMethods(f, fdef, "reset", fgen, NULL)
        ## Note that the body of the function comes from the list.  In
        ## a few cases ("$"), this body is not just a call to
        ## standardGeneric
    }
    fgen
}

generic.skeleton <- function(name, fdef, fdefault)
{
    anames <- formalArgs(fdef)
    skeleton <- lapply(as.list(c(name, anames)), as.name)
    ## any arguments after "..." have to be named
    dots <- match("...", anames)
    if(!is.na(dots) && dots < length(anames)) {
        anames[1L:dots] <- ""
        names(skeleton) <- c("", anames)
    }
    if(is.null(fdefault)) {
        fdefault <- fdef
	msg <- gettextf("invalid call in method dispatch to '%s' (no default method)",
			name)
	body(fdefault) <- substitute(stop(MESSAGE, domain = NA),
				     list(MESSAGE = msg))
        environment(fdefault) <- baseenv()
    }
    skeleton[[1L]] <- fdefault
    as.call(skeleton)
}


defaultDumpName <-
  ## the default name to be used for dumping a method.
  function(generic, signature)
{
    if(missing(signature))
        paste(generic, "R", sep=".", collapse =".")
    else
        paste(generic, paste(signature, collapse ="."), "R", sep=".")
}


mergeMethods <-
    ## merge the methods in the second MethodsList object into the first,
    ## and return the merged result.
    function(m1, m2, genericLabel = character())
{
    .MlistDeprecated("mergeMethods()")
    if(length(genericLabel) && is(m2, "MethodsList"))
        m2 <- .GenericInPrimitiveMethods(m2, genericLabel)
    if(is.null(m1) || is(m1, "EmptyMethodsList"))
        return(m2)
    tmp <- listFromMlist(m2)
    sigs <- tmp[[1]]
    methods <- tmp[[2]]
    for(i in seq_along(sigs)) {
        sigi <- sigs[[i]]
        if(.noMlists() && !identical(unique(sigi), "ANY"))
          next
        args <- names(sigi)
        m1 <- insertMethod(m1, as.character(sigi), args, methods[[i]], FALSE)
    }
    m1
}

doPrimitiveMethod <-
  ## do a primitive call to builtin function 'name' the definition and call
  ## provided, and carried out in the environment 'ev'.
  ##
  ## A call to 'doPrimitiveMethod' is used when the actual method is a .Primitive.
  ##  (because primitives don't behave correctly as ordinary functions,
  ## not having either formal arguments nor a function body).
  function(name, def, call = sys.call(sys.parent()), ev = sys.frame(sys.parent(2)))
{
    cat("called doPrimitiveMethod\n\n")
    ## Store a local version of function 'name' back where the current version was
    ## called.  Restore the previous state there on exit, either removing or re-assigning.
    if(!is.null(prev <- ev[[name]])) {
        on.exit(assign(name, prev, envir = ev))
    }
    else
        on.exit(rm(list=name, envir=ev))
    assign(name, def, envir = ev)
    eval(call, ev)
}

.renderSignature <- function(f, signature)
{
    nm <- names(signature)
    nm[nzchar(nm)] <- paste0(nm[nzchar(nm)], "=")
    msig <- paste0(nm, '"', as.vector(signature), '"')
    msig <- paste(msig, collapse = ",")
    gettextf("in method for %s with signature %s: ", sQuote(f), sQuote(msig))
}

conformMethod <- function(signature, mnames, fnames,
			  f = "<unspecified>", fdef, method)
{
    sig0 <- signature
    fsig <- fdef@signature
    if(is.na(match("...", mnames)) && !is.na(match("...", fnames)))
        fnames <- fnames[-match("...", fnames)]
    imf <- match(fnames, mnames)
    omitted <- is.na(imf)
    if(is.unsorted(imf[!omitted]))
	stop(.renderSignature(f, signature),
             "formal arguments in method and generic do not appear in the same order",
             call. = FALSE)
    if(!any(omitted)) ## i.e. mnames contains all fnames
        return(signature)
    sigNames <- names(signature)
    omittedSig <- sigNames %in% fnames[omitted] #  names in signature & generic but not in method defn
### FIXME:  the test below is too broad, with all.names().  Would be nice to have a test
### for something like assigning to one of the omitted arguments.
    ##     missingFnames <- fnames[omitted]
    ##     foundNames <- missingFnames %in% all.names(body(method), unique = TRUE)
    ##     if(any(foundNames))
    ##         warning(gettextf("%s function arguments omitted from method arguments, (%s), were found in method definition",
    ##                       label, paste(missingFnames[foundNames], collapse = ", ")),
    ##              domain = NA)
    if(!any(omittedSig))
      return(signature)
    if(any(is.na(match(signature[omittedSig], c("ANY", "missing"))))) {
        bad <- omittedSig & is.na(match(signature[omittedSig], c("ANY", "missing")))
        bad2 <- paste0(fnames[bad], " = \"", signature[bad], "\"", collapse = ", ")
        stop(.renderSignature(f, sig0),
             gettextf("formal arguments (%s) omitted in the method definition cannot be in the signature", bad2),
             call. = TRUE, domain = NA)
    }
    else if(!all(signature[omittedSig] == "missing")) {
        omittedSig <- omittedSig && (signature[omittedSig] != "missing")
        .message("Note: ", .renderSignature(f, sig0),
                 gettextf("expanding the signature to include omitted arguments in definition: %s",
                          paste(sigNames[omittedSig], "= \"missing\"",collapse = ", ")))
        omittedSig <- seq_along(omittedSig)[omittedSig] # logical index will extend signature!
        signature[omittedSig] <- "missing"
    }
    ## remove trailing "ANY"'s
    n <- length(signature)
    while(.identC(signature[[n]], "ANY"))
        n <- n - 1L
    length(signature) <- n
    length(fsig) <- n
    setNames(signature, fsig)
}

rematchDefinition <- function(definition, generic, mnames, fnames, signature)
{
    added <- any(is.na(match(mnames, fnames)))
    keepsDots <- !is.na(match("...", mnames))
    if(!added && keepsDots) {
        ## the formal args of the method must be identical to generic
        formals(definition, envir = environment(definition)) <- formals(generic)
        return(definition)
    }
    dotsPos <- match("...", fnames)
    if(added && is.na(dotsPos))
        stop(gettextf("methods can add arguments to the generic %s only if '...' is an argument to the generic", sQuote(generic@generic)),
             call. = TRUE)
    ## pass down all the names in common between method & generic,
    ## plus "..."  even if the method doesn't have it.  But NOT any
    ## arguments having class "missing" implicitly (see conformMethod),
    ## i.e., are not among 'mnames':
    useNames <- !is.na(imf <- match(fnames, mnames)) | fnames == "..."
    newCall <- lapply(c(".local", fnames[useNames]), as.name)

    ## Should not be needed, if conformMethod() has already been called:
    if(is.unsorted(imf[!is.na(imf)]))
	stop(.renderSignature(generic@generic, signature),
             "formal arguments in method and generic do not appear in the same order",
             call. = FALSE)

    ## leave newCall as a list while checking the trailing args
    if(keepsDots && dotsPos < length(fnames)) {
	## Trailing arguments are required to match.  This is a little
	## stronger than necessary, but this is a dicey case, because
	## the argument-matching may not be consistent otherwise (in
	## the generic, such arguments have to be supplied by name).
	## The important special case is replacement methods, where
	## value is the last argument.

	ntrail <- length(fnames) - dotsPos
	trailingArgs <- fnames[seq.int(to = length(fnames), length.out = ntrail)]
	if(!identical(	mnames[seq.int(to = length(mnames), length.out = ntrail)],
		      trailingArgs))
	    stop(gettextf("%s arguments (%s) after %s in the generic must appear in the method, in the same place at the end of the argument list",
                          .renderSignature(generic@generic, signature),
			  paste(sQuote(trailingArgs), collapse = ", "),
                          sQuote("...")),
                 call. = FALSE, domain = NA)
	newCallNames <- character(length(newCall))
	newCallNames[seq.int(to = length(newCallNames), length.out = ntrail)] <-
	    trailingArgs
	names(newCall) <- newCallNames
    }
    newCall <- as.call(newCall)
    newBody <- substitute({.local <- DEF; NEWCALL},
			  list(DEF = definition, NEWCALL = newCall))
    generic <- .copyMethodDefaults(generic, definition)
    body(generic, envir = environment(definition)) <- newBody
    generic
}


isRematched <- function(definition)
{
    ## detect the effects of rematchDefinition, if it was used.
    ## Has the obvious disadvantage of depending on the implementation.
    ## If we considered the rematching part of the API, a cleaner solution
    ## would be to include the "as given to setMethod" definition as a slot

    bdy <- body(definition)
    if(.identC(class(bdy),"{") && length(bdy) > 1L) {
        bdy <- bdy[[2L]]
        .identC(class(bdy), "<-") && identical(bdy[[2L]], as.name(".local"))
    } else FALSE
}

unRematchDefinition <- function(definition)
{
    if(isRematched(definition))
        definition <-  body(definition)[[2]][[3]] # value in assignmt to .local
    definition
}

getGeneric <-
  ## return the definition of the function named f as a generic.
  ##
  ## If there is no definition, throws an error or returns
  ## NULL according to the value of mustFind.
  function(f, mustFind = FALSE, where, package = "")
{
    if(is.function(f)) {
        if(is(f, "genericFunction"))
            return(f)
        else if(is.primitive(f))
            return(genericForBasic(.primname(f), mustFind=mustFind))
        else
            stop("argument 'f' must be a string, generic function, or primitive: got an ordinary function")
    }
    value <- if(missing(where))
		  .getGeneric(f,      , package)
	     else .getGeneric(f, where, package)
    if(is.null(value) && !is.null(baseDef <- baseenv()[[f]])) {
        if(is.function(baseDef)) {
            value <- genericForBasic(f, mustFind=FALSE)
            if(is(value, "genericFunction"))
                value <- .cacheGeneric(f, value)
        }
    }
    if(is.function(value))
        value
    else {
        if(nzchar(package) && is.na(match(package, c("methods", "base")))) {
            value <- tryCatch({
                ## load package namespace or error
                ev <- getNamespace(package)
                .getGeneric(f, ev, package)
            }, error = function(e) NULL)
        }
        if(is.function(value))
            value
        else if(mustFind)
            ## the C code will have thrown an error if f is not a single string
            stop(gettextf("no generic function found for %s", sQuote(f)),
                 domain = NA)
        else
            NULL
    }
}

## low-level version
.getGeneric <- function(f, where = .GlobalEnv, # default only for C search
                        package = "")
{
    ## do not search the cache if getGeneric() was called with explicit where=
    value <- if(missing(where))
        .getGenericFromCache(f, where,  package) ## else NULL
    if(is.null(value)) {
        if(is.character(f) && f %in% "as.double") f <- "as.numeric"
        if(is.character(f) && !nzchar(f)) {
            message("Empty function name in .getGeneric")
            dput(sys.calls())
        }
        value <- .Call(C_R_getGeneric, f, FALSE, as.environment(where), package)
        ## cache public generics (usually these will have been cached already
        ## and we get to this code for non-exported generics)
        if(!is.null(value) && !is.null(vv <- .GlobalEnv[[f]]) &&
           identical(vv, value))
            .cacheGeneric(f, value)
    }
    ##     if(is.null(value) && nzchar(package) && !identical(package, "base")) {
    ##         env <- .requirePackage(package, FALSE)
    ##         if(is.environment(env))
    ##           value <- .Call("R_getGeneric", f, FALSE, env, package,
    ##                      PACKAGE = "methods")
    ##     }
    value
}

## cache and retrieve generic functions.  If the same generic name
## appears for multiple packages, a named list of the generics is cached.
.genericTable <- new.env(TRUE, baseenv())

.implicitTable <- new.env(TRUE, baseenv())

.cacheGeneric <- function(name, def)
  .cacheGenericTable(name, def, .genericTable)

.cacheImplicitGeneric <- function(name, def)
   .cacheGenericTable(name, def, .implicitTable)

.cacheGenericTable <- function(name, def, table)
{
    fdef <- def
    if(!is.null(prev <- table[[name]])) {
        newpkg <- def@package
        if(is.function(prev)) {
            if(identical(prev, def))
                return(fdef)
            ## the following makes the cached version != package
            ##  fdef <- def <- .makeGenericForCache(def)
            pkg <- prev@package
            if(identical(pkg, newpkg)) { # redefinition
                table[[name]] <- def
                return(fdef)
            }
            prev <- list(prev)          # start a per-package list
            names(prev) <- pkg
        }
        i <- match(newpkg, names(prev))
        if(is.na(i))
            prev[[newpkg]] <- def # or, .makeGenericForCache(def) as above
        else if(identical(def, prev[[i]]))
            return(fdef)
        else
            prev[[i]] <- def  # or, .makeGenericForCache(def) as above
        def <- prev
    }

    .getMethodsTable(fdef)              # force initialization
    table[[name]] <- def
    fdef
}

.uncacheGeneric <- function(name, def)
  .uncacheGenericTable(name, def, .genericTable)

.uncacheImplicitGeneric <- function(name, def)
  .uncacheGenericTable(name, def, .implicitTable)

.uncacheGenericTable <- function(name, def, table)
{
    if(exists(name, envir = table, inherits = FALSE)) {
        newpkg <- def@package
        prev <- get(name, envir = table)
        if(is.function(prev))  # we might worry if  prev not identical
            return(remove(list = name, envir = table))
        i <- match(newpkg, names(prev))
        if(!is.na(i))
            prev[[i]] <- NULL
        else           # we might warn about unchaching more than once
            return()
        if(length(prev) == 0L)
            return(remove(list = name, envir = table))
        else if(length(prev) == 1L)
            prev <- prev[[1L]]
        assign(name, prev, envir  = table)
    }
}

.getGenericFromCache <- function(name, where,  pkg = "")
   .getGenericFromCacheTable(name, where, pkg, .genericTable)

.getImplicitGenericFromCache <- function(name, where,  pkg = "")
   .getGenericFromCacheTable(name, where, pkg, .implicitTable)

.getGenericFromCacheTable <- function(name, where, pkg = "", table)
{
    if(exists(name, envir = table, inherits = FALSE)) {
        value <- get(name, envir = table)
        if(is.list(value)) {        # multiple generics with this name
            ## force a check of package name, even if argument is ""
            if(!nzchar(pkg)) {
                if(is.character(where))
                    pkg <- where
                else {
                    pkg <- attr(name, "package")
                    if(is.null(pkg))
                        pkg <- getPackageName(where, FALSE)
                    if(identical(pkg, ".GlobalEnv"))
                        pkg <- ""
                }
            }
            pkgs <- names(value)
            i <- match(pkg, pkgs, 0L)
            if(i > 0L)
                return(value[[i]])
            i <- match("methods", pkgs, 0L)
            if(i > 0L)
                return(value[[i]])
            i <- match("base", pkgs, 0L)
            if(i > 0L)
                return(value[[i]])
            else
                return(NULL)
        }
        else if(nzchar(pkg) && !identical(pkg, value@package))
            NULL
        else
            value
    }
    else
        NULL
}

.genericOrImplicit <- function(name, pkg, env)
{
    fdef <- .getGenericFromCache(name, env, pkg)
    if(is.null(fdef)) {
	penv <- tryCatch(getNamespace(pkg), error = function(e)e)
	if(!isNamespace(penv))	{      # no namespace--should be rare!
	    pname <- paste0("package:", pkg)
	    penv <- if(pname %in% search()) as.environment(pname) else env
	}
        fdef <- getFunction(name, TRUE, FALSE, penv)
        if(!is(fdef, "genericFunction")) {
            if(is.primitive(fdef))
                fdef <- genericForBasic(name, penv)
            else
                fdef <- implicitGeneric(name, penv)
        }
    }
    fdef
}


## copy the environments in the generic function so later merging into
## the cached generic will not modify the generic in the package.
## NOT CURRENTLY USED: see comments in .getGeneric()
.makeGenericForCache <- function(fdef)
{
    value <- fdef
    ev <- environment(fdef)
    objs <- lapply(as.list(ev, all.names=TRUE), function(obj) {
        if(is.environment(obj))
            obj <- .copyEnv(obj)
        obj
    })
    environment(value) <- list2env(objs, hash=TRUE, parent=parent.env(ev))
    value
}

.copyEnv <- function(env)
{
    list2env(as.list(env, all.names=TRUE), hash=TRUE, parent=parent.env(env))
}

getGroup <-
  ## return the groups to which this generic belongs.  If 'recursive=TRUE', also all the
  ## group(s) of these groups.
  function(fdef, recursive = FALSE, where = topenv(parent.frame()))
{
    if(is.character(fdef))
        fdef <- getGeneric(fdef, where = where)
    if(is(fdef, "genericFunction"))
        group <- fdef@group
    else
        group <- list()
    if(recursive && length(group)) {
        allGroups <- group
        for(gp in group) {
            fgp <- getGeneric(gp, where = where)
            if(is(fgp, "groupGenericFunction"))
                allGroups <- c(allGroups, Recall(fgp, TRUE, where))
        }
        if(length(allGroups) > 1L) {
            ids <- sapply(allGroups, function(x) {
                pkg <- packageSlot(x)
                if(is.null(pkg)) x
                else paste(x, pkg, sep=":")
            })
            allGroups <- allGroups[!duplicated(ids)]
        }
        allGroups
    }
    else
        group
}

getMethodsMetaData <- function(f, where = topenv(parent.frame()))
{
    fdef <- getGeneric(f, where = where)
    if(is.null(fdef))
        return(NULL)
    if(.noMlists()) {
        warning(sprintf("Methods list objects are not maintained in this version of R:  request for function %s may return incorrect information",
                        sQuote(fdef@generic)),
                domain = NA)
    }
    mname <- methodsPackageMetaName("M",fdef@generic, fdef@package)
    if (exists(mname, where = where, inherits = missing(where)))
        get(mname, where)
    else if(missing(where))
        .makeMlistFromTable(fdef)
    else
        .makeMlistFromTable(fdef, where)
}

assignMethodsMetaData <-
  ## assign value to be the methods metadata for generic f on database where.
  ## as of R 2.7.0 the mlist metadata is deprecated.
  ## If value is not a MethodsList,  only turns on primitives & groups
  function(f, value, fdef, where)
{
    where <- as.environment(where)
    if(is(value, "MethodsList")) {
	.MlistDeprecated()
        mname <- methodsPackageMetaName("M",fdef@generic, fdef@package)
        if(exists(mname, envir = where, inherits = FALSE) &&
           bindingIsLocked(mname, where))
          {}        # may be called from trace() with locked binding; ignore
        else
          assign(mname, value, where)
    }
    if(dispatchIsInternal(fdef))
        setPrimitiveMethods(f, fdef@default, "reset", fdef, NULL)
    if(is(fdef, "groupGenericFunction")) # reset or turn on members of group
        cacheGenericsMetaData(f, fdef, where = where, package = fdef@package)
}


## utility for getGenerics to return package(s)
.packageForGeneric <- function(object)
{
    if(is.list(object))                 # a list of objects
        lapply(object, .packageForGeneric)
    else if(is(object, "genericFunction"))
        object@package
    else ## ?? possibly a primitive
        "base"
}

getGenerics <- function(where, searchForm = FALSE)
{
    if(missing(where)) {
        ## all the packages cached ==? all packages with methods
        ## globally visible.  Assertion based on cacheMetaData + setMethod
        fdefs <- as.list(.genericTable, all.names=TRUE, sorted=TRUE)
        fnames <- mapply(function(nm, obj) {
            if (is.list(obj)) names(obj) else nm
        }, names(fdefs), fdefs, SIMPLIFY=FALSE)
        packages <- lapply(fdefs, .packageForGeneric)
        new("ObjectsWithPackage", unlist(fnames), package=unlist(packages))
    }
    else {
        if(is.environment(where)) where <- list(where)
        ## The order matters ... and there might be no objects.
        these <- unlist(lapply(where, objects, all.names=TRUE), use.names=FALSE)
        metaNameUndo(unique(these), prefix = "T", searchForm = searchForm)
    }
}

## Find the pattern for methods lists or tables
## Currently driven by mlists, but eventually these will go away
## in favor of tables.

## always returns a compatible list, with an option of  prefix
.getGenerics <- function(where, trim = TRUE)
{
    if(missing(where)) where <- .envSearch(topenv(parent.frame()))
    else if(is.environment(where)) where <- list(where)
    these <- unlist(lapply(where, objects, all.names=TRUE), use.names=FALSE)
    these <- unique(these)
    these <- these[startsWith(these, ".__T__")]
    if(length(these) == 0L)
        return(character())
    funNames <- gsub("^.__T__(.*):([^:]+)", "\\1", these)
    ## FIXME: length(funNames) == length(these) != 0   ==> this never triggers:
    ## if(length(funNames) == 0L && any(startsWith(these, ".__M__")))
    ##     warning(sprintf("package %s seems to have out-of-date methods; need to reinstall from source",
    ##                      sQuote(getPackageName(where[[1L]]))))
    packageNames <- gsub(".__T__(.*):([^:]+(.*))", "\\2", these)
    attr(funNames, "package") <- packageNames
    ## Would prefer following, but may be trouble bootstrapping methods
    ## funNames <- new("ObjectsWithPackage", funNames, package = packageNames)
    if(isTRUE(trim))
        funNames
    else if(isFALSE(trim))
        these
    else
        gsub(".__T__", as.character(trim), these)
}

cacheMetaData <-
    function(where, attach = TRUE, searchWhere = as.environment(where),
             doCheck = TRUE)
{
    ## a collection of actions performed on attach or detach
    ## to update class and method information.
    pkg <- getPackageName(where)
    classes <- getClasses(where)
    if (attach) {
        for(cl in classes) {
            ## NOT getClassDef, it will use cache
            cldef <- get(classMetaName(cl), where)
            if(is(cldef, "classRepresentation"))
                .cacheClass(cl, cldef, is(cldef, "ClassUnionRepresentation"),
                            where)
        }
    } else {
        for(cl in classes) {
            cldef <- getClassDef(cl, searchWhere)
            if(is(cldef, "classRepresentation") &&
               identical(cldef@package, pkg)) {
                .uncacheClass(cl, cldef)
                .removeSuperclassBackRefs(cl, cldef, searchWhere)
                if(is(cldef, "ClassUnionRepresentation")) {
                    subclasses <- names(cldef@subclasses)
                    for(subclass in subclasses)
                        .removeSuperClass(subclass, cl)
                }
            }
        }
    }
    generics <- .getGenerics(where)
    packages <- attr(generics, "package")
    if(length(packages) <  length(generics))
        packages <- rep(packages, length.out = length(generics))
    if(attach && exists(".requireCachedGenerics", where, inherits = FALSE)) {
        others <- get(".requireCachedGenerics", where)
        generics <- c(generics, others)
        packages <- c(packages, attr(others, "package"))
    }
    ## check for duplicates
    dups <- duplicated(generics) & duplicated(packages)
    generics <- generics[!dups]
    for(i in seq_along(generics)) {
        f <- generics[[i]]
        fpkg <- packages[[i]]
        if(!identical(fpkg, pkg) && doCheck) {
            if(attach) {
                env <- as.environment(where)
                ## All instances of this generic in different attached packages must
                ## agree with the cached version of the generic for consistent
                ## method selection.
                if(exists(f, envir = env, inherits = FALSE)) {
                    def <- get(f, envir = env)
                    fdef <- .genericOrImplicit(f, fpkg, env)
                    if(is.function(def)) {
                        ## exclude a non-function of the same name as a primitive with methods (!)
                        if(identical(environment(def), environment(fdef)))
                            next        # the methods are identical
                        else if( is(fdef, "genericFunction")) {
                            .assignOverBinding(f, fdef,  env, FALSE)
                        }
                    }     # else, go ahead to update primitive methods
                }
                else          # either imported generic or a primitive
                    fdef <- getGeneric(f, FALSE, searchWhere, fpkg)
            }
            else
                fdef <- getGeneric(f, FALSE, searchWhere, fpkg)
        }
        else
            fdef <- getGeneric(f, FALSE, searchWhere, fpkg)
        if(!is(fdef, "genericFunction"))
            next ## silently ignores all generics not visible from searchWhere
        if(attach)
            .cacheGeneric(f, fdef)
        else
            .uncacheGeneric(f, fdef)
        methods <- .updateMethodsInTable(fdef, where, attach)
        cacheGenericsMetaData(f, fdef, attach, where, fdef@package, methods)
    }
    .doLoadActions(where, attach)
    invisible(NULL) ## as some people call this at the end of functions
}


cacheGenericsMetaData <- function(f, fdef, attach = TRUE,
                                  where = topenv(parent.frame()),
                                  package, methods)
{
    if(!is(fdef, "genericFunction")) {
	warning(gettextf("no methods found for %s; cacheGenericsMetaData() will have no effect",
			 sQuote(f)),
		domain = NA)
	return(FALSE)
    }
    if(missing(package))
        package <- fdef@package
### Assertion: methods argument unused except for primitives
### and then only for the old non-table case.
    deflt <- finalDefaultMethod(fdef@default) #only to detect primitives
    if(dispatchIsInternal(fdef)) {
	if(missing(methods)) ## "reset"
	    setPrimitiveMethods(f, deflt, "reset", fdef, NULL)
	else ## "set"
	    setPrimitiveMethods(f, deflt, "set", fdef, methods)
    }
    else if(isGroup(f, fdef = fdef)) {
	members <- fdef@groupMembers
	## do the computations for the members as well; important if the
	## members are primitive functions.
	for(ff in members) {
	    ffdef <- getGeneric(ff, where = where)
	    if(is(ffdef, "genericFunction"))
		Recall(ff, ffdef, attach, where,
                       methods = .getMethodsTable(ffdef))
	}
    }
    TRUE
}

setPrimitiveMethods <-
  function(f, fdef, code, generic, mlist = get(".Methods", envir = environment(generic)))
    .Call(C_R_M_setPrimitiveMethods, f, fdef, code, generic, mlist)

### utility to turn ALL primitive methods on or off (to avoid possible inf. recursion)
.allowPrimitiveMethods <- function(onOff) {
    code <- if(onOff) "SET" else "CLEAR"
    .Call(C_R_M_setPrimitiveMethods, "", NULL, code, NULL, NULL)
}


findUnique <- function(what, message, where = topenv(parent.frame()))
{
    where <- .findAll(what, where = where)
    if(length(where) > 1L) {
        if(missing(message))
            message <- sQuote(what)
        if(is.list(where))
            where <- unlist(where)
        if(is.numeric(where))
            where <- search()[where]
        warning(message,
                sprintf(" found on: %s; using the first one",
                        paste(sQuote(where), collapse = ", ")),
                domain = NA)
        where <- where[1L]
    }
    where
}

MethodAddCoerce <- function(method, argName, thisClass, methodClass)
{
    if(.identC(thisClass, methodClass))
        return(method)
    ext <- possibleExtends(thisClass, methodClass)
    ## if a non-simple coerce is required to get to the target class for
    ## dispatch, insert it in the method.
    if(is.logical(ext) || ext@simple)
        return(method)
    methodInsert <- function(method, addExpr) {
        if(is.function(method)) {
            newBody <- substitute({firstExpr; secondExpr},
                                  list(firstExpr = addExpr,
                                       secondExpr = body(method)))
            body(method, envir = environment(method)) <- newBody
        }
        else if(is(method, "MethodsList")) {
	    .MlistDeprecated()
            methods <- method@allMethods
            for(i in seq_along(methods))
                methods[[i]] <- Recall(methods[[i]], addExpr)
            method@allMethods <- methods
        }
        method
    }
    addExpr <- substitute(XXX <- as(XXX, CLASS),
                          list(XXX = argName, CLASS = methodClass))
    methodInsert(method, addExpr)
}

missingArg <- function(symbol, envir = parent.frame(), eval = FALSE)
    .Call(C_R_missingArg, if(eval) symbol else substitute(symbol), envir)

balanceMethodsList <- function(mlist, args, check = TRUE)
{
    .MlistDeprecated("balanceMethodsList()")
    moreArgs <- args[-1L]
    if(length(moreArgs) == 0L)
        return(mlist)
    methods <- mlist@methods
    if(check && length(methods)) {
        ## check whether the current depth is enough (i.e.,
        ## whether a method with this no. of args or more was set before
        depth <- 0
        el <- methods[[1L]]
        while(is(el, "MethodsList")) {
            mm <- el@methods
            if(length(mm) == 0L)
                break
            depth <- depth+1L
            el <- mm[[1L]]
        }
        if(depth >= length(args))
            ## already balanced to this length: An assertion
            ## relying on balance having been used consistently,
            ## which in turn relies on setMethod being called to
            ## add methods.  If you roll your own, tough luck!
            return(mlist)
    }
    for(i in seq_along(methods)) {
        el <- methods[[i]]
        if(is(el, "MethodsList"))
            el <- Recall(el, moreArgs, FALSE)
        else {
            if(is(el, "MethodDefinition")) {
                el@target[moreArgs] <- "ANY"
                el@defined[moreArgs] <- "ANY"
            }
            for(what in rev(moreArgs))
                el <- new("MethodsList", argument = as.name(what),
                          methods = list(ANY = el))
        }
        methods[[i]] <- el
    }
    mlist@methods <- methods
    mlist
}


sigToEnv <- function(signature, generic)
{
    genericSig <- generic@signature
    package <- packageSlot(signature)
    if(is.null(package))
        parent <- environment(generic)
    else
        parent <- .requirePackage(package)
    value <- new.env(parent = parent)
    classes <- as.character(signature)
    args <- names(signature)
    for(i in seq_along(args))
        assign(args[[i]], classes[[i]], envir = value)
    ## missing args in signature have class "ANY"
    if(length(args) < length(genericSig))
        for(other in genericSig[is.na(match(genericSig, args))])
            assign(other, "ANY", envir = value)
    value
}

methodSignatureMatrix <- function(object, sigSlots = c("target", "defined"))
{
    if(length(sigSlots)) {
        allSlots <- lapply(sigSlots, slot, object = object)
        n <- max(lengths(allSlots))
        mm <- unlist(lapply(allSlots, function(s) {
            length(s) <- n
            s[is.na(s)] <- "ANY"
            s
        }))
        mm <- matrix(mm, nrow = length(allSlots), byrow = TRUE)
        dimnames(mm) <- list(sigSlots, names(allSlots[[1L]]))
        mm
    }
    else matrix(character(), 0L, 0L)
}

.valueClassTest <- function(object, classes, fname)
{
    if(length(classes)) {
        for(Cl in classes)
            if(is(object, Cl)) return(object)
        stop(gettextf("invalid value from generic function %s, class %s, expected %s",
                      sQuote(fname),
                      dQuote(class(object)),
                      paste(dQuote(classes), collapse = " or ")),
             domain = NA)
    }
    ## empty test is allowed
    object
}


.getOrMakeMethodsList <- function(f, where, genericFun)
{
    allMethods <- getMethodsMetaData(f, where = where)
    if(is.null(allMethods)) {
        argName <- genericFun@signature[[1L]]
	warning("\"MethodsList\" is defunct; allMethods now are empty")
##-        allMethods <- new("MethodsList", argument = as.name(argName))
#         other <- getMethodsMetaData(f)
#         if(is.null(other))
#             ## this utility is called AFTER ensuring the existence of a generic for f
#             ## Therefore, the case below can only happen for a primitive for which
#             ## no methods currently are attached.  Make the primitive the default
#             deflt <- getFunction(f, generic = FALSE, mustFind = FALSE)
#         else
#             ## inherit the default method, if any
#             deflt <- finalDefaultMethod(other)
#         if(!is.null(deflt))
#             allMethods <- insertMethod(allMethods, "ANY", argName, deflt)
    }
    allMethods
}

.makeCallString <- function(def, name = substitute(def), args = formalArgs(def))
{
    if(is.character(def)) {
        if(missing(name))
            name <- def
        def <- getFunction(def)
    }
    if(is.function(def))
        paste0(name, "(", paste(args, collapse=", "), ")")
    else
        ""
}

.ValidateValueClass <- function(fdef, name, valueClass)
{
    ## include tests for value
    fbody <- body(fdef)
    body(fdef, envir = environment(fdef)) <-
        substitute({
            ans <- EXPR
            .valueClassTest(ans, VALUECLASS, FNAME)
        }, list(EXPR = fbody, VALUECLASS = valueClass, FNAME = name))
    fdef
}

## interpret the group= argument to makeGeneric, allowing for char. argument
## and "" for compatibility.
## TO DO:  make it possible for this argument to be a group generic function
## (it may in fact work now).
.asGroupArgument <- function(group)
{
    if(is.character(group)) {
	if(identical(group, ""))
	    list()
	else
	    as.list(group) ## should we allow c(group, package) ?
    }
    else
	group
}

metaNameUndo <- function(strings, prefix, searchForm = FALSE)
{
    pattern <- methodsPackageMetaName(prefix, "")
    n <- nchar(pattern, "c")
    matched <- substr(strings, 1L, n) == pattern
    value <- substring(strings[matched], n+1L)
    pkg <- sub("^[^:]*", "", value)   # will be "" if no : in the name
    if(searchForm) {
        global <- grep(".GlobalEnv", value)
        if(length(global)) {
            pkg[-global] <- paste0("package", pkg[-global])
            pkg[global] <- substring(pkg[global], 2L)
        }
    }
    else
        pkg <- substring(pkg, 2L)
    value <- sub(":.*","", value)
    new("ObjectsWithPackage", value, package = pkg)
}

.recursiveCallTest <- function(x, fname)
{
    if(is(x, "call")) {
        if(identical(x[[1L]], quote(standardGeneric))) {
            if(!identical(x[[2L]], fname))
                warning(gettextf("the body of the generic function for %s calls 'standardGeneric' to dispatch on a different name (\"%s\")!",
                                 sQuote(fname),
                                 paste(as.character(x[[2L]]), collapse = "\n")),
                        domain = NA)
            TRUE
        }
        else {
            for(i in seq.int(from=2L, length.out = length(x)-1L)) {
                if(Recall(x[[i]], fname))
                    return(TRUE)
            }
            FALSE
        }
    }
    else if(is(x, "language")) {
        for(i in seq.int(from=2L, length.out = length(x)-1L)) {
            if(Recall(x[[i]], fname))
                return(TRUE)
        }
        FALSE
    }
    else
        FALSE
}

.NonstandardGenericTest <- function(body, fname, stdBody)
{
    if(identical(body, stdBody))
        FALSE
    else if(.recursiveCallTest(body, fname))
        TRUE
    else
        NA
}

.GenericInPrimitiveMethods <- function(mlist, f)
{
    methods <- mlist@methods
    for(i in seq_along(methods)) {
        mi <- methods[[i]]
        if(is.function(mi)) {
            body(mi, envir = environment(mi)) <-
                substitute({.Generic <- FF; BODY},
                           list(FF = f,BODY = body(mi)))
        }
	else if(is(mi, "MethodsList")) {
	    .MlistDeprecated()
            mi <- Recall(mi, f)
	} else
            stop(sprintf("internal error: Bad methods list object in fixing methods for primitive function %s",
                          sQuote(f)),
                 domain = NA)
        methods[[i]] <- mi
    }
    mlist@methods <- methods
    mlist
}

.signatureString <- function(fdef, signature)
{
    snames <- names(signature)
    if(is.null(snames)) {
        if(is(fdef, "genericFunction")) {
            snames <- fdef@signature
            signature <- matchSignature(signature, fdef)
            if(length(snames) > length(signature))
                length(snames) <- length(signature)
        }
        else                            # shouldn't happen,...
            return(paste(signature, collapse=", "))
    }
    else
        signature <- as.character(signature)
    paste(paste0(snames, "=\"", signature, "\""), collapse = ", ")
}

.ChangeFormals <- function(def, defForArgs, msg = "<unidentified context>")
{
    if(!is.function(def))
        stop(gettextf("trying to change the formal arguments in %s in an object of class %s; expected a function definition",
                      msg, dQuote(class(def))),
             domain = NA)
    if(!is.function(defForArgs))
        stop(gettextf("trying to change the formal arguments in %s, but getting the new formals from an object of class %s; expected a function definition",
                      msg, dQuote(class(def))),
             domain = NA)
    old <- formalArgs(def)
    new <- formalArgs(defForArgs)
    if(length(old) < length(new))
        stop(gettextf("trying to change the formal arguments in %s, but the number of existing arguments is less than the number of new arguments: (%s) vs (%s)",
                      msg, paste0("\"", old, "\"", collapse=", "),
                      paste0("\"", new, "\"", collapse=", ")),
             domain = NA)
    if(length(old) > length(new))
        warning(gettextf("trying to change the formal arguments in %s, but the number of existing arguments is greater than the number of new arguments (the extra arguments won't be used): (%s) vs (%s)",
                         msg, paste0("\"", old, "\"", collapse=", "),
                         paste0("\"", new, "\"", collapse=", ")),
                domain = NA)
    if(identical(old, new))           # including the case of 0 length
        return(def)
    dlist <- as.list(def)
    slist <- lapply(c(old, new), as.name)
    names(slist) <- c(new, old)
    vlist <- dlist
    for(i in seq_along(vlist))
        vlist[[i]] <- do.call("substitute", list(vlist[[i]], slist))
    dnames <- names(dlist)
    whereNames <- match(old, dnames)
    if(anyNA(whereNames))
	stop(gettextf("in changing formal arguments in %s, some of the old names are not in fact arguments: %s",
		      msg, paste0("\"", old[is.na(match(old, names(dlist)))], "\"", collapse=", ")),
	     domain = NA)
    dnames[whereNames] <- new
    names(vlist) <- dnames
    as.function(vlist, envir = environment(def))
}

## The search list, or a namespace's static search list, or an environment
.envSearch <- function(env = topenv(parent.frame()))
{
    if(identical(env, .GlobalEnv))
        seq_along(search())
    else if(isNamespace(env) && !isBaseNamespace(env)) {
        ## the static environments for this namespace, ending with the base namespace
        value <- list(env)
        repeat {
            if(identical(env, emptyenv()))
                stop("botched namespace: failed to find 'base' namespace in its parents", domain = NA)
            env <- parent.env(env)
            value <- c(value, list(env))
            if(isBaseNamespace(env))
                break
        }
        value
    }
    else
        list(env)
}

.genericName <- function(f)
{
    if(is(f, "genericFunction"))
        f@generic
    else
        as.character(f)
}

## the environment in which to start searching for methods, etc. related
## to this generic function.  Will normally be the namespace of the generic's
## home package, or else the global environment
.genericEnv <- function(fdef)
    parent.env(environment(fdef))

## the default environment in which to start searching for methods, etc. relative to this
## call to a methods package utility.  In the absence of other information, the current
## strategy is to look at the function _calling_ the methods package utility.
##TODO:  this utility can't really work right until the methods package itself has a
## namespace, so that calls from within the package can be detected.  The
## heuristic is that all callers are skipped as long as their enviornment is  identical
## to .methodsNamespace.  But that is currently initialized to .GlobalEnv.
##
## The logic will fail if a function in a package with a namespace calls a (non-methods)
## function in a package with no namespace, and that function then calls a methods package
## function.  The right answer then is .GlobalEnv, but we will instead get the package
## namespace.
.externalCallerEnv <- function(n = 2, nmax = sys.nframe() - n + 1)
{
    ## start n generations back; by default the caller of the caller to this function
    ## go back nmax at most (e.g., a function in the methods package that knows it's never
    ## called more than nmax levels in could supply this argument
    if(nmax < 1) stop("got a negative maximum number of frames to look at")
    ev <- topenv(parent.frame()) # .GlobalEnv or the environment in which methods is being built.
    for(back in seq.int(from = -n, length.out = nmax)) {
        fun <- sys.function(back)
        if(is.function(fun)) {
            ## Note that "fun" may actually be a method definition, and still will be counted.
            ## This appears to be the correct semantics, in
            ## the sense that, if the call came from a method, it's the method's environment
            ## where one would expect to start the search (for a class definition, e.g.)
            ev <- environment(fun)
            if(!identical(ev, .methodsNamespace))
                break
        }
    }
    ev
}

## a list of environments, starting from ev, going back to the base package,
## or else terminated by finding a namespace
.parentEnvList <- function(ev)
{
    ev <- as.environment(ev)
    value <- list(ev)
    while(!isNamespace(ev)) {
        if(identical(ev, baseenv())) {
            value[[length(value)]] <- .BaseNamespaceEnv
            break
        } else if(identical(ev, emptyenv())) {
            break
        }
        ev <- parent.env(ev)
        value <- c(value, list(ev))
    }
    value
}

.genericAssign <- function(f, fdef, methods, where, deflt)
{
    ev <- environment(fdef)
    assign(".Methods", methods, ev)
}

## Mark the method as derived from a non-generic.
.derivedDefaultMethod <- function(fdef, internal = NULL)
{
    if(is.function(fdef) && !is.primitive(fdef)) {
        if (!is.null(internal)) {
            value <- new("internalDispatchMethod", internal = internal)
        } else {
            value <- new("derivedDefaultMethod")
        }
        value@.Data <- fdef
        value@target <- value@defined <- .newSignature(list(.anyClassName), formalArgs(fdef))
        value
    }
    else
        fdef
}

.identC <- function(c1 = NULL, c2 = NULL)
{
    ## are the two objects identical class or genric function string names?
    .Call(C_R_identC, c1, c2)
}

## match default exprs in the method to those in the generic
## if the method does not itself specify a default, and the
## generic does
matchDefaults <- function(method, generic)
{
    changes <- FALSE
    margs <- formals(method)
    gargs <- formals(generic)
    for(arg in names(margs)) {
        ##!! weird use of missing() here is required by R's definition
        ## of a missing arg as a name object with empty ("") name
        ## This is dangerously kludgy code but seems the only way
        ## to avoid spurious errors ("xxx missing with no default")
        marg <- margs[[arg]]
        garg <- gargs[[arg]]
        if(missing(marg) && !missing(garg)) {
            changes <- TRUE
            margs[arg] <- gargs[arg] # NOT  [[]], which woud fail for NULL element
        }
    }
    if(changes)
        formals(method, envir = environment(method)) <- margs
    method
}

getGroupMembers <- function(group, recursive = FALSE, character = TRUE)
{
    .recMembers <- function(members, where) {
        all = vector("list", length(members))
        for(i in seq_along(members)) {
            what <- members[[i]]
            f <- getGeneric(what, FALSE, where)
            if(!is.null(f))
                all[[i]] <- what
            if(is(f, "groupGenericFunction")) {
                newMem <- f@groupMembers
                all <- c(all, Recall(newMem, where))
            }
        }
        all
    }
    f <- getGeneric(group)
    if(is.null(f)) {
        warning(gettextf("%s is not a generic function (or not visible here)",
                         sQuote(f)),
                domain = NA)
        return(character())
    }
    else if(!is(f, "groupGenericFunction"))
        character()
    else {
        members <- f@groupMembers
        if(recursive) {
            where <- f@package
            if(identical(where, "base")) {
                where <- "methods"      # no generics actually on base
                members <- .recMembers(members, .methodsNamespace)
            }
            else
                members <- .recMembers(members, .requirePackage(where))
        }
        if(character)
            sapply(members, function(x){
                if(is(x, "character"))
                    x
                else if(is(x, "genericFunction"))
                    x@generic
                else
		    stop(gettextf("invalid element in the \"groupMembers\" slot (class %s)",
				  dQuote(class(x))),
                         domain = NA)
            })
        else
            members
    }
}

.primname <- function(object)
{
    ## the primitive name is 'as.double', but S4 methods are
    ## traditionally set on 'as.numeric'
    f <- .Call(C_R_get_primname, object)
    if(f == "as.double") "as.numeric" else f
}

.copyMethodDefaults <- function(generic, method)
{
    emptyDefault <- function(value) missing(value) ||
    (is.name(value) && nzchar(as.character(value)) )
    fg <- formals(generic)
    mg <- formals(method)
    emptyDef <- vapply(mg, emptyDefault, logical(1L))
    mg <- mg[!emptyDef]
    i <- match(names(fg), names(mg))
    formals(generic)[!is.na(i)] <- mg[i[!is.na(i)]]
    generic
}

.NamespaceOrPackage <- function(what)
{
    name <- as.name(what)
    ns <-  .getNamespace(name)
    if(!is.null(ns))
        asNamespace(ns)
    else {
        i <- match(paste0("package:", what), search())
        if(is.na(i))
            .GlobalEnv
        else
            as.environment(i)
    }
}

.NamespaceOrEnvironment <- function(where)
{
    value <- NULL
    if(is.environment(where))
        value <- where
    else if(is.character(where) && nzchar(where)) {
        ns <- .getNamespace(where)
        if(isNamespace(ns))
            value <- ns
        else if(where %in% search())
            value <- as.environment(where)
        else {
            where <- paste0("package:", where)
            if(where %in% search())
                value <- as.environment(where)
        }
    }
    else if(is.numeric(where) && where %in% seq_along(search()))
        value <- as.environment(where)
    value
}

## is this really right?
## cf .methodsPackageMetaNamePattern <- "^[.]__[A-Z]+__"
.hasS4MetaData <- function(env) {
    nms <- names(env)
    any(startsWith(nms, ".__C__")) ||
    any(startsWith(nms, ".__T__")) ||
    any(startsWith(nms, ".__A__"))
}

## turn ordinary generic into one that dispatches on "..."
## currently only called in one place from setGeneric()
.dotsGeneric <- function(f)
{
    if(!is(f, "genericFunction"))
        f <- getGeneric(f)
    if(!is(f, "genericFunction") || !identical(f@signature, "..."))
        stop("argument f must be a generic function with signature \"...\"")
    def <- .standardGenericDots
    body(def) <- eval(call("substitute", body(def),
                           list(.dotsMethod=as.name(f@generic))))
    environment(def) <- environment(f)
    assign("standardGeneric", def, envir = environment(f))
    f
}

utils::globalVariables(c(".MTable", ".AllMTable", ".dotsCall"))

## NB this is used with a modified environment in .dotsGeneric,
## so methods::: calls are necessary.
.standardGenericDots <- function(name)
{
    env <- sys.frame(sys.parent())
    dots <- eval(quote(list(...)), env)
    classes <- unique(unlist(lapply(dots, methods:::.class1)))
    method <- methods:::.selectDotsMethod(classes, .MTable, .AllMTable)
    if(is.null(method))
        stop(gettextf("no method or default matching the \"...\" arguments in %s",
                      deparse(sys.call(sys.parent()), nlines = 1)), domain = NA)
    mc <- match.call(sys.function(sys.parent()), sys.call(sys.parent()),
                     expand.dots=FALSE, envir=parent.frame(2))
    args <- names(mc)[-1L]
    mc[args] <- lapply(args, as.name)
    names(mc)[names(mc) == "..."] <- ""
    mc[[1L]] <- quote(.dotsMethod)
    assign(name, method, env)
    eval(mc, env)
}

.selectDotsMethod <- function(classes, mtable, allmtable)
{
    .pasteC <- function(names) paste0('"', names, '"', collapse = ", ")
    found <- character()
    distances <- numeric()
    methods <- names(mtable)
    direct <- classes %in% methods
    if(all(direct)) {
        if(length(classes) > 1L) {
            warning(gettextf("multiple direct matches: %s; using the first of these", .pasteC(classes)), domain = NA)
            classes <- classes[1L]
        }
        else if(length(classes) == 0L)
            return( if(is.na(match("ANY", methods))) NULL else get("ANY", envir = mtable))
        return(mtable[[classes]])
    }
    if(is.null(allmtable))
        return(NULL)

    ## Else, look for an acceptable inherited method, which must match or be a superclass
    ## of the class of each of the arguments.
    classes <- sort(classes) # make slection depend only on the set of classes
    label <- .sigLabel(classes)
    if(exists(label, envir = allmtable, inherits = FALSE))
        ## pre-cached, but possibly NULL to indicate no match
        return(get(label, envir = allmtable))
    for(i in seq_along(classes)) {
        classi <- classes[[i]]
        defi <- getClassDef(classi)
        if(is.null(defi)) next
        extendsi <- defi@contains
        namesi <- c(classi, names(extendsi))
        if(i == 1)
            namesi <- namesi[namesi %in% methods]
        else { # only the superclass methods matching all arguments are kept
            namesi <- namesi[namesi %in% found]
            found <- namesi
            if(length(found) == 0L) break # no possible non-default match
        }
        for(namei in namesi) {
            disti <- if(identical(namei, classi)) 0 else extendsi[[namei]]@distance
            prev <- match(namei, found)
            if(is.na(prev)) {           # must be the 1st element
                found <- c(found, namei)
                distances <- c(distances, disti)
            }
            else if(disti < distances[[prev]])
                distances[[prev]] <- disti
        }
    }
    if(length(found) == 0L)
        method <-  if(is.na(match("ANY", methods))) NULL else get("ANY", envir = mtable)
    else {
        classes <- found[which.min(distances)]
        if(length(classes) > 1L) {
            warning(gettextf("multiple equivalent inherited matches: %s; using the first of these",
                             .pasteC(classes)), domain = NA)
            classes <- classes[1L]
        }
        method <- get(classes,envir = mtable)
    }
    if(!is.null(method))
        method@target <- new("signature", ... = label) # ?? not a legal class name if > 1 classes
    assign(label, method, allmtable)
    method
}

.isSingleString <- function(what)
  is.character(what) && isTRUE(nzchar(what))

.notSingleString <- function(what)
{
    if(identical(what, ""))
        "non-empty string; got \"\""
    else if(is.character(what))
        paste("single string; got a character vector of length", length(what))
    else
        gettextf("single string; got an object of class %s",
                 dQuote(class(what)[[1L]]))
}

.dotsClass <- function(...) {
    if(missing(..1))
      "missing"
    else
      class(..1)
}

## a utility to exclude various annoying glitches during
## loading of the methods package
.methodsIsLoaded <- function()
    isTRUE(.saveImage)

if(FALSE) {
## Defined but not currently used:
## utilitity to test well-defined classes in signature,
## for setMethod(), setAs() [etc.?], the result to be
## assigned in package where=
## Returns a list of signature, messages and level of error

## Has undefined ns an package
 .validSignature <- function(signature, generic, where) {
    thisPkg <- getPackageName(where, FALSE)
    checkDups <- .duplicateClassesExist()
    if(is(signature, "character")) { # including class "signature"
        classes <- as.character(signature)
        names <- allNames(signature)
        pkgs <- attr(signature, "package")
    }
    else if(is(signature, "list")) {
        classes <- sapply(signature, as.character)
        names <- names(signature)
        pkgs <- character(length(signature))
        for(i in seq_along(pkgs)) {
            pkgi <- attr(signature[[i]], "package")
            pkgs[[i]] <- if(is.null(pkgi)) "" else pkgi
        }
    }
    msgs <- character(); level <- integer()
    for(i in seq_along(classes)) {
        ## classes must be defined
        ## if duplicates exist check for them
        ## An ambiguous duplicate is a warning if it can match thisPkg
        ## else, an error
        classi <- classes[[i]]
        pkgi <- pkgs[[i]]
        classDefi <- getClassDef(classi, where=if (pkgi == "") where else pkgi)
        if(checkDups && classi %in% multipleClasses()) { # hardly ever, we hope
            clDefsi <- get(classi, envir = .classTable)
            if(nzchar(pkgi) && pkgi %in% names(clDefsi))
                ## use the chosen class, no message
                classDefi <- clDefsi[[pkgi]]
            else if(nzchar(pkgi)){
                ## this is only a warning because it just might
                ## be the result of identical class defs (e.g., from setOldClass()
                msgs <- c(msgs,
                          gettextf("multiple definitions exist for class %s, but the supplied package (%s) is not one of them (%s)",
                                   dQuote(classi), sQuote(pkgi),
                                   paste(dQuote(get(classi, envir = .classTable)), collapse = ", ")))
                level <- c(level, 2) #warn
            }
            else {
                msgs <- c(msgs,
                          gettextf("multiple definitions exist for class %s; should specify one of them (%s), e.g. by className()",
                                   dQuote(classi),
                                   paste(dQuote(get(classi, envir = .classTable)), collapse = ", ")))
            }
        }
        else {
            ## just possibly the first reference to an available
            ## package not yet loaded.  It's an error to specify
            ## a non-loadable package
            if(nzchar(pkgi)) {
                loadNamespace(pkgi)
                classDefi <- getClass(classi, where = ns)
            }
            if(is.null(classDefi)) {
                classDefi <- getClassDef
                msgi <- gettextf("no definition found for class %s",
                                 dQuote(classi))
                ## ensure only one error message
                if(length(level) && any(level == 3))
                    msgs[level == 3] <- paste(msgs[level == 3], msgi, sep = "; ")
                else
                    msgs <- c(msgs, msgi)
                level <- c(level, 3)
            }
            ## note that we do not flag a pkgi different from
            ## the package of the def., mainly because of setOldClass()
            ## which currently generates potentially multiple versions
            ## of the same S3 class.
        }
        ## except for the obscure multiple identical class case
        ## we should not get here w/o a valid class def.
        if(is.null(classDefi)) {}
        else
            pkgs[[i]] <- classDefi@package
    }
    signature <- .MakeSignature(new("signature"), generic,
                                structure(classes, names = names, package = package))
    if(length(msgs) > 1) {
        ## sort by severity, to get all messages before errror
        ii <- sort.list(level)
        msgs <- msgs[ii]; level <- level[ii]
    }
    list(signature = signature, message = msgs, level = level)
}
}

.ActionMetaPattern <- function()
    paste0("^[.]",substring(methodsPackageMetaName("A",""),2))

.actionMetaName <- function(name)
    methodsPackageMetaName("A", name)


.doLoadActions <- function(where, attach) {
    ## at the moment, no unload actions
    if(!attach)return()
    actionListName <- .actionMetaName("")
    if(!exists(actionListName, envir = where, inherits = FALSE))
        return(list())
    actions <- get(actionListName, envir = where)
    for(what in actions) {
        aname <- .actionMetaName(what)
        if(!exists(aname, envir = where, inherits = FALSE)) {
            warning(gettextf("missing function for load action: %s", what))
            next
        }
        f <- get(aname, envir = where)
        value <- eval(substitute(tryCatch(FUN(WHERE), error = function(e)e),
                            list(FUN = f, WHERE = where)), where)
        if(is(value, "error")) {
            callString <- deparse(value$call)[[1]]
            stop(gettextf("error in load action %s for package %s: %s: %s",
                          aname, getPackageName(where), callString, value$message))
        }
    }
}

setLoadAction <- function(action,
              aname = "",
              where = topenv(parent.frame())) {
    currentAnames <- .assignActionListNames(where)
    if(!nzchar(aname))
        aname <- paste0(".", length(currentAnames)+1)
    .assignActions(list(action), aname, where)
    if(is.na(match(aname, currentAnames))) {
        actionListName <- .actionMetaName("")
        assign(actionListName, c(currentAnames, aname), envir = where)
    }
}

.assignActions <- function(actions, anames, where) {
    ## check all the actions before assigning any
    for(i in seq_along(actions)) {
        f <- actions[[i]]
        fname <- anames[[i]]
        if(!is.function(f))
            stop(gettextf("non-function action: %s",
                          sQuote(fname)),
                 domain = NA)
        if(length(formals(f)) == 0)
            stop(gettextf("action function %s has no arguments, should have at least 1",
                          sQuote(fname)),
                 domain = NA)
    }
    for(i in seq_along(actions))
        assign(.actionMetaName(anames[[i]]), actions[[i]], envir = where)
}

.assignActionListNames <- function(where) {
    actionListName <- .actionMetaName("")
    if(exists(actionListName, envir = where, inherits = FALSE))
        get(actionListName, envir = where)
    else
        character()
}

setLoadActions <- function(..., .where = topenv(parent.frame())) {
    actionListName <- .actionMetaName("")
    currentAnames <- .assignActionListNames(.where)
    actions <- list(...)
    anames <- allNames(actions)
    ## first, replacements
    previous <- anames %in% currentAnames
    if(any(previous)) {
        .assignActions(actions[previous], anames[previous], .where)
        if(all(previous))
            return(list())
        anames <- anames[!previous]
        actions <- actions[!previous]
    }
    anon <- !nzchar(anames)
    if(any(anon)) {
        n <- length(currentAnames)
        deflts <- paste0(".",seq(from = n+1, length.out = length(actions)))
        anames[anon] <- deflts[anon]
    }
    .assignActions(actions, anames, .where)
    assign(actionListName, c(currentAnames, anames), envir = .where)
}

hasLoadAction <- function(aname, where = topenv(parent.frame()))
    exists(.actionMetaName(aname), envir = where, inherits = FALSE)

getLoadActions <- function(where = topenv(parent.frame())) {
    actionListName <- .actionMetaName("")
    if(!exists(actionListName, envir = where, inherits = FALSE))
        return(list())
    actions <- get(actionListName, envir = where)
    if(length(actions)) {
        allExists <- sapply(actions, function(what) exists(.actionMetaName(what), envir = where, inherits = FALSE))
        if(!all(allExists)) {
            warning(gettextf("some actions are missing: %s",
                             paste(actions[!allExists], collapse =", ")),
                    domain = NA)
            actions <- actions[allExists]
        }
        allFuns <- lapply(actions, function(what) get(.actionMetaName(what), envir = where))
        names(allFuns) <- actions
        allFuns
    }
    else
        list()
}

evalOnLoad <- function(expr, where = topenv(parent.frame()), aname = "") {
    f <- function(env)NULL
    body(f, where) <- substitute(eval(EXPR,ENV), list(EXPR = expr, ENV = where))
    setLoadAction(f, aname, where)
}

evalqOnLoad <- function(expr, where = topenv(parent.frame()), aname = "")
    evalOnLoad(substitute(expr), where, aname)

## a utility function used to flag non-generics at the loadNamespace phase
## The calculation there used to ignore the generic cache, which is wrong logic
## if the package being loaded had a DEPENDS on a package containing the generic
## version of the function.
.findsGeneric <- function(what, ns) {
    if(is(get(what, mode = "function", envir = ns), "genericFunction"))
        1L
    else if(!is.null(.getGenericFromCache(what, ns)))
        2L
    else
        0L
}

## test whether this function  _could be_  an S3 generic, either
## a primitive or a function calling UseMethod()
isS3Generic <- function(fdef) {
    switch(typeof(fdef),
           "special" = FALSE,
           "builtin" = TRUE,
           ## otherwise:
           "UseMethod" %in% .getGlobalFuns(fdef)) # from refClass.R
}