setClass <-
    ## Define Class to be an S-style class.
    function(Class, representation = list(), prototype = NULL,
             contains = character(), validity = NULL, access = list(),
             where = topenv(parent.frame()), version = .newExternalptr(), sealed = FALSE, package = getPackageName(where))
{
    oldDef <- getClassDef(Class, where)
    if(is(oldDef, "classRepresentation") && oldDef@sealed)
        stop(gettextf("\"%s\" has a sealed class definition and cannot be redefined", Class), domain = NA)
    if(is(representation, "classRepresentation")) {
        ## supplied a class definition object
        classDef <- representation
        if(!(missing(prototype) && missing(contains) && missing(validity) && missing(access)
             && missing(version) && missing(package)))
            stop("only arguments 'Class' and 'where' can be supplied when argument 'representation' is a 'classRepresentation' object")
        if(length(classDef@package)==0)
            classDef@package <- package # the default
        superClasses <- allNames(classDef@contains)
    }
    else {
        ## catch the special case of a single class name as the representation
        if(is.character(representation) && length(representation) == 1 &&
           is.null(names(representation)))
            representation <- list(representation)
        slots <- nchar(allNames(representation)) > 0
        superClasses <- c(as.character(representation[!slots]), contains)
        properties <- representation[slots]
        classDef <- makeClassRepresentation(Class, properties,superClasses, prototype, package,
                                             validity, access, version, sealed, where = where)
        superClasses <- names(classDef@contains)
    }
    classDef <- completeClassDefinition(Class, classDef, where, doExtends = FALSE)
    oldDef <- getClassDef(Class, where)
    if(is(oldDef, "classRepresentation"))
      .uncacheClass(Class, oldDef)
    if(length(superClasses) == 0)
        assignClassDef(Class, classDef, where)
    else {
        sealed <- classDef@sealed
        classDef@sealed <- FALSE # to allow setIs to work anyway; will be reset later
        assignClassDef(Class, classDef, where)
        badContains <- character()
        for(class2 in superClasses)
            if(is(try(setIs(Class, class2, classDef = classDef, where = where)), "try-error"))
                badContains <- c(badContains, class2)
        if(length(badContains) > 0) {
            msg <- paste(dQuote(badContains), collapse = ", ")
            if(is(try(removeClass(Class, where)), "try-error"))
                stop(gettextf("error in contained classes (%s) for class \"%s\" and unable to remove definition from \"%s\"",
                              msg, Class, getPackageName(where)), domain = NA)
            if(is.null(oldDef))
                stop(gettextf("error in contained classes (%s) for class \"%s\"; class definition removed from \"%s\"",
                              msg, Class, getPackageName(where)), domain = NA)
            else if(is(try(setClass(Class, oldDef, where=where)), "try-error"))
                stop(gettextf("error in contained classes (%s) for class \"%s\" and unable to restore previous definition from \"%s\"",
                              msg, Class, getPackageName(where)), domain = NA)
            else
                stop(gettextf("error in contained classes (%s) for class \"%s\"; previous definition restored to \"%s\"",
                              msg, Class, getPackageName(where)), domain = NA)
        }
        if(sealed) {
            classDef@sealed <- TRUE
            assignClassDef(Class, classDef, where)
        }
    }
    Class
}

representation <-
  ## Representation of a class; that is,
  ## a list of named slots and unnamed classes to be included in a class
  ## definition.
  function(...)
{
    value <- list(...)
    ## unlike the S-Plus function, this does not form the class representation,
    ## since set SClass works separately with the slots and extends arguments.
    anames <- allNames(value)
    for(i in seq_along(value)) {
        ei <- el(value, i)
        if(!is.character(ei) || length(ei) != 1)
            stop(gettextf("element %d of the representation was not a single character string", i), domain = NA)
    }
    includes <- as.character(value[nchar(anames)==0])
    if(any(duplicated(includes)))
        stop(gettextf("duplicate class names among superclasses: %s",
                      paste(dQuote(includes[duplicated(includes)]),
                            collapse = ", ")),
             domain = NA)
    slots <- anames[nchar(anames)>0]
    if(any(duplicated(slots)))
       stop(gettextf("duplicated slot names: %s",
                     paste(sQuote(slots[duplicated(slots)]), collapse="")),
            domain = NA)
    value
}

### the version called prototype is the external interface.  But functions with argument
### named prototype in R cannot call the prototype function (until there is a methods namespace
### to allow methods::prototype(...)
prototype <- function(...)
    .prototype(...)

.prototype <- function(...) {
    props <- list(...)
    names <- allNames(props)
    data <- nchar(names) == 0
    dataPart <- any(data)
    if(dataPart) {
        if(sum(data) > 1)
            stop("only one data object (unnamed argument to prototype) allowed")
        obj <- unclass(props[[seq_along(data)[data] ]])
        props <- props[!data]
        names <- names[!data]
    }
    else
        obj <- defaultPrototype()
    for(i in seq_along(names))
        slot(obj, names[[i]], FALSE) <- props[[i]]
    new("classPrototypeDef", object = obj, slots = names, dataPart = dataPart)
}

makeClassRepresentation <-
  ## Set the Class Definition.
  ## The formal definition of the class is set according to the arguments.
  ##
  ## Users should call setClass instead of this function.
  function(name, slots = list(), superClasses = character(), prototype = NULL, package, validity = NULL, access = list(), version = .newExternalptr(), sealed = FALSE, virtual = NA, where)
{
    if(!is.null(prototype) || length(slots)>0 || length(superClasses) >0) {
        ## collect information about slots, create prototype if needed
        pp <- reconcilePropertiesAndPrototype(name, slots, prototype, superClasses, where)
        slots <- pp$properties
        prototype <- pp$prototype
    }
    contains <- list();
    if(nchar(package)>0)
        packageSlot(name) <- package
    for(what in superClasses) {
        if(is(what, "classRepresentation"))
            whatClassDef <- what
        else if(is.null(packageSlot(what)))
            whatClassDef <- getClass(what, where = where)
        else
            whatClassDef <- getClass(what)
        what <- whatClassDef@className # includes package name as attribute
        ## Create the SClassExtension objects (will be simple, possibly dataPart).
        ## The slots are supplied explicitly, since `name' is currently an undefined class
        elNamed(contains, what) <- makeExtends(name, what, slots = slots,
                                              classDef2 = whatClassDef, package = package)
    }
    validity <- .makeValidityMethod(name, validity)
    if(is.na(virtual)) {
        virtual <- testVirtual(slots, contains, prototype, where)
        if(virtual && !is.na(match("VIRTUAL", superClasses)))
            elNamed(contains, "VIRTUAL") <- NULL
    }
    newClassRepresentation(className = name, slots = slots,
                           contains = contains,
                           prototype = prototype,
                           virtual = virtual,
                           validity = validity,
                           access = access,
                           package = package,
                           versionKey = version,
                           sealed = sealed)
}

getClassDef <-
  ## Get the definition of the class supplied as a string.
  function(Class, where = topenv(parent.frame()), package = packageSlot(Class))
{
    ## FIXME:  really wants to be is(Class, "classRepresentation") but
    ## generates inf. loop in booting methods package (also for new())
    if(.identC(class(Class), "classRepresentation"))
        return(Class)
    value <- .getClassFromCache(Class, where)
    if(is.null(value)) {
    if(length(Class)>1)
        ## S3 class; almost certainly has no packageSLot, but we'll continue anyway
        cname <- classMetaName(Class[[1]])
    else
        cname <- classMetaName(Class)
    value <- NULL
    ## a string with a package slot strongly implies the class definition
    ## should be in that package.
    if(!is.null(package)) {
        whereP <- .requirePackage(package)
        if(exists(cname, whereP))
            value <- get(cname, whereP)
    }
    if(is.null(value) && exists(cname, where))
        value <- get(cname, where)
    }
    value
}

getClass <-
  ## Get the complete definition of the class supplied as a string,
  ## including all slots, etc. in classes that this class extends.
  function(Class, .Force = FALSE,
	   where = .classEnv(Class, topenv(parent.frame()), FALSE))
{
    value <- getClassDef(Class, where)
    if(is.null(value)) {
	if(!.Force)
	    stop(gettextf("\"%s\" is not a defined class", Class), domain = NA)
	else
	    value <- makeClassRepresentation(Class, package = "base",
					     virtual = TRUE, where = where)
    }
    value
}

slot <-
  ## Get the value of the named slot.  This function does exact, not partial, matching of names,
  ## and the name must be one of the slot names specified in the class's definition.
  ##
  ## Because slots are stored as attributes, the validity check is not 100% guaranteed,
  ## but should be OK if nobody has "cheated" (e.g., by setting other attributes directly).
  function(object, name)
    .Call("R_get_slot", object, name, PACKAGE = "methods")

"slot<-" <-
  ## Set the value of the named slot.  Must be one of the slots in the class's definition.
  function(object, name, check = TRUE, value) {
      if(check)
          value <- checkSlotAssignment(object, name, value)
      .Call("R_set_slot", object, name, value, PACKAGE="methods")
  }

checkSlotAssignment <- function(obj, name, value)
{
    cl <- class(obj)
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
    slotClass <- elNamed(ClassDef@slots, name)
    if(is.null(slotClass))
        stop(gettextf("\"%s\" is not a slot in class \"%s\"", name, class(obj)),
             domain = NA)
    valueClass <- class(value)
    if(.identC(slotClass, valueClass))
       return(value)
    ## check the value, but be careful to use the definition of the slot's class from
    ## the class environment of obj (change validObject too if a better way is found)
    ok <- possibleExtends(valueClass, slotClass, ClassDef2 = getClassDef(slotClass, where = .classEnv(ClassDef)))
    if(identical(ok, FALSE))
       stop(gettextf("assignment of an object of class \"%s\" is not valid for slot \"%s\" in an object of class \"%s\"; is(value, \"%s\") is not TRUE",
                     class(value),  name, class(obj), slotClass),
            domain = NA)
    else if(identical(ok, TRUE))
        value
    else
       as(value, slotClass, strict=FALSE, ext = ok)
}



## "@" <-
##   function(object, name)
##   .Internal(object@name)

"@<-" <-
   function(object, name, value) {
     arg <- substitute(name)
     if(is.name(arg))
       name <- as.character(arg)
     "slot<-"(object, name, TRUE, value)
   }

##  The names of the class's slots.  The argument is either the name
##  of a class, or an object from the relevant class.

## NOTA BENE:  .slotNames() shouldn't be needed,
##             rather slotNames() should be changed (to work like .slotNames())!
slotNames <- function(x)
    if(is(x, "classRepresentation")) names(x@slots) else .slotNames(x)

.slotNames <- function(x)
{
    classDef <-
	getClassDef(if(is.character(x) && length(x) == 1) x else class(x))
    if(is.null(classDef))
	character()
    else
	names(classDef@slots)
}


removeClass <-  function(Class, where = topenv(parent.frame())) {
    if(missing(where)) {
       classEnv <- .classEnv(Class, where, FALSE)
        classWhere <- findClass(Class, where = classEnv)
        if(length(classWhere) == 0) {
            warning(gettextf("Class definition for \"%s\" not found  (no action taken)", Class),
                    domain = NA)
            return(FALSE)
        }
        if(length(classWhere) > 1)
            warning(gettextf("class \"%s\" has multiple definitions visible; only the first removed", Class), domain = NA)
        classWhere <- classWhere[[1]]
    }
    else classWhere <- where
    classDef <- getClassDef(Class, where=classWhere)
    if(length(classDef@subclasses)>0) {
      subclasses <- names(classDef@subclasses)
      found <- sapply(subclasses, isClass, where = where)
      if(any(found))
        warning("The class to be removed  (\"", Class,
    "\") has defined subclasses that should also be removed: (",
                paste(as.character(subclasses[found]), collapse = ", "), ")")
    }
    .uncacheClass(Class, classDef)
    .undefineMethod("initialize", Class, classWhere)
    what <- classMetaName(Class)
    rm(list=what, pos=classWhere)
    TRUE
}


isClass <-
  ## Is this a formally defined class?
  function(Class, formal=TRUE, where = topenv(parent.frame()))
{
    ## argument formal is for Splus compatibility & is ignored.  (All classes that
    ## are defined must have a class definition object.)
    if(missing(where))
        !is.null(getClassDef(Class))
    else
        !is.null(getClassDef(Class, where))
}

new <-
  ## Generate an object from the specified class.
  ##
  ## If other arguments are included, these are the values for named slots
  ## in the object, or an object that can be coerced into this class.
  ## Note that the basic vector classes, `"numeric"', etc. are implicitly defined,
  ## so one can use `new' for these classes.
  ###
  ### Unnamed arguments are objects from this class or a superclass.
  ##
  function(Class, ...)
{
    ## get the class definition, completing it if this is the first reference
    ## to this class in this session.
    ## FIXME:  really wants to be is(Class, "classRepresentation") but
    ## generates inf. loop in booting methods package (also for getClassDef)
    if(.identC(class(Class), "classRepresentation"))
        ClassDef <- Class
    else
        ClassDef <- getClass(Class, where = topenv(parent.frame()))
    value <- .Call("R_do_new_object", ClassDef, PACKAGE = "base")
    initialize(value, ...)
}

getClasses <-
  ## The names of all the classes formally defined on `where'.
  ## If called with no argument, all the classes currently known in the session
  ## (which does not include classes that may be defined on one of the attached
  ## libraries, but have not yet been used in the session).
  function(where = .externalCallerEnv(), inherits = missing(where))
{
    pat <- paste("^",classMetaName(""), sep="")
    if(inherits) {
        evList <- .parentEnvList(where)
        clNames <- character()
        for(ev in evList)
            clNames <- c(clNames, objects(ev, pattern = pat, all.names = TRUE))
        clNames <- unique(clNames)
    }
    else
        clNames <- objects(where, pattern = pat, all.names = TRUE)
    ## strip off the leading pattern (this implicitly assumes the characters
    ## in classMetaName("") are either "." or not metacharacters
    substring(clNames, nchar(pat))
}


validObject <- function(object, test = FALSE, complete = FALSE)
{
    Class <- class(object)
    classDef <- getClassDef(Class)
    where <- .classEnv(classDef)
    anyStrings <- function(x) if(identical(x, TRUE)) character() else x
    ## perform, from bottom up, the default and any explicit validity tests
    ## First, validate the slots.
    errors <- character()
    slotTypes <- classDef@slots
    slotNames <- names(slotTypes)
    for(i in seq_along(slotTypes)) {
        classi <- slotTypes[[i]]
        sloti <- slot(object, slotNames[[i]])
        classDefi <- getClassDef(classi, where = where)
        if(is.null(classDefi)) {
          errors <- c(errors, paste("class for slot \"", slotNames[[i]],
                                    "\" (\"", classi, "\")", sep=""))
          next
        }
        ## note that the use of possibleExtends is shared with checkSlotAssignment(), in case a
        ## future revision improves on it!
        ok <- possibleExtends(class(sloti), classi, ClassDef2 = classDefi)
        if(identical(ok, FALSE)) {
            errors <- c(errors,
                        paste("invalid object for slot \"", slotNames[[i]],
                              "\" in class \"", Class,
                              "\": got class \"", class(sloti),
                              "\", should be or extend class \"", classi, "\"", sep = ""))
            next
        }
        if(!complete)
          next
        validityMethod <- classDefi@validity
        if(is(validityMethod, "function")) {
            errori <- anyStrings(validityMethod(sloti))
            if(length(errori)>0) {
                errori <- paste("In slot \"", slotNames[[i]],
                                "\" of class \"", class(sloti), "\": ",
                                sep = "", errori)
                errors <- c(errors, errori)
            }
        }
    }
    extends <- rev(classDef@contains); i <- 1
    while(length(errors) == 0 && i <= length(extends)) {
        exti <- extends[[i]]
        superClass <- exti@superClass
        i <- i+1
        if(!exti@simple && !is(object, superClass))
            next ## skip conditional relations that don't hold for this object
        superDef <- getClassDef(superClass, where = where)
        if(is.null(superDef)) {
            errors <- c(errors, paste("superclass \"", superClass, "\" not defined in the environment of the object's class", sep=""))
            next
        }
        validityMethod <- superDef@validity
        if(is(validityMethod, "function"))
            errors <- c(errors, anyStrings(validityMethod(as(object, superClass))))
    }
    validityMethod <- classDef@validity
    if(length(errors) == 0 && is(validityMethod, "function")) {
        errors <- c(errors, anyStrings(validityMethod(object)))
    }
    if(length(errors) > 0) {
        if(test)
            errors
        else {
            msg <- gettextf("invalid class \"%s\" object:", Class)
            if(length(errors) > 1)
                stop(paste(msg,
                           paste(paste(1:length(errors), errors, sep=": ")),
                           collapse = "\n"), domain = NA)
            else stop(msg, " ", errors, domain = NA)
    }
}
  else
    TRUE
}

setValidity <-
  function(Class, method, where = topenv(parent.frame())) {
    if(isClassDef(Class)) {
        ClassDef <- Class
        Class <- ClassDef@className
    }
    else {
      ClassDef <- getClassDef(Class, where)
  }
    method <- .makeValidityMethod(Class, method)
    if(is.null(method) ||
      (is(method, "function") && length(formalArgs(method))==1))
      ClassDef@validity <- method
    else
      stop("validity method must be NULL or a function of one argument")
    ## TO DO:  check the where argument against the package of the class def.
    assignClassDef(Class, ClassDef, where = where)
    resetClass(Class, ClassDef, where = where)
  }

resetClass <- function(Class, classDef, where) {
        if(is(Class, "classRepresentation")) {
            classDef <- Class
            Class <- Class@className
            if(missing(where))
                where <- .classDefEnv(classDef)
        }
        else {
            if(missing(where)) {
                if(missing(classDef))
                    where <- findClass(Class, unique = "resetting the definition")[[1]]
                else
                    where <- .classDefEnv(classDef)
            }
            if(missing(classDef)) {
                classDef <- getClassDef(Class, where)
                if(is.null(classDef)) {
                    warning(gettextf("class \"%s\" not found on \"%s\"; 'resetClass' will have no effect", Class, getPackageName(where)), domain = NA)
                    return(classDef)
                }
            }
            else if(!is(classDef, "classRepresentation"))
                stop(gettextf("argument 'classDef' must be a string or a class representation; got an object of class \"%s\"", class(classDef)), domain = NA)
            package <- getPackageName(where)
        }
        if(classDef@sealed)
            warning(gettextf("class \"%s\" is sealed; 'resetClass' will have no effect", Class), domain = NA)
        else {
            classDef <-  .uncompleteClassDefinition(classDef)
            classDef <- completeClassDefinition(Class, classDef, where)
            assignClassDef(Class, classDef, where)
        }
        classDef
    }

## the (default) initialization:  becomes the default method when the function
## is made a generic by .InitMethodDefinitions

initialize <- function(.Object, ...) {
    args <- list(...)
    if(length(args) > 0) {
        Class <- class(.Object)
        ## the basic classes have fixed definitions
        if(!is.na(match(Class, .BasicClasses)))
            return(newBasic(Class, ...))
        ClassDef <- getClass(Class)
        ## separate the slots, superclass objects
        snames <- allNames(args)
        which <- nchar(snames)>0
        elements <- args[which]
        supers <- args[!which]
        thisExtends <- names(ClassDef@contains)
        slotDefs <- ClassDef@slots
        dataPart <- elNamed(slotDefs, ".Data")
        if(is.null(dataPart)) dataPart <- "missing"
        if(length(supers) > 0) {
            for(i in rev(seq_along(supers))) {
                obj <- el(supers, i)
                Classi <- class(obj)
                ## test some cases that let information be copied into the
                ## object, ordered from more to less:  all the slots in the
                ## first two cases, some in the 3rd, just the data part in 4th
                if(.identC(Classi[[1]], Class))
                    .Object <- obj
                else if(extends(Classi, Class))
                    .Object <- as(obj, Class, strict=FALSE)
                else if(extends(Class, Classi))
                    as(.Object, Classi) <- obj
                else if(extends(Classi, dataPart))
                    .Object@.Data <- obj
                else {
                    ## is there a class to which we can coerce obj
                    ## that is then among the superclasses of Class?
                    extendsi <- extends(Classi)[-1]
                    ## look for the common extensions, choose the first
                    ## one in the extensions of Class
                    which <- match(thisExtends, extendsi)
                    which <- seq_along(which)[!is.na(which)]
                    if(length(which) >0 ) {
                        Classi <- thisExtends[which[1]]
                        as(.Object, Classi) <- as(obj, Classi, strict = FALSE)
                    }
                    else
                        stop(gettextf("cannot use object of class \"%s\" in new():  class \"%s\" does not extend that class", Classi, Class), domain = NA)
                }
            }
        }
        if(length(elements)>0) {
            snames <- names(elements)
            if(any(duplicated(snames)))
                stop(gettextf("duplicated slot names: %s",
                              paste(sQuote(snames[duplicated(snames)]),
                                    collapse = ", ")), domain = NA)
            which  <- match(snames, names(slotDefs))
            if(any(is.na(which)))
                stop(gettextf("invalid names for slots of class \"%s\": %s",
                              Class,
                              paste(snames[is.na(which)], collapse=", ")),
                     domain = NA)
            for(i in seq_along(snames)) {
                slotName <- el(snames, i)
                slotClass <- elNamed(slotDefs, slotName)
                slotClassDef <- getClassDef(slotClass, package=ClassDef@package)
                slotVal <- el(elements, i)
                ## perform non-strict coercion, but leave the error messages for
                ## values not conforming to the slot definitions to validObject(),
                ## hence the check = FALSE argument in the slot assignment
                if(!.identC(class(slotVal), slotClass)
                   && !is.null(slotClassDef) ) {
                    valClass <- class(slotVal)
                    valClassDef <- getClassDef(valClass, package = ClassDef@package)
                    if(!identical(possibleExtends(valClass, slotClass,
                                         valClassDef, slotClassDef), FALSE))
                        slotVal <- as(slotVal, slotClass, strict = FALSE)
                }
                slot(.Object, slotName, check = FALSE) <- slotVal
            }
        }
        validObject(.Object)
     }
    .Object
}

findClass <- function(Class, where = topenv(parent.frame()), unique = "") {
    if(is(Class, "classRepresentation")) {
        pkg <- Class@package
        Class <- Class@className
    }
    else
        pkg <- ""
    if(missing(where) && nchar(pkg))
            where <- .requirePackage(pkg)
    else
        where <- as.environment(where)
    what <- classMetaName(Class)
    where <- .findAll(what, where)
    if(length(where) != 1 && nchar(unique)>0) {
            if(length(where) == 0)
                stop(gettextf("no definition of \"%s\" to use for %s",
                              Class, unique), domain = NA)
            if(length(where) > 1) {
                where <- where[1]
                ## problem: 'unique'x is text passed in, so do not translate
                warning(sprintf("multiple definitions of class \"%s\" visible; using the definition on package \"%s\" for %s",
                                 Class, getPackageName(where[[1]]), unique),
                        domain = NA)
            }
    }
    where
}

isSealedClass <- function(Class, where = topenv(parent.frame())) {
    if(is.character(Class))
            Class <- getClass(Class, TRUE, where)
    if(!is(Class, "classRepresentation"))
        FALSE
    else
        Class@sealed
}

sealClass <- function(Class, where = topenv(parent.frame())) {
    if(missing(where))
        where <- findClass(Class, unique = "sealing the class", where = where)
    classDef <- getClassDef(Class, where)
    if(!classDef@sealed) {
        classDef@sealed <- TRUE
        assignClassDef(Class, classDef, where)
    }
    invisible(classDef)
}

