#  File src/library/methods/R/RMethodUtils.R
#  Part of the R package, http://www.R-project.org
#
#  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
#  http://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, 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\"",
                          f),
                 domain = NA)
          else if(is.primitive(fdefault)) {
              return(genericForPrimitive(f))
          }
          fdef <- fdefault
          body(fdef) <- substitute(standardGeneric(NAME), list(NAME = f))
          environment(fdef) <- .methodsNamespace
      }
      ## 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 'genericFunction' argument must be NULL or a generic function object; got an object of class \"%s\"", 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(gettextf("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))
          methods <- MethodsList(name)
      else {
          fdefault <- checkTrace(fdefault)
          if(!identical(formalArgs(fdefault), formalArgs(fdef)) &&
             !is.primitive(fdefault))
              stop(gettextf("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
          methods <- MethodsList(name, fdefault)
      }
      value@default <- methods
      assign(".Methods", methods, envir = ev)
      .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)
.asS4 <- function (object)
{
    .Call("R_setS4Object", object, TRUE, 0L, PACKAGE = "base")
}

.notS4 <- function (object)
{
    .Call("R_setS4Object", object, FALSE, 0L, PACKAGE = "base")
}


## 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(gettextf("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))
          methods <- MethodsList(name)
      else
          methods <- MethodsList(name, asMethodDefinition(fdefault, fdef = value))
###--------
      assign(".Methods", methods, envir = ev)
      slot(value, "default", FALSE) <- methods
      slot(value, "skeleton", FALSE) <- generic.skeleton(f, fdef, fdefault)
###--------
      value
  }


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's 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 <- genericForPrimitive(f)
      if(identical(fgen, FALSE))
        stop(gettextf("special function \"%s\" is not permitted to have methods",
                      f), domain = NA)
      if(is.null(fgen)) {
        warning(gettextf("special function \"%s\" has no known argument list; will assume '(x, ...)'", f), domain = NA)
        ## unknown
        fgen <- function(x, ...) {}
      }
      else {
          message(gettextf("making a generic for special function \"%s\"", 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
      body(fdefault) <- substitute(stop(MESSAGE, domain = NA), list(MESSAGE=
          gettextf("invalid call in method dispatch to \"%s\" (no default method)", name)))
      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()) {
        if(length(genericLabel) && is(m2, "MethodsList"))
            m2 <- .GenericInPrimitiveMethods(m2, genericLabel)
        if(is.null(m1) || is(m1, "EmptyMethodsList"))
            return(m2)
        tmp <- listFromMlist(m2)
        sigs <- el(tmp, 1)
        methods <- el(tmp, 2)
        for(i in seq_along(sigs)) {
            sigi <- el(sigs, i)
            args <- names(sigi)
            m1 <- insertMethod(m1, as.character(sigi), args, el(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(exists(name, envir=ev, inherits=FALSE)) {
        prev <- get(name, envir=ev)
        on.exit(assign(name, prev, envir = ev))
    }
    else
        on.exit(rm(list=name, envir=ev))
    assign(name, def, envir = ev)
    eval(call, ev)
}

conformMethod <- function(signature, mnames, fnames,
			  f = "<unspecified>", fdef, method)
{
    fsig <- fdef@signature
    if(is.na(match("...", mnames)) && !is.na(match("...", fnames)))
        fnames <- fnames[-match("...", fnames)]
    label <- paste("In method for function \"", f,"\": ", sep="")
    omitted <- is.na(imf <- match(fnames, mnames))
    if(is.unsorted(imf[!omitted]))
	## Should be an error, but the test was not triggering for such a long time :
	warning(label,
	     "formal arguments in method and function do not appear in the same order")
    if(!any(omitted)) ## i.e. mnames contains all fnames
        return(signature)

    signature <- c(signature, rep("ANY", length(fsig)-length(signature)))
    ### 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(is.na(match(signature[omitted], c("ANY", "missing"))))) {
        bad <- omitted & is.na(match(signature[omitted], c("ANY", "missing")))
        stop(label, gettextf("formal arguments omitted in the method definition cannot be in the signature (%s)",
                             paste(fnames[bad], " = \"", signature[bad], "\"",
                                   sep = "", collapse = ", ")), domain = NA)
    }
    else if(!all(signature[omitted] == "missing")) {
        .message(label, gettextf("expanding the signature to include omitted arguments in definition: %s",
                                 paste(fnames[omitted], "= \"missing\"",collapse = ", ")))
        omitted <- seq_along(omitted)[omitted] # logical index will extend signature!
        signature[omitted] <- "missing"
    }
    ## remove trailing "ANY"'s
    n <- length(signature)
    while(.identC(signature[[n]], "ANY"))
        n <- n - 1
    length(signature) <- n
    length(fsig) <- n
    names(signature) <- fsig
    signature
}

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("methods can add arguments to the generic only if '...' is an argument to the generic")
    ## 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)]))
	warning("Arguments of method and generic are not in the same order")

    ## 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("arguments after '...' in the generic (%s) must appear in the method, in the same place at the end of the argument list",
			  paste(trailingArgs, collapse=", ")), 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
}

unRematchDefinition <- function(definition) {
    ## undo the effects of rematchDefiniition, 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]]
        if(.identC(class(bdy), "<-") &&
           identical(bdy[[2L]], as.name(".local")))
            definition <- bdy[[3L]]
    }
    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(genericForPrimitive(.primname(f)))
        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) && exists(f, envir = baseenv(), inherits = FALSE)) {
        ## check for primitives
        baseDef <- get(f, envir = baseenv())
        if(is.primitive(baseDef)) {
            value <- genericForPrimitive(f)
            if(!is.function(value) && mustFind)
                stop(gettextf("methods cannot be defined for the primitive function \"%s\"",
                              f), domain = NA)
            if(is(value, "genericFunction"))
                value <- .cacheGeneric(f, value)
        }
    }
    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\"", 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=
    if(missing(where))
        value <- .getGenericFromCache(f, where,  package)
    else
        value <- NULL
    if(is.null(value)) {
        if(is.character(f) && f %in% c("as.double", "as.real")) f <- "as.numeric"
        if(is.character(f) && !nzchar(f)) {
            message("Empty function name in .getGeneric")
            dput(sys.calls())
        }
        value <- .Call("R_getGeneric", f, FALSE, as.environment(where), package,
                       PACKAGE = "methods")
        ## cache public generics (usually these will have been cached already
        ## and we get to this code for non-exported generics)
        if(!is.null(value) && exists(f, .GlobalEnv) &&
           identical(get(f, .GlobalEnv), 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(exists(name, envir = table, inherits = FALSE)) {
        newpkg <- def@package
        prev <- get(name, envir = table)
        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
                assign(name, def, envir = table)
                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
    assign(name, def, envir = table)
    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 <- paste("package:", pkg, sep="")
	    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 <- genericForPrimitive(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)
    environment(value) <- newEv <- new.env(TRUE, parent.env(ev))
    for(what in objects(ev, all.names=TRUE)) {
        obj <- get(what, envir = ev)
        if(is.environment(obj))
          obj <- .copyEnv(obj)
        assign(what, obj, envir = newEv)
    }
    value
}

.copyEnv <- function(env) {
    value <- new.env(TRUE, parent.env(env))
    for(what in objects(env, all.names = TRUE))
      assign(what, get(what, envir = env), envir = value)
    value
}

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())) {
## Deprecate for 2.8.0? {currently would give 22 warnings when loading methods:} _FIXME_
##     .methodsDeprecated("getMethodsMetaData",
##                        "Methods list objects are no longer used and will not be generated in future versions; see findMethods() for alternatives")
    fdef <- getGeneric(f, where = where)
    if(is.null(fdef))
      return(NULL)
    mname <- methodsPackageMetaName("M",fdef@generic, fdef@package)
    if (exists(mname, where = where, inherits = missing(where)))
        get(mname, 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.  This function will
  ## either disappear or deal only with primitives & groups in l
  function(f, value, fdef, where, deflt = finalDefaultMethod(value)) {
      where <- as.environment(where)
      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(is.primitive(deflt))
        setPrimitiveMethods(f, deflt, "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
        fnames <- as.list(objects(.genericTable, all.names=TRUE))
        packages <- vector("list", length(fnames))
        for(i in seq_along(fnames)) {
            obj <- get(fnames[[i]], envir = .genericTable)
            if(is.list(obj))
                fnames[[i]] <-  names(obj)
            packages[[i]] <- .packageForGeneric(obj)
        }
        new("ObjectsWithPackage", unlist(fnames), package=unlist(packages))
    }
    else {
        if(is.environment(where)) where <- list(where)
        these <- character()
        for(i in where)
            these <- c(these, objects(i, all.names=TRUE))
        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 <- character()
    for(i in where) these <- c(these, objects(i, all.names=TRUE))
    these <- allThese <- unique(these)
    these <- these[substr(these, 1L, 6L) == ".__T__"]
    if(length(these) == 0L)
      return(character())
    funNames <- gsub(".__T__(.*):([^:]+)", "\\1", these)
    if(length(funNames) == 0L &&
       length(these[substr(these, 1L, 6L) == ".__M__"]))
      warning(gettextf(
      "Package \"%s\" seems to have out-of-date methods; need to reinstall from source",
                       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(identical(trim, TRUE))
      funNames
    else {
      if(identical(trim, FALSE))
        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.
    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]
    pkg <- getPackageName(where)
    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)
    }
    classes <- getClasses(where)
    for(cl in classes) {
        cldef <- (if(attach) get(classMetaName(cl), where) # NOT getClassDef, it will use cache
                  else  getClassDef(cl, searchWhere))
        if(is(cldef, "classRepresentation")) {
            if(attach) {
              .cacheClass(cl, cldef, is(cldef, "ClassUnionRepresentation"), where)
             }
            else if(identical(cldef@package, pkg)) {
              .uncacheClass(cl, cldef)
              .removeSuperclassBackRefs(cl, cldef, searchWhere)
          }
        }
    }
    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",
			 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(is.primitive(deflt)) {
	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("R_M_setPrimitiveMethods", f, fdef, code, generic, mlist, PACKAGE="methods")



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")) {
            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("R_missingArg", if(eval) symbol else substitute(symbol), envir, PACKAGE = "methods")

balanceMethodsList <- function(mlist, args, check = TRUE) {
    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)
        mm <- unlist(allSlots)
        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", fname, class(object), paste("\"", classes, "\"", sep = "", 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]]
        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(def, "function"))
        paste(name, "(", paste(args, collapse=", "), ")", sep="")
    else
        ""
}

.ValidateValueClass <- function(fdef, name, valueClass)
{
    ## include tests for value
    fbody <- body(fdef)
    body(fdef, envir = environment(fdef)) <-
        substitute(.valueClassTest(EXPR, 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] <- paste("package", pkg[-global], sep="")
            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\")!",
                                 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))
            warning("the supplied generic function definition for ", fname, " does not seem to call 'standardGeneric'; no methods will be dispatched!")
        TRUE
    }
}

.GenericInPrimitiveMethods <- function(mlist, f) {
    methods <- mlist@methods
    for(i in seq_along(methods)) {
        mi <- methods[[i]]
        if(is(mi, "function")) {
            body(mi, envir = environment(mi)) <-
                substitute({.Generic <- FF; BODY},
                  list(FF = f,BODY = body(mi)))
        }
        else if(is(mi, "MethodsList"))
            mi <- Recall(mi, f)
        else
            stop(gettextf("internal error: Bad methods list object in fixing methods for primitive function \"%s\"", 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(paste(snames, "=\"", signature, "\"", sep=""), collapse = ", ")
}

.ChangeFormals <- function(def, defForArgs, msg = "<unidentified context>") {
    if(!is(def, "function"))
        stop(gettextf("trying to change the formal arguments in %s, in an object of class \"%s\"; expected a function definition", msg, class(def)),
             domain = NA)
    if(!is(defForArgs, "function"))
        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, 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, paste("\"", old, "\"", sep ="", collapse=", "),
                      paste("\"", new, "\"", sep ="", 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, paste("\"", old, "\"", sep ="", collapse=", "),
                         paste("\"", new, "\"", sep ="", 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(any(is.na(whereNames)))
        stop(gettextf("in changing formal arguments in %s, some of the old names are not in fact arguments: %s", msg, paste("\"", old[is.na(match(old, names(dlist)))], "\"", sep ="", 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")
            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 pacakge 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(fun, "function")) {
            ## 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 defintion, 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.
## FIXME:  This can't work for primitives, which cannot have slots
## However, primitives are not to be restored locally in any case.
.derivedDefaultMethod <- function(fdef) {
    if(is.function(fdef) && !is.primitive(fdef)) {
        value <- new("derivedDefaultMethod")
        value@.Data <- fdef
        value
    }
    else
        fdef
}

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

## a version of match that avoids the is.factor() junk: faster & safe for bootstrapping
.matchBasic <- function(x, table, nomatch = NA) .Internal(match(x, table, nomatch))

## 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)",
                         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, .asEnvironmentPackage(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\")",
				  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("R_get_primname", object, PACKAGE = "base")
    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)
    mgn <- names(mg)
    changed <- FALSE
    for(what in names(fg)) {
        i <- match(what, mgn, 0L)
        if(i > 0L) {
            deflt <- mg[[i]]
            if(!(emptyDefault(deflt) || identical(deflt, fg[[what]]))) {
                fg[[what]] <- deflt
                changed <- TRUE
            }
        }
    }
    if(changed)
      formals(generic) <- fg
    generic
}


.setDeprecatedAction <- function(f, what) {
    switch(what,
           warn = , stop = , once = , ignore =  .deprecatedActions[[f]] <<- what,
           warning('"', what, '" is not a known action (warn, stop, once, ignore); no action recorded for function "', f, '"')
           )
}

.deprecatedActions <- list(mlistMetaName = "once")
.deprecatedVisited <- character()

.methodsDeprecated <- function(f, msg) {
    message <- paste("function \"", f, "\" is deprecated: ",msg, sep = "")
    i <- match(f, names(.deprecatedActions))
    if(is.na(i))
      action <- "warn"
    else
      action <- .deprecatedActions[[i]]
    switch(action,
           warn =  {.Deprecated(msg = message)},
           stop = stop(message),
           once = {
               if(is.na(match(f, .deprecatedVisited))) {
                 message <- paste(message, " (this message will appear only once)")
                 .Deprecated(msg = message)
                 .assignOverBinding(".deprecatedVisited",  c(.deprecatedVisited, f), .methodsNamespace, FALSE)
             }
           },
           ignore =
           )
}

.NamespaceOrPackage <- function(what) {
    name <- as.name(what)
    ns <-  .Internal(getRegisteredNamespace(name))
    if(!is.null(ns))
      asNamespace(ns)
    else {
        i <- match(paste("package", what, sep=":"), 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 <- .Internal(getRegisteredNamespace(where))
        if(isNamespace(ns))
          value <- ns
        else if(where %in% search())
          value <- as.environment(where)
        else {
            where <- paste("package:", where, sep="")
            if(where %in% search())
              value <- as.environment(where)
        }
    }
    else if(is.numeric(where) && where %in% seq_along(search()))
      value <- as.environment(where)
    value
}


.hasS4MetaData <- function(env)
  (length(objects(env, all.names = TRUE,
                          pattern = "^[.]__[CT]_")))

## turn ordinary generic into one that dispatches on "..."
.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
    fenv <- environment(f)
    environment(def) <- fenv
    assign("standardGeneric", def, envir = fenv)
    assign(".dotsCall", .makeDotsCall(formalArgs(f)), envir = fenv)
   f
}


.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)
    assign(".Method", method, envir = env)
    eval(.dotsCall, env)
}


.quoteCall <- quote(.Method(...))
.makeDotsCall <- function(formals) {
    call <- methods:::.quoteCall
    if(length(formals)  > 1L) {
        idots <- match("...", formals)
        for(what in formals[-idots]) {
            ## the following nonsense is required to get the names in the call
            ## expression to be empty for ... and there for other args
            eval(substitute(call$NAME <- as.name(WHAT),
                            list(NAME = as.name(what), WHAT = what)))
        }
    }
    call
}

.selectDotsMethod <- function(classes, mtable, allmtable) {
    .pasteC <- function(names) paste('"', names, '"', sep="", collapse = ", ")
    found <- character()
    distances <- numeric()
    methods <- objects(mtable, all=TRUE)
    direct <- match(classes, methods, 0L) > 0L
    if(all(direct)) {
        if(length(classes) > 1L) {
            warning("multiple direct matches: ", .pasteC(classes), "; using the first of these")
            classes <- classes[1L]
        }
        else if(length(classes) == 0L)
          return( if(is.na(match("ANY", methods))) NULL else get("ANY", envir = mtable))
        return(get(classes,envir = mtable))
    }
    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[match(namesi, methods, 0L) > 0L]
        else { # only the superclass methods matching all arguments are kept
            namesi <- namesi[match(namesi, found, 0L) > 0L]
            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("multiple equivalent inherited matches: ", .pasteC(classes), "; using the first of these")
            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) && identical(nzchar(what), TRUE)

.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\"", class(what)[[1]])
}
