View | Details | Raw Unified | Return to bug 16490 | Differences between
and this patch

Collapse All | Expand All

(-)src/library/base/R/attach.R (-3 / +3 lines)
Lines 52-58 Link Here
52
                break
52
                break
53
            }
53
            }
54
        }
54
        }
55
        ob <- objects(db.pos, all.names = TRUE)
55
        ob <- names(db.pos)
56
        if(.isMethodsDispatchOn()) { ## {see note in library() about this}
56
        if(.isMethodsDispatchOn()) { ## {see note in library() about this}
57
            these <- ob[substr(ob, 1L, 6L) == ".__T__"]
57
            these <- ob[substr(ob, 1L, 6L) == ".__T__"]
58
            gen  <- gsub(".__T__(.*):([^:]+)", "\\1", these)
58
            gen  <- gsub(".__T__(.*):([^:]+)", "\\1", these)
Lines 62-69 Link Here
62
        }
62
        }
63
        ipos <- seq_along(sp)[-c(db.pos, match(c("Autoloads", "CheckExEnv"), sp, 0L))]
63
        ipos <- seq_along(sp)[-c(db.pos, match(c("Autoloads", "CheckExEnv"), sp, 0L))]
64
        for (i in ipos) {
64
        for (i in ipos) {
65
            obj.same <- match(objects(i, all.names = TRUE), ob, nomatch = 0L)
65
            obj.same <- match(names(i), ob, nomatch = 0L)
66
            if (any(obj.same > 0L)) {
66
            if (sum(obj.same) > 0L) {
67
                same <- ob[obj.same]
67
                same <- ob[obj.same]
68
                same <- same[!(same %in% dont.mind)]
68
                same <- same[!(same %in% dont.mind)]
69
                Classobjs <- grep("^\\.__", same)
69
                Classobjs <- grep("^\\.__", same)
(-)src/library/base/R/library.R (-4 / +4 lines)
Lines 153-159 Link Here
153
        else {
153
        else {
154
            ## A package will have created a generic
154
            ## A package will have created a generic
155
            ## only if it has created a formal method.
155
            ## only if it has created a formal method.
156
            length(objects(env, pattern="^\\.__T", all.names=TRUE)) == 0L
156
            length(grep(pattern="^\\.__T", names(env))) == 0L
157
        }
157
        }
158
    }
158
    }
159
159
Lines 167-173 Link Here
167
        sp <- search()
167
        sp <- search()
168
        lib.pos <- match(pkgname, sp)
168
        lib.pos <- match(pkgname, sp)
169
        ## ignore generics not defined for the package
169
        ## ignore generics not defined for the package
170
        ob <- objects(lib.pos, all.names = TRUE)
170
        ob <- names(lib.pos)
171
        if(!nogenerics) {
171
        if(!nogenerics) {
172
            ##  Exclude generics that are consistent with implicit generic
172
            ##  Exclude generics that are consistent with implicit generic
173
            ## from another package.  A better test would be to move this
173
            ## from another package.  A better test would be to move this
Lines 183-190 Link Here
183
	ipos <- seq_along(sp)[-c(lib.pos,
183
	ipos <- seq_along(sp)[-c(lib.pos,
184
				 match(c("Autoloads", "CheckExEnv"), sp, 0L))]
184
				 match(c("Autoloads", "CheckExEnv"), sp, 0L))]
185
        for (i in ipos) {
185
        for (i in ipos) {
186
            obj.same <- match(objects(i, all.names = TRUE), ob, nomatch = 0L)
186
            obj.same <- match(names(i), ob, nomatch = 0L)
187
            if (any(obj.same > 0)) {
187
            if (sum(obj.same) > 0L) {
188
                same <- ob[obj.same]
188
                same <- ob[obj.same]
189
                same <- same[!(same %in% dont.mind)]
189
                same <- same[!(same %in% dont.mind)]
190
                Classobjs <- grep("^\\.__", same)
190
                Classobjs <- grep("^\\.__", same)
(-)src/library/base/R/namespace.R (-28 / +24 lines)
Lines 92-98 Link Here
92
	    get0(oNam, envir = ns)
92
	    get0(oNam, envir = ns)
93
	} else { ##  <pkg> :: <dataset>  for lazydata :
93
	} else { ##  <pkg> :: <dataset>  for lazydata :
94
	    ld <- .getNamespaceInfo(ns, "lazydata")
94
	    ld <- .getNamespaceInfo(ns, "lazydata")
95
	    if (!is.null(obj <- get0(name, envir = ld, inherits = FALSE)))
95
	    if (!is.null(obj <- ld[[name]]))
96
		obj
96
		obj
97
	    else { ## if there's a lazydata object with value NULL:
97
	    else { ## if there's a lazydata object with value NULL:
98
		if(exists(name, envir = ld, inherits = FALSE))
98
		if(exists(name, envir = ld, inherits = FALSE))
Lines 126-132 Link Here
126
{
126
{
127
    ## only used to run .onAttach
127
    ## only used to run .onAttach
128
    runHook <- function(hookname, env, libname, pkgname) {
128
    runHook <- function(hookname, env, libname, pkgname) {
129
        if (!is.null(fun <- get0(hookname, envir = env, inherits = FALSE))) {
129
        if (!is.null(fun <- env[[hookname]])) {
130
            res <- tryCatch(fun(libname, pkgname), error = identity)
130
            res <- tryCatch(fun(libname, pkgname), error = identity)
131
            if (inherits(res, "error")) {
131
            if (inherits(res, "error")) {
132
                stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
132
                stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
Lines 162-168 Link Here
162
    dimpenv <- .getNamespaceInfo(ns, "lazydata")
162
    dimpenv <- .getNamespaceInfo(ns, "lazydata")
163
    dnames <- names(dimpenv)
163
    dnames <- names(dimpenv)
164
    .Internal(importIntoEnv(env, dnames, dimpenv, dnames))
164
    .Internal(importIntoEnv(env, dnames, dimpenv, dnames))
165
    if(length(depends)) assign(".Depends", depends, env)
165
    if(length(depends)) env[[".Depends"]] <- depends
166
    Sys.setenv("_R_NS_LOAD_" = nsname)
166
    Sys.setenv("_R_NS_LOAD_" = nsname)
167
    on.exit(Sys.unsetenv("_R_NS_LOAD_"), add = TRUE)
167
    on.exit(Sys.unsetenv("_R_NS_LOAD_"), add = TRUE)
168
    runHook(".onAttach", ns, dirname(nspath), nsname)
168
    runHook(".onAttach", ns, dirname(nspath), nsname)
Lines 217-223 Link Here
217
    } else {
217
    } else {
218
        ## only used here for .onLoad
218
        ## only used here for .onLoad
219
        runHook <- function(hookname, env, libname, pkgname) {
219
        runHook <- function(hookname, env, libname, pkgname) {
220
	    if (!is.null(fun <- get0(hookname, envir = env, inherits = FALSE))) {
220
	    if (!is.null(fun <- env[[hookname]])) {
221
                res <- tryCatch(fun(libname, pkgname), error = identity)
221
                res <- tryCatch(fun(libname, pkgname), error = identity)
222
                if (inherits(res, "error")) {
222
                if (inherits(res, "error")) {
223
                    stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
223
                    stop(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
Lines 239-246 Link Here
239
            name <- as.character(as.name(name))
239
            name <- as.character(as.name(name))
240
            version <- as.character(version)
240
            version <- as.character(version)
241
            info <- new.env(hash = TRUE, parent = baseenv())
241
            info <- new.env(hash = TRUE, parent = baseenv())
242
            assign(".__NAMESPACE__.", info, envir = env)
242
            env[[".__NAMESPACE__."]] <- info
243
            assign("spec", c(name = name, version = version), envir = info)
243
            info[["spec"]] <- c(name = name, version = version)
244
            setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = baseenv()))
244
            setNamespaceInfo(env, "exports", new.env(hash = TRUE, parent = baseenv()))
245
            dimpenv <- new.env(parent = baseenv(), hash = TRUE)
245
            dimpenv <- new.env(parent = baseenv(), hash = TRUE)
246
            attr(dimpenv, "name") <- paste("lazydata", name, sep = ":")
246
            attr(dimpenv, "name") <- paste("lazydata", name, sep = ":")
Lines 251-259 Link Here
251
                             normalizePath(file.path(lib, name), "/", TRUE))
251
                             normalizePath(file.path(lib, name), "/", TRUE))
252
            setNamespaceInfo(env, "dynlibs", NULL)
252
            setNamespaceInfo(env, "dynlibs", NULL)
253
            setNamespaceInfo(env, "S3methods", matrix(NA_character_, 0L, 3L))
253
            setNamespaceInfo(env, "S3methods", matrix(NA_character_, 0L, 3L))
254
            assign(".__S3MethodsTable__.",
254
            env[[".__S3MethodsTable__."]] <-
255
                   new.env(hash = TRUE, parent = baseenv()),
255
                   new.env(hash = TRUE, parent = baseenv())
256
                   envir = env)
257
            .Internal(registerNamespace(name, env))
256
            .Internal(registerNamespace(name, env))
258
            env
257
            env
259
        }
258
        }
Lines 302-308 Link Here
302
                                                           sym$name, varName, varName, sQuote(package)),
301
                                                           sym$name, varName, varName, sQuote(package)),
303
                                                  domain = NA)
302
                                                  domain = NA)
304
                                      else
303
                                      else
305
                                          assign(varName, sym, envir = env)
304
                                          env[[varName]] <- sym
306
                                  })
305
                                  })
307
                       })
306
                       })
308
307
Lines 330-336 Link Here
330
                                                origVarName, varName, sQuote(package)),
329
                                                origVarName, varName, sQuote(package)),
331
                                       domain = NA)
330
                                       domain = NA)
332
                       else
331
                       else
333
                           assign(varName, symbols[[origVarName]], envir = env)
332
                           env[[varName]] <- symbols[[origVarName]]
334
333
335
                   })
334
                   })
336
            symbols
335
            symbols
Lines 426-432 Link Here
426
425
427
        env <- asNamespace(ns)
426
        env <- asNamespace(ns)
428
        ## save the package name in the environment
427
        ## save the package name in the environment
429
        assign(".packageName", package, envir = env)
428
        env[[".packageName"]] <- package
430
429
431
        ## load the code
430
        ## load the code
432
        codename <- strsplit(package, "_", fixed = TRUE)[[1L]][1L]
431
        codename <- strsplit(package, "_", fixed = TRUE)[[1L]][1L]
Lines 473-479 Link Here
473
            ## dynlibs vector.
472
            ## dynlibs vector.
474
            if(!is.null(names(nsInfo$dynlibs))
473
            if(!is.null(names(nsInfo$dynlibs))
475
               && nzchar(names(nsInfo$dynlibs)[i]))
474
               && nzchar(names(nsInfo$dynlibs)[i]))
476
                assign(names(nsInfo$dynlibs)[i], dlls[[lib]], envir = env)
475
                env[[names(nsInfo$dynlibs)[i]]] <- dlls[[lib]]
477
            setNamespaceInfo(env, "DLLs", dlls)
476
            setNamespaceInfo(env, "DLLs", dlls)
478
        }
477
        }
479
        addNamespaceDynLibs(env, nsInfo$dynlibs)
478
        addNamespaceDynLibs(env, nsInfo$dynlibs)
Lines 712-718 Link Here
712
{
711
{
713
    ## only used to run .onUnload
712
    ## only used to run .onUnload
714
    runHook <- function(hookname, env, ...) {
713
    runHook <- function(hookname, env, ...) {
715
	if (!is.null(fun <- get0(hookname, envir = env, inherits = FALSE))) {
714
	if (!is.null(fun <- env[[hookname]])) {
716
            res <- tryCatch(fun(...), error=identity)
715
            res <- tryCatch(fun(...), error=identity)
717
            if (inherits(res, "error")) {
716
            if (inherits(res, "error")) {
718
                warning(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
717
                warning(gettextf("%s failed in %s() for '%s', details:\n  call: %s\n  error: %s",
Lines 879-885 Link Here
879
	}
878
	}
880
    }
879
    }
881
    for (n in impnames)
880
    for (n in impnames)
882
	if (!is.null(genImp <- get0(n, envir = impenv, inherits = FALSE))) {
881
	if (!is.null(genImp <- impenv[[n]])) {
883
	    if (.isMethodsDispatchOn() && methods::isGeneric(n, ns)) {
882
	    if (.isMethodsDispatchOn() && methods::isGeneric(n, ns)) {
884
		## warn only if generic overwrites a function which
883
		## warn only if generic overwrites a function which
885
		## it was not derived from
884
		## it was not derived from
Lines 945-951 Link Here
945
            }
944
            }
946
        }
945
        }
947
        if(g %in% vars && !exists(g, envir = self, inherits = FALSE)) {
946
        if(g %in% vars && !exists(g, envir = self, inherits = FALSE)) {
948
	    if(!is.null(f <- get0(g, envir = ns)) && methods::is(f, "genericFunction")) {
947
	    if(!is.null(f <- ns[[g]]) && methods::is(f, "genericFunction")) {
949
                allVars <- c(allVars, g)
948
                allVars <- c(allVars, g)
950
                generics <- c(generics, g)
949
                generics <- c(generics, g)
951
                packages <- c(packages, p)
950
                packages <- c(packages, p)
Lines 1014-1020 Link Here
1014
                                paste(sQuote(expnames[ex]), collapse = ", ")),
1013
                                paste(sQuote(expnames[ex]), collapse = ", ")),
1015
                        call. = FALSE, domain = NA)
1014
                        call. = FALSE, domain = NA)
1016
            for (i in seq_along(new))
1015
            for (i in seq_along(new))
1017
                assign(expnames[i], intnames[i], envir = exports)
1016
                exports[[expnames[i]]] <- intnames[i]
1018
        }
1017
        }
1019
        makeImportExportNames <- function(spec) {
1018
        makeImportExportNames <- function(spec) {
1020
            old <- as.character(spec)
1019
            old <- as.character(spec)
Lines 1046-1054 Link Here
1046
    newMethods <- new[substr(new, 1L, nchar(mm, type = "c")) == mm]
1045
    newMethods <- new[substr(new, 1L, nchar(mm, type = "c")) == mm]
1047
    nsimports <- parent.env(ns)
1046
    nsimports <- parent.env(ns)
1048
    for(what in newMethods) {
1047
    for(what in newMethods) {
1049
	if(!is.null(m1 <- get0(what, envir = nsimports, inherits = FALSE))) {
1048
	if(!is.null(m1 <- nsimports[[what]])) {
1050
            m2 <- get(what, envir = ns)
1049
            m2 <- get(what, envir = ns)
1051
            assign(what, envir = ns, methods::mergeMethods(m1, m2))
1050
            ns[[what]] <- methods::mergeMethods(m1, m2)
1052
        }
1051
        }
1053
    }
1052
    }
1054
}
1053
}
Lines 1334-1342 Link Here
1334
        if (typeof(genfun) == "closure") environment(genfun)
1333
        if (typeof(genfun) == "closure") environment(genfun)
1335
	else .BaseNamespaceEnv
1334
	else .BaseNamespaceEnv
1336
    }
1335
    }
1337
    if (is.null(table <- get0(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))) {
1336
    if (is.null(table <- defenv[[".__S3MethodsTable__."]])) {
1338
	table <- new.env(hash = TRUE, parent = baseenv())
1337
	table <- new.env(hash = TRUE, parent = baseenv())
1339
	assign(".__S3MethodsTable__.", table, envir = defenv)
1338
	defenv[[".__S3MethodsTable__."]] <- table
1340
    }
1339
    }
1341
1340
1342
    if (is.character(method)) {
1341
    if (is.character(method)) {
Lines 1392-1400 Link Here
1392
            if (typeof(genfun) == "closure") environment(genfun)
1391
            if (typeof(genfun) == "closure") environment(genfun)
1393
            else .BaseNamespaceEnv
1392
            else .BaseNamespaceEnv
1394
        }
1393
        }
1395
	if (is.null(table <- get0(".__S3MethodsTable__.", envir = defenv, inherits = FALSE))) {
1394
	if (is.null(table <- defenv[[".__S3MethodsTable__."]])) {
1396
	    table <- new.env(hash = TRUE, parent = baseenv())
1395
	    table <- new.env(hash = TRUE, parent = baseenv())
1397
	    assign(".__S3MethodsTable__.", table, envir = defenv)
1396
	    defenv[[".__S3MethodsTable__."]] <- table
1398
	}
1397
	}
1399
        if(!is.null(e <- table[[nm]])) {
1398
        if(!is.null(e <- table[[nm]])) {
1400
            current <- environmentName(environment(e))
1399
            current <- environmentName(environment(e))
Lines 1469-1479 Link Here
1469
.mergeImportMethods <- function(impenv, expenv, metaname)
1468
.mergeImportMethods <- function(impenv, expenv, metaname)
1470
{
1469
{
1471
    expMethods <- get(metaname, envir = expenv)
1470
    expMethods <- get(metaname, envir = expenv)
1472
    if(!is.null(impMethods <- get0(metaname, envir = impenv, inherits = FALSE))) {
1471
    if(!is.null(impMethods <- impenv[[metaname]])) {
1473
	assign(metaname,
1472
	impenv[[metaname]] <- methods:::.mergeMethodsTable2(impMethods, expMethods, expenv, metaname)
1474
	       methods:::.mergeMethodsTable2(impMethods,
1475
					     expMethods, expenv, metaname),
1476
	       envir = impenv)
1477
	impMethods
1473
	impMethods
1478
    } ## else NULL
1474
    } ## else NULL
1479
}
1475
}
(-)src/library/methods/NAMESPACE (-1 lines)
Lines 61-67 Link Here
61
export(doPrimitiveMethod)
61
export(doPrimitiveMethod)
62
export(dumpMethod)
62
export(dumpMethod)
63
export(dumpMethods)
63
export(dumpMethods)
64
export(el, "el<-")
65
export(elNamed, "elNamed<-")
64
export(elNamed, "elNamed<-")
66
export(empty.dump)
65
export(empty.dump)
67
export(emptyMethodsList)
66
export(emptyMethodsList)
(-)src/library/methods/R/BasicClasses.R (-3 / +3 lines)
Lines 251-261 Link Here
251
        supers <- args[!which]
251
        supers <- args[!which]
252
        thisExtends <- names(ClassDef@contains)
252
        thisExtends <- names(ClassDef@contains)
253
        slotDefs <- ClassDef@slots
253
        slotDefs <- ClassDef@slots
254
        dataPart <- elNamed(slotDefs, ".Data")
254
        dataPart <- slotDefs[[".Data"]]
255
        if(is.null(dataPart))
255
        if(is.null(dataPart))
256
          dataPart <- "missing" # nothing will extend this => no data part args allowed
256
          dataPart <- "missing" # nothing will extend this => no data part args allowed
257
        for(i in rev(seq_along(supers))) {
257
        for(i in rev(seq_along(supers))) {
258
            obj <- el(supers, i)
258
            obj <- supers[[i]]
259
            Classi <- class(obj)
259
            Classi <- class(obj)
260
            defi <- getClassDef(Classi)
260
            defi <- getClassDef(Classi)
261
            if(is.null(defi))
261
            if(is.null(defi))
Lines 639-645 Link Here
639
                      localObjs <- is.na(match(objs, slots))
639
                      localObjs <- is.na(match(objs, slots))
640
                      if(any(localObjs)) {
640
                      if(any(localObjs)) {
641
                          for(what in objs[localObjs])
641
                          for(what in objs[localObjs])
642
                              assign(what, elNamed(args, what), envir = selfEnv)
642
                              selfEnv[[what]] <- args[[what]]
643
                          objs <- objs[!localObjs]
643
                          objs <- objs[!localObjs]
644
                          args <- args[!localObjs]
644
                          args <- args[!localObjs]
645
                      }
645
                      }
(-)src/library/methods/R/BasicFunsList.R (-1 / +1 lines)
Lines 94-100 Link Here
94
            substitute(standardGeneric(FNAME), list(FNAME=f))
94
            substitute(standardGeneric(FNAME), list(FNAME=f))
95
    }
95
    }
96
    deflt <- .derivedDefaultMethod(deflt)
96
    deflt <- .derivedDefaultMethod(deflt)
97
    elNamed(funslist, f) <- makeGeneric(f, fdef, deflt, group = group, package = "base",
97
    funslist[[f]] <- makeGeneric(f, fdef, deflt, group = group, package = "base",
98
                                        signature = signature)
98
                                        signature = signature)
99
    funslist
99
    funslist
100
}
100
}
(-)src/library/methods/R/ClassExtensions.R (-2 / +2 lines)
Lines 185-191 Link Here
185
    distance <- 1
185
    distance <- 1
186
    ##FIX ME:  when by is supplied, should use the existing extension information
186
    ##FIX ME:  when by is supplied, should use the existing extension information
187
    ## to compute distance
187
    ## to compute distance
188
    dataPartClass <- elNamed(slots, ".Data")
188
    dataPartClass <- elNamed(slots, ".Data") # This seems to be the only elNamed that has to stay
189
    dataPart <- FALSE
189
    dataPart <- FALSE
190
    if(simple && !is.null(dataPartClass)) {
190
    if(simple && !is.null(dataPartClass)) {
191
        if(!(is.null(getClassDef(dataPartClass)) || is.null(getClassDef(to)))) {
191
        if(!(is.null(getClassDef(dataPartClass)) || is.null(getClassDef(to)))) {
Lines 234-240 Link Here
234
    }
234
    }
235
    if(is.null(replace)) {
235
    if(is.null(replace)) {
236
        if(dataPart) {
236
        if(dataPart) {
237
            extn <- elNamed(classDef2@contains, dataPartClass)
237
            extn <- classDef2@contains[[dataPartClass]]
238
            if(is(extn, "SClassExtension"))
238
            if(is(extn, "SClassExtension"))
239
                easy <- extn@simple
239
                easy <- extn@simple
240
            else
240
            else
(-)src/library/methods/R/Methods.R (-2 / +2 lines)
Lines 516-522 Link Here
516
    }
516
    }
517
    else if(identical(gwhere, NA)) {
517
    else if(identical(gwhere, NA)) {
518
        ## better be a primitive since getGeneric returned a generic, but none was found
518
        ## better be a primitive since getGeneric returned a generic, but none was found
519
        if(is.null(elNamed(.BasicFunsList, f)))
519
        if(is.null(.BasicFunsList[[f]]))
520
            stop(sprintf("apparent internal error: a generic function was found for \"%s\", but no corresponding object was found searching from \"%s\"",
520
            stop(sprintf("apparent internal error: a generic function was found for \"%s\", but no corresponding object was found searching from \"%s\"",
521
                          f, getPackageName(where)), domain = NA)
521
                          f, getPackageName(where)), domain = NA)
522
        if(!isGeneric(f))
522
        if(!isGeneric(f))
Lines 889-895 Link Here
889
    value <- list(...)
889
    value <- list(...)
890
    names <- names(value)
890
    names <- names(value)
891
    for(i in seq_along(value)) {
891
    for(i in seq_along(value)) {
892
        sigi <- el(value, i)
892
        sigi <- value[[i]]
893
        if(!is.character(sigi) || length(sigi) != 1L)
893
        if(!is.character(sigi) || length(sigi) != 1L)
894
            stop(gettextf(
894
            stop(gettextf(
895
		"bad class specified for element %d (should be a single character string)",
895
		"bad class specified for element %d (should be a single character string)",
(-)src/library/methods/R/MethodsList.R (-23 / +23 lines)
Lines 57-63 Link Here
57
    i <- match("", mnames)
57
    i <- match("", mnames)
58
    if(!is.na(i)) {
58
    if(!is.na(i)) {
59
        ## convert to ANY
59
        ## convert to ANY
60
        el(mnames, i) <- "ANY"
60
        mnames[[i]] <- "ANY"
61
        names(object) <- mnames
61
        names(object) <- mnames
62
    }
62
    }
63
    if(anyDuplicated(mnames))
63
    if(anyDuplicated(mnames))
Lines 65-76 Link Here
65
             level, paste("\"", unique(mnames[duplicated(mnames)]), "\"",
65
             level, paste("\"", unique(mnames[duplicated(mnames)]), "\"",
66
                          collapse=", ")), domain = NA)
66
                          collapse=", ")), domain = NA)
67
    for(i in seq_along(object)) {
67
    for(i in seq_along(object)) {
68
        eli <- el(object, i)
68
        eli <- object[[i]]
69
        if(is(eli, "function")
69
        if(is(eli, "function")
70
           || is(eli, "MethodsList")) {}
70
           || is(eli, "MethodsList")) {}
71
        else if(is(eli, "list") ||
71
        else if(is(eli, "list") ||
72
                is(eli, "named"))
72
                is(eli, "named"))
73
            el(object, i) <- Recall(eli, NULL, level+1)
73
            object[[i]] <- Recall(eli, NULL, level+1)
74
        else
74
        else
75
            stop(gettextf("element %d at level %d (class %s) cannot be interpreted as a function or named list",
75
            stop(gettextf("element %d at level %d (class %s) cannot be interpreted as a function or named list",
76
                          i, level, dQuote(class(eli))),
76
                          i, level, dQuote(class(eli))),
Lines 97-106 Link Here
97
        stop("arguments 'names' and 'signature' must have the same length")
97
        stop("arguments 'names' and 'signature' must have the same length")
98
    if(n == 0)
98
    if(n == 0)
99
        return(definition)
99
        return(definition)
100
    Class <- el(signature,n)
100
    Class <- signature[[n]]
101
    name <- el(names, n)
101
    name <- names[[n]]
102
    m <- MethodsList(name)
102
    m <- MethodsList(name)
103
    elNamed(slot(m, "methods"), Class) <- definition
103
    slot(m, "methods")[[Class]] <- definition
104
    slot(m, "argument") <- as.name(name)
104
    slot(m, "argument") <- as.name(name)
105
    SignatureMethod(names[-n], signature[-n], m)
105
    SignatureMethod(names[-n], signature[-n], m)
106
}
106
}
Lines 134-142 Link Here
134
             domain = NA)
134
             domain = NA)
135
    if(length(args) > 1 && !cacheOnly)
135
    if(length(args) > 1 && !cacheOnly)
136
        mlist <- balanceMethodsList(mlist, args)
136
        mlist <- balanceMethodsList(mlist, args)
137
    Class <- el(signature, 1)
137
    Class <- signature[[1]]
138
    methods <- if(cacheOnly) mlist@allMethods else mlist@methods
138
    methods <- if(cacheOnly) mlist@allMethods else mlist@methods
139
    current <- elNamed(methods, Class)
139
    current <- methods[[Class]]
140
    if(is(current, "MethodsList")) {
140
    if(is(current, "MethodsList")) {
141
        nextArg <- as.character(current@argument)
141
        nextArg <- as.character(current@argument)
142
        sigArgs <- args
142
        sigArgs <- args
Lines 155-161 Link Here
155
    if(length(signature) == 1) {
155
    if(length(signature) == 1) {
156
        if(is.null(current)) {
156
        if(is.null(current)) {
157
            if(!is.null(def))
157
            if(!is.null(def))
158
                elNamed(methods, Class) <- def
158
                methods[[Class]] <- def
159
            ## else, no change
159
            ## else, no change
160
        }
160
        }
161
        else {
161
        else {
Lines 164-170 Link Here
164
                ## delete the method
164
                ## delete the method
165
                methods <- methods[-which]
165
                methods <- methods[-which]
166
            else
166
            else
167
                el(methods, which) <- def
167
                methods[[which]] <- def
168
        }
168
        }
169
    }
169
    }
170
    else { ## recursively merge, initializing current if necessary
170
    else { ## recursively merge, initializing current if necessary
Lines 173-179 Link Here
173
        else if(is.function(current))
173
        else if(is.function(current))
174
            current <- new("MethodsList", argument = as.name(args[2L]),
174
            current <- new("MethodsList", argument = as.name(args[2L]),
175
			   methods = list(ANY = current))
175
			   methods = list(ANY = current))
176
        elNamed(methods, Class) <-
176
        methods[[Class]] <-
177
            Recall(current, signature[-1L], args[-1L], def, cacheOnly)
177
            Recall(current, signature[-1L], args[-1L], def, cacheOnly)
178
    }
178
    }
179
    mlist@allMethods <- methods
179
    mlist@allMethods <- methods
Lines 391-397 Link Here
391
          break
391
          break
392
        if(is(method, "MethodsList")) {
392
        if(is(method, "MethodsList")) {
393
	    .MlistDeprecated()
393
	    .MlistDeprecated()
394
            method <-  elNamed(slot(method, "methods"), "ANY")
394
            method <-  slot(method, "methods")[["ANY"]]
395
        } else
395
        } else
396
          stop(gettextf(
396
          stop(gettextf(
397
	"default method must be a method definition, a primitive or NULL: got an object of class %s",
397
	"default method must be a method definition, a primitive or NULL: got an object of class %s",
Lines 414-420 Link Here
414
{
414
{
415
  .MlistDeprecated("inheritedSubMethodLists()")
415
  .MlistDeprecated("inheritedSubMethodLists()")
416
  methods <- slot(mlist, "methods")## only direct methods
416
  methods <- slot(mlist, "methods")## only direct methods
417
  defaultMethod <- elNamed(methods, "ANY")## maybe NULL
417
  defaultMethod <- methods[["ANY"]]## maybe NULL
418
  classes <- names(methods)
418
  classes <- names(methods)
419
  value <- list()
419
  value <- list()
420
  if(.identC(thisClass, "missing")) {
420
  if(.identC(thisClass, "missing")) {
Lines 433-460 Link Here
433
          superClasses <- names(classDef@contains)
433
          superClasses <- names(classDef@contains)
434
          classes <- superClasses[!is.na(match(superClasses, classes))]
434
          classes <- superClasses[!is.na(match(superClasses, classes))]
435
          for(which in seq_along(classes)) {
435
          for(which in seq_along(classes)) {
436
              tryClass <- el(classes, which)
436
              tryClass <- classes[[which]]
437
              ## TODO:  There is potential bug here:  If the is relation is conditional,
437
              ## TODO:  There is potential bug here:  If the is relation is conditional,
438
              ## we should not cache this selection.  Needs another trick in the environment
438
              ## we should not cache this selection.  Needs another trick in the environment
439
              ## to FORCE no caching regardless of what happens elsewhere; e.g., storing a
439
              ## to FORCE no caching regardless of what happens elsewhere; e.g., storing a
440
              ## special object in .Class
440
              ## special object in .Class
441
              if(is.null(object) || is(object, tryClass)) {
441
              if(is.null(object) || is(object, tryClass)) {
442
                  elNamed(value, tryClass) <- elNamed(methods, tryClass)
442
                  value[[tryClass]] <- methods[[tryClass]]
443
              }
443
              }
444
          }
444
          }
445
      }
445
      }
446
      else {
446
      else {
447
          for(which in seq_along(classes)) {
447
          for(which in seq_along(classes)) {
448
              tryClass <- el(classes, which)
448
              tryClass <- classes[[which]]
449
              tryClassDef <- getClassDef(tryClass, ev)
449
              tryClassDef <- getClassDef(tryClass, ev)
450
              if(!is.null(tryClassDef) &&
450
              if(!is.null(tryClassDef) &&
451
                 !is.na(match(thisClass, names(tryClassDef@subclasses))))
451
                 !is.na(match(thisClass, names(tryClassDef@subclasses))))
452
                  elNamed(value, tryClass) <- el(methods, which)
452
                  value[[tryClass]] <- methods[[which]]
453
          }
453
          }
454
      }
454
      }
455
  }
455
  }
456
  if(!is.null(defaultMethod))
456
  if(!is.null(defaultMethod))
457
      elNamed(value, "ANY") <- defaultMethod
457
      value[["ANY"]] <- defaultMethod
458
  value
458
  value
459
}
459
}
460
460
Lines 812-820 Link Here
812
    sigs <- list()
812
    sigs <- list()
813
    methods <- list()
813
    methods <- list()
814
    for(i in seq_along(methodSlot)) {
814
    for(i in seq_along(methodSlot)) {
815
        thisMethod <- el(methodSlot, i)
815
        thisMethod <- methodSlot[i]
816
        thisClass <- el(mnames, i)
816
        thisClass <- mnames[[i]]
817
        elNamed(prefix, argName) <- thisClass
817
        prefix[[argName]] <- thisClass
818
        if(is.function(thisMethod)) {
818
        if(is.function(thisMethod)) {
819
            if(sigs.) sigs <- c(sigs, list(prefix))
819
            if(sigs.) sigs <- c(sigs, list(prefix))
820
            if(methods.) methods <- c(methods, list(thisMethod))
820
            if(methods.) methods <- c(methods, list(thisMethod))
Lines 821-828 Link Here
821
        }
821
        }
822
        else {
822
        else {
823
            more <- Recall(thisMethod, prefix)
823
            more <- Recall(thisMethod, prefix)
824
            if(sigs.) sigs <- c(sigs, el(more, 1))
824
            if(sigs.) sigs <- c(sigs, more[[1]])
825
            if(methods.) methods <- c(methods, el(more, 2))
825
            if(methods.) methods <- c(methods, more[[2]])
826
        }
826
        }
827
    }
827
    }
828
    list(sigs, methods)
828
    list(sigs, methods)
(-)src/library/methods/R/MethodsListClass.R (-1 / +1 lines)
Lines 193-199 Link Here
193
                  args <- list(...)
193
                  args <- list(...)
194
                  objs <- names(args)
194
                  objs <- names(args)
195
                  for(what in objs)
195
                  for(what in objs)
196
                      assign(what, elNamed(args, what), envir = value)
196
                      value[[what]] <- args[[what]]
197
                  value
197
                  value
198
              }, where = envir)
198
              }, where = envir)
199
    ## from 2.11.0, the MethodsList class is deprecated
199
    ## from 2.11.0, the MethodsList class is deprecated
(-)src/library/methods/R/RClassUtils.R (-23 / +23 lines)
Lines 63-69 Link Here
63
    ## try for a single superclass that is not virtual
63
    ## try for a single superclass that is not virtual
64
    supers <- names(extends)
64
    supers <- names(extends)
65
##    virtual <- NA
65
##    virtual <- NA
66
    dataPartClass <- elNamed(slots, ".Data")
66
    dataPartClass <- slots[[".Data"]]
67
    prototype <- ClassDef@prototype
67
    prototype <- ClassDef@prototype
68
    dataPartDone <- is.null(dataPartClass)  || is(prototype, dataPartClass)# don't look for data part in supreclasses
68
    dataPartDone <- is.null(dataPartClass)  || is(prototype, dataPartClass)# don't look for data part in supreclasses
69
    ## check for a formal prototype object (TODO:  sometime ensure that this happens
69
    ## check for a formal prototype object (TODO:  sometime ensure that this happens
Lines 77-83 Link Here
77
    if(length(slots) == 0L && !is.null(prototype))
77
    if(length(slots) == 0L && !is.null(prototype))
78
            return(prototype)
78
            return(prototype)
79
    for(i in seq_along(extends)) {
79
    for(i in seq_along(extends)) {
80
        what <- el(supers, i)
80
        what <- supers[[i]]
81
        exti <- extends[[i]]
81
        exti <- extends[[i]]
82
        if(identical(exti@simple, FALSE))
82
        if(identical(exti@simple, FALSE))
83
            next ## only simple contains rel'ns give slots
83
            next ## only simple contains rel'ns give slots
Lines 133-139 Link Here
133
    ## now check that all the directly specified slots have corresponding elements
133
    ## now check that all the directly specified slots have corresponding elements
134
    ## in the prototype--the inherited slots were done in the loop over extends
134
    ## in the prototype--the inherited slots were done in the loop over extends
135
    if(!is.na(match(".Data", snames))) {
135
    if(!is.na(match(".Data", snames))) {
136
        dataPartClass <- elNamed(slots, ".Data")
136
        dataPartClass <- slots[[".Data"]]
137
137
138
        ## check the data part
138
        ## check the data part
139
        if(!(isVirtualClass(dataPartClass))) {
139
        if(!(isVirtualClass(dataPartClass))) {
Lines 155-166 Link Here
155
        slots <- slots[iData]
155
        slots <- slots[iData]
156
    }
156
    }
157
    for(j in seq_along(snames)) {
157
    for(j in seq_along(snames)) {
158
        name <- el(snames, j)
158
        name <- snames[[j]]
159
        i <- match(name, pnames)
159
        i <- match(name, pnames)
160
        if(is.na(i)) {
160
        if(is.na(i)) {
161
            ## if the class of the j-th element of slots is defined and non-virtual,
161
            ## if the class of the j-th element of slots is defined and non-virtual,
162
            ## generate an object from it; else insert NULL
162
            ## generate an object from it; else insert NULL
163
            slot(prototype, name, check = FALSE) <- tryNew(el(slots, j), where)
163
            slot(prototype, name, check = FALSE) <- tryNew(slots[[j]], where)
164
        }
164
        }
165
    }
165
    }
166
    extra <- pnames[is.na(match(pnames, snames)) & !is.na(match(pnames, pslots))]
166
    extra <- pnames[is.na(match(pnames, snames)) & !is.na(match(pnames, pslots))]
Lines 559-565 Link Here
559
    slot(object, "prototype", FALSE) <- proto
559
    slot(object, "prototype", FALSE) <- proto
560
    for(what in c("contains", "validity", "access", "hasValidity", "subclasses",
560
    for(what in c("contains", "validity", "access", "hasValidity", "subclasses",
561
                  "versionKey"))
561
                  "versionKey"))
562
        slot(object, what, FALSE) <- elNamed(protoSlots, what)
562
        slot(object, what, FALSE) <- protoSlots[[what]]
563
    slot(object, "sealed", FALSE) <- TRUE
563
    slot(object, "sealed", FALSE) <- TRUE
564
    slot(object, "package", FALSE) <- getPackageName(where)
564
    slot(object, "package", FALSE) <- getPackageName(where)
565
##    assignClassDef("classRepresentation", object, where)
565
##    assignClassDef("classRepresentation", object, where)
Lines 672-678 Link Here
672
      ## a vector.  But none of the existing SEXP types work.  Someday ...
672
      ## a vector.  But none of the existing SEXP types work.  Someday ...
673
      StandardPrototype <- defaultPrototype()
673
      StandardPrototype <- defaultPrototype()
674
      slots <-  validSlotNames(allNames(properties))
674
      slots <-  validSlotNames(allNames(properties))
675
      dataPartClass <- elNamed(properties, ".Data")
675
      dataPartClass <- properties[[".Data"]]
676
      dataPartValue <- FALSE
676
      dataPartValue <- FALSE
677
      if(!is.null(dataPartClass) && is.null(.validDataPartClass(dataPartClass, where)))
677
      if(!is.null(dataPartClass) && is.null(.validDataPartClass(dataPartClass, where)))
678
          stop(gettextf("in defining class %s, the supplied data part class, %s is not valid (must be a basic class or a virtual class combining basic classes)",
678
          stop(gettextf("in defining class %s, the supplied data part class, %s is not valid (must be a basic class or a virtual class combining basic classes)",
Lines 703-711 Link Here
703
                  properties <- c(list(".Data"= dataPartClass), properties)
703
                  properties <- c(list(".Data"= dataPartClass), properties)
704
                  slots <- names(properties)
704
                  slots <- names(properties)
705
              }
705
              }
706
              else if(!extends(elNamed(properties, ".Data"), dataPartClass))
706
              else if(!extends(properties[[".Data"]], dataPartClass))
707
                  stop(gettextf("conflicting definition of data part: .Data = %s, superclass implies %s",
707
                  stop(gettextf("conflicting definition of data part: .Data = %s, superclass implies %s",
708
                                dQuote(elNamed(properties, ".Data")),
708
                                dQuote(properties[[".Data"]]),
709
                                dQuote(dataPartClass)),
709
                                dQuote(dataPartClass)),
710
                       domain = NA)
710
                       domain = NA)
711
##              pslots <- NULL
711
##              pslots <- NULL
Lines 760-770 Link Here
760
              theseSlots <- theseSlots[theseSlots == ".Data"] # handled already
760
              theseSlots <- theseSlots[theseSlots == ".Data"] # handled already
761
              dups <- !is.na(match(theseSlots, allProps))
761
              dups <- !is.na(match(theseSlots, allProps))
762
              for(dup in theseSlots[dups])
762
              for(dup in theseSlots[dups])
763
                  if(!extends(elNamed(allProps, dup), elNamed(theseProperties, dup)))
763
                  if(!extends(allProps[[dup]], theseProperties[[dup]]))
764
                      stop(gettextf("slot %s in class %s currently defined (or inherited) as \"%s\", conflicts with an inherited definition in class %s",
764
                      stop(gettextf("slot %s in class %s currently defined (or inherited) as \"%s\", conflicts with an inherited definition in class %s",
765
                                    sQuote(dup),
765
                                    sQuote(dup),
766
                                    dQuote(name),
766
                                    dQuote(name),
767
                                    elNamed(allProps, dup),
767
                                    allProps[[dup]],
768
                                    dQuote(cl)),
768
                                    dQuote(cl)),
769
                           domain = NA)
769
                           domain = NA)
770
              theseSlots <- theseSlots[!dups]
770
              theseSlots <- theseSlots[!dups]
Lines 829-838 Link Here
829
      what <- slots[what]
829
      what <- slots[what]
830
      nm <- names(attributes(prototype))
830
      nm <- names(attributes(prototype))
831
      for(i in seq_along(what)) {
831
      for(i in seq_along(what)) {
832
          propName <- el(what, i)
832
          propName <- what[[i]]
833
          if(!identical(propName, ".Data") && !propName %in% nm)
833
          if(!identical(propName, ".Data") && !propName %in% nm)
834
#             is.null(attr(prototype, propName)))
834
#             is.null(attr(prototype, propName)))
835
              slot(prototype, propName, FALSE) <- tryNew(el(props, i), where)
835
              slot(prototype, propName, FALSE) <- tryNew(props[[i]], where)
836
      }
836
      }
837
      list(properties = properties, prototype = prototype)
837
      list(properties = properties, prototype = prototype)
838
  }
838
  }
Lines 922-928 Link Here
922
    what <- names(ext)
922
    what <- names(ext)
923
    how <- character(length(ext))
923
    how <- character(length(ext))
924
    for(i in seq_along(ext)) {
924
    for(i in seq_along(ext)) {
925
        eli <- el(ext, i)
925
        eli <- ext[[i]]
926
        if(is(eli, "SClassExtension")) {
926
        if(is(eli, "SClassExtension")) {
927
            how[i] <-
927
            how[i] <-
928
                if(length(eli@by))
928
                if(length(eli@by))
Lines 976-995 Link Here
976
{
976
{
977
    if(.identC(class1[[1L]], class2) || .identC(class2, "ANY"))
977
    if(.identC(class1[[1L]], class2) || .identC(class2, "ANY"))
978
        return(TRUE)
978
        return(TRUE)
979
    ext <- TRUE # may become a list of extends definitions
980
    if(is.null(ClassDef1)) # class1 not defined
979
    if(is.null(ClassDef1)) # class1 not defined
981
        return(FALSE)
980
        return(FALSE)
982
    ## else
981
    ## else
983
    ext <- ClassDef1@contains
982
    ext <- ClassDef1@contains
984
    nm1 <- names(ext)
983
    nm1 <- names(ext)
985
    i <- match(class2, nm1)
984
    i <- which(nm1 == class2)
986
    if(is.na(i)) {
985
    if ( length(i) ) {
986
        return( ext[[i]] )
987
    } else {
987
        ## look for class1 in the known subclasses of class2
988
        ## look for class1 in the known subclasses of class2
988
        if(!is.null(ClassDef2)) {
989
        if(!is.null(ClassDef2)) {
989
            ext <- ClassDef2@subclasses
990
            ext <- ClassDef2@subclasses
990
            ## check for a classUnion definition, not a plain "classRepresentation"
991
            ## check for a classUnion definition, not a plain "classRepresentation"
991
            if(!.identC(class(ClassDef2), "classRepresentation") &&
992
            if(!.identC(class(ClassDef2), "classRepresentation") && isClassUnion(ClassDef2))
992
               isClassUnion(ClassDef2))
993
                ## a simple TRUE iff class1 or one of its superclasses belongs to the union
993
                ## a simple TRUE iff class1 or one of its superclasses belongs to the union
994
		            i <- any(c(class1, nm1) %in% names(ext))
994
		            i <- any(c(class1, nm1) %in% names(ext))
995
            else {
995
            else {
Lines 1000-1013 Link Here
1000
                i <- if(length(ii))  ii[1L] else i[1L]
1000
                i <- if(length(ii))  ii[1L] else i[1L]
1001
            }
1001
            }
1002
        }
1002
        }
1003
    }
1004
    if(is.na(i))
1003
    if(is.na(i))
1005
        FALSE
1004
        FALSE
1006
    else if(is.logical(i))
1005
    else if(is.logical(i))
1007
        i
1006
        i
1008
    else
1007
    else
1009
        el(ext, i)
1008
            ext[[i]]
1010
}
1009
}
1010
}
1011
1011
1012
  ## complete the extends information in the class definition, by following
1012
  ## complete the extends information in the class definition, by following
1013
  ## transitive chains.
1013
  ## transitive chains.
Lines 1398-1404 Link Here
1398
        slots <- getSlots(classDef)
1398
        slots <- getSlots(classDef)
1399
        dataSlot <- .dataSlot(names(slots))
1399
        dataSlot <- .dataSlot(names(slots))
1400
        if(length(dataSlot) == 1)
1400
        if(length(dataSlot) == 1)
1401
          dataClass <- elNamed(slots, dataSlot)
1401
          dataClass <- slots[[dataSlot]]
1402
        else if(check)
1402
        else if(check)
1403
          stop(gettextf("class %s does not have a data part (a .Data slot) defined",
1403
          stop(gettextf("class %s does not have a data part (a .Data slot) defined",
1404
                        dQuote(class(object))),
1404
                        dQuote(class(object))),
Lines 1425-1431 Link Here
1425
        ClassDef <- getClass(cl, TRUE)
1425
        ClassDef <- getClass(cl, TRUE)
1426
1426
1427
    switch(cl, matrix = , array = value <- cl,
1427
    switch(cl, matrix = , array = value <- cl,
1428
           value <- elNamed(ClassDef@slots, ".Data"))
1428
           value <- ClassDef@slots[[".Data"]])
1429
    if(is.null(value)) {
1429
    if(is.null(value)) {
1430
        if(.identC(cl, "structure"))
1430
        if(.identC(cl, "structure"))
1431
            value <- "vector"
1431
            value <- "vector"
(-)src/library/methods/R/RMethodUtils.R (-6 / +6 lines)
Lines 261-274 Link Here
261
    if(is.null(m1) || is(m1, "EmptyMethodsList"))
261
    if(is.null(m1) || is(m1, "EmptyMethodsList"))
262
        return(m2)
262
        return(m2)
263
    tmp <- listFromMlist(m2)
263
    tmp <- listFromMlist(m2)
264
    sigs <- el(tmp, 1)
264
    sigs <- tmp[[1]]
265
    methods <- el(tmp, 2)
265
    methods <- tmp[[2]]
266
    for(i in seq_along(sigs)) {
266
    for(i in seq_along(sigs)) {
267
        sigi <- el(sigs, i)
267
        sigi <- sigs[[i]]
268
        if(.noMlists() && !identical(unique(sigi), "ANY"))
268
        if(.noMlists() && !identical(unique(sigi), "ANY"))
269
          next
269
          next
270
        args <- names(sigi)
270
        args <- names(sigi)
271
        m1 <- insertMethod(m1, as.character(sigi), args, el(methods, i), FALSE)
271
        m1 <- insertMethod(m1, as.character(sigi), args, methods[[i]], FALSE)
272
    }
272
    }
273
    m1
273
    m1
274
}
274
}
Lines 491-497 Link Here
491
        value <- .Call(C_R_getGeneric, f, FALSE, as.environment(where), package)
491
        value <- .Call(C_R_getGeneric, f, FALSE, as.environment(where), package)
492
        ## cache public generics (usually these will have been cached already
492
        ## cache public generics (usually these will have been cached already
493
        ## and we get to this code for non-exported generics)
493
        ## and we get to this code for non-exported generics)
494
        if(!is.null(value) && !is.null(vv <- get0(f, .GlobalEnv)) &&
494
        if(!is.null(value) && !is.null(vv <- .GlobalEnv[[f]]) &&
495
           identical(vv, value))
495
           identical(vv, value))
496
            .cacheGeneric(f, value)
496
            .cacheGeneric(f, value)
497
    }
497
    }
Lines 761-767 Link Here
761
    }
761
    }
762
    else {
762
    else {
763
        if(is.environment(where)) where <- list(where)
763
        if(is.environment(where)) where <- list(where)
764
        these <- unlist(lapply(where, objects, all.names=TRUE), use.names=FALSE)
764
        these <- unlist(lapply(where, names), use.names=FALSE)
765
        metaNameUndo(unique(these), prefix = "T", searchForm = searchForm)
765
        metaNameUndo(unique(these), prefix = "T", searchForm = searchForm)
766
    }
766
    }
767
}
767
}
(-)src/library/methods/R/SClasses.R (-12 / +12 lines)
Lines 127-133 Link Here
127
    ## since set SClass works separately with the slots and extends arguments.
127
    ## since set SClass works separately with the slots and extends arguments.
128
    anames <- allNames(value)
128
    anames <- allNames(value)
129
    for(i in seq_along(value)) {
129
    for(i in seq_along(value)) {
130
        ei <- el(value, i)
130
        ei <- value[[i]]
131
        if(!is.character(ei) || length(ei) != 1L)
131
        if(!is.character(ei) || length(ei) != 1L)
132
            stop(gettextf("element %d of the representation was not a single character string", i), domain = NA)
132
            stop(gettextf("element %d of the representation was not a single character string", i), domain = NA)
133
    }
133
    }
Lines 205-211 Link Here
205
        what <- whatClassDef@className # includes package name as attribute
205
        what <- whatClassDef@className # includes package name as attribute
206
        ## Create the SClassExtension objects (will be simple, possibly dataPart).
206
        ## Create the SClassExtension objects (will be simple, possibly dataPart).
207
        ## The slots are supplied explicitly, since `name' is currently an undefined class
207
        ## The slots are supplied explicitly, since `name' is currently an undefined class
208
        elNamed(contains, what) <- makeExtends(name, what, slots = slots,
208
        contains[[what]] <- makeExtends(name, what, slots = slots,
209
                                              classDef2 = whatClassDef, package = package)
209
                                              classDef2 = whatClassDef, package = package)
210
    }
210
    }
211
    validity <- .makeValidityMethod(name, validity)
211
    validity <- .makeValidityMethod(name, validity)
Lines 212-218 Link Here
212
    if(is.na(virtual)) {
212
    if(is.na(virtual)) {
213
        virtual <- testVirtual(slots, contains, prototype, where)
213
        virtual <- testVirtual(slots, contains, prototype, where)
214
        if(virtual && !is.na(match("VIRTUAL", superClasses)))
214
        if(virtual && !is.na(match("VIRTUAL", superClasses)))
215
            elNamed(contains, "VIRTUAL") <- NULL
215
            contains[["VIRTUAL"]] <- NULL
216
    }
216
    }
217
    # new() must return an S4 object, except perhaps for basic classes
217
    # new() must return an S4 object, except perhaps for basic classes
218
    if(!is.null(prototype) && is.na(match(name, .BasicClasses)))
218
    if(!is.null(prototype) && is.na(match(name, .BasicClasses)))
Lines 304-310 Link Here
304
{
304
{
305
    cl <- class(obj)
305
    cl <- class(obj)
306
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
306
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
307
    slotClass <- elNamed(ClassDef@slots, name)
307
    slotClass <- ClassDef@slots[[name]]
308
    if(is.null(slotClass))
308
    if(is.null(slotClass))
309
        stop(gettextf("%s is not a slot in class %s",
309
        stop(gettextf("%s is not a slot in class %s",
310
                      sQuote(name), dQuote(cl)),
310
                      sQuote(name), dQuote(cl)),
Lines 330-336 Link Here
330
checkAtAssignment <- function(cl, name, valueClass)
330
checkAtAssignment <- function(cl, name, valueClass)
331
{
331
{
332
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
332
    ClassDef <- getClass(cl) # fails if cl not a defined class (!)
333
    slotClass <- elNamed(ClassDef@slots, name)
333
    slotClass <- ClassDef@slots[[name]]
334
    if(is.null(slotClass))
334
    if(is.null(slotClass))
335
        stop(gettextf("%s is not a slot in class %s",
335
        stop(gettextf("%s is not a slot in class %s",
336
                      sQuote(name), dQuote(cl)),
336
                      sQuote(name), dQuote(cl)),
Lines 442-452 Link Here
442
        evList <- .parentEnvList(where)
442
        evList <- .parentEnvList(where)
443
        clNames <- character()
443
        clNames <- character()
444
        for(ev in evList)
444
        for(ev in evList)
445
            clNames <- c(clNames, objects(ev, pattern = pat, all.names = TRUE))
445
            clNames <- c(clNames, grep(pat, names(ev), value=TRUE))
446
        clNames <- unique(clNames)
446
        clNames <- unique(clNames)
447
    }
447
    }
448
    else
448
    else
449
        clNames <- objects(where, pattern = pat, all.names = TRUE)
449
        clNames <- grep(pat, names(where), value=TRUE)
450
    ## strip off the leading pattern (this implicitly assumes the characters
450
    ## strip off the leading pattern (this implicitly assumes the characters
451
    ## in classMetaName("") are either "." or not metacharacters
451
    ## in classMetaName("") are either "." or not metacharacters
452
    substring(clNames, nchar(pat, "c"))
452
    substring(clNames, nchar(pat, "c"))
Lines 638-648 Link Here
638
        supers <- args[!which]
638
        supers <- args[!which]
639
        thisExtends <- names(ClassDef@contains)
639
        thisExtends <- names(ClassDef@contains)
640
        slotDefs <- ClassDef@slots
640
        slotDefs <- ClassDef@slots
641
        dataPart <- elNamed(slotDefs, ".Data")
641
        dataPart <- slotDefs[[".Data"]]
642
        if(is.null(dataPart)) dataPart <- "missing"
642
        if(is.null(dataPart)) dataPart <- "missing"
643
        if(length(supers)) {
643
        if(length(supers)) {
644
            for(i in rev(seq_along(supers))) {
644
            for(i in rev(seq_along(supers))) {
645
                obj <- el(supers, i)
645
                obj <- supers[[i]]
646
                Classi <- class(obj)
646
                Classi <- class(obj)
647
                if(length(Classi) > 1L)
647
                if(length(Classi) > 1L)
648
                    Classi <- Classi[[1L]] #possible S3 inheritance
648
                    Classi <- Classi[[1L]] #possible S3 inheritance
Lines 695-704 Link Here
695
                     domain = NA)
695
                     domain = NA)
696
            firstTime <- TRUE
696
            firstTime <- TRUE
697
            for(i in seq_along(snames)) {
697
            for(i in seq_along(snames)) {
698
                slotName <- el(snames, i)
698
                slotName <- snames[[i]]
699
                slotClass <- elNamed(slotDefs, slotName)
699
                slotClass <- slotDefs[[slotName]]
700
                slotClassDef <- getClassDef(slotClass, package = ClassDef@package)
700
                slotClassDef <- getClassDef(slotClass, package = ClassDef@package)
701
                slotVal <- el(elements, i)
701
                slotVal <- elements[[i]]
702
                ## perform non-strict coercion, but leave the error messages for
702
                ## perform non-strict coercion, but leave the error messages for
703
                ## values not conforming to the slot definitions to validObject(),
703
                ## values not conforming to the slot definitions to validObject(),
704
                ## hence the check = FALSE argument in the slot assignment
704
                ## hence the check = FALSE argument in the slot assignment
(-)src/library/methods/R/as.R (-1 / +1 lines)
Lines 125-131 Link Here
125
    ## be the equivalent of new("toClass", fromObject)
125
    ## be the equivalent of new("toClass", fromObject)
126
    ## But must check that replacement is defined, in the case
126
    ## But must check that replacement is defined, in the case
127
    ## of nonstandard superclass relations
127
    ## of nonstandard superclass relations
128
    replaceMethod <- elNamed(ClassDef@contains, fromClass)
128
    replaceMethod <- ClassDef@contains[[fromClass]]
129
    if(is(replaceMethod, "SClassExtension") &&
129
    if(is(replaceMethod, "SClassExtension") &&
130
       !identical(as(replaceMethod@replace, "function"), .ErrorReplace)) {
130
       !identical(as(replaceMethod@replace, "function"), .ErrorReplace)) {
131
        f <- function(from, to) NULL
131
        f <- function(from, to) NULL
(-)src/library/methods/R/is.R (-5 / +5 lines)
Lines 76-86 Link Here
76
        ext <- classDef1@contains
76
        ext <- classDef1@contains
77
        if(!identical(maybe, TRUE) && length(ext) > 0)
77
        if(!identical(maybe, TRUE) && length(ext) > 0)
78
        {
78
        {
79
            noTest <- sapply(ext, function(obj)identical(body(obj@test), TRUE))
79
            noTest <- vapply(ext, function(obj)identical(body(obj@test), TRUE), logical(1))
80
            ext <- ext[noTest]
80
            ext <- ext[noTest]
81
        }
81
        }
82
        if(fullInfo) {
82
        if(fullInfo) {
83
            elNamed(ext, class1) <- TRUE
83
            ext[[class1]] <- TRUE
84
            return(ext)
84
            return(ext)
85
        }
85
        }
86
        else
86
        else
Lines 172-178 Link Here
172
    if(!identical(ok, TRUE))
172
    if(!identical(ok, TRUE))
173
      stop(ok)
173
      stop(ok)
174
    where2 <- .findOrCopyClass(class2, classDef2, where, "subclass")
174
    where2 <- .findOrCopyClass(class2, classDef2, where, "subclass")
175
    elNamed(classDef2@subclasses, class1) <- obj
175
    classDef2@subclasses[[class1]] <- obj
176
    if(doComplete)
176
    if(doComplete)
177
        classDef2@subclasses <- completeSubclasses(classDef2, class1, obj, where)
177
        classDef2@subclasses <- completeSubclasses(classDef2, class1, obj, where)
178
    ## try to provide a valid prototype for virtual classes
178
    ## try to provide a valid prototype for virtual classes
Lines 244-250 Link Here
244
                                 paste(n2[is.na(match(n2, n1))], collapse = ", "))))
244
                                 paste(n2[is.na(match(n2, n1))], collapse = ", "))))
245
            bad <- character()
245
            bad <- character()
246
            for(what in n2)
246
            for(what in n2)
247
                if(!extends(elNamed(slots1, what), elNamed(slots2, what)))
247
                if(!extends(slots1[[what]], slots2[[what]]))
248
                    bad <- c(bad, what)
248
                    bad <- c(bad, what)
249
            if(length(bad))
249
            if(length(bad))
250
                return(c(.msg(class1, class2), ": ",
250
                return(c(.msg(class1, class2), ": ",
Lines 263-269 Link Here
263
    superclasses <- names(contains)
263
    superclasses <- names(contains)
264
    if(length(superclasses2) == 0 || length(superclasses) == 0 ||
264
    if(length(superclasses2) == 0 || length(superclasses) == 0 ||
265
       all(is.na(match(superclasses2, superclasses))))
265
       all(is.na(match(superclasses2, superclasses))))
266
      elNamed(contains, class2) <- value
266
      contains[[class2]] <- value
267
    else {
267
    else {
268
        sq <- seq_along(superclasses)
268
        sq <- seq_along(superclasses)
269
        before <- (sq[match(superclasses, superclasses2,0)>0])[[1]]
269
        before <- (sq[match(superclasses, superclasses2,0)>0])[[1]]
(-)src/library/methods/R/methodsTable.R (-5 / +5 lines)
Lines 62-68 Link Here
62
##  anyLabel <- .sigLabel(anySig)
62
##  anyLabel <- .sigLabel(anySig)
63
  newMethods <- names(newtable)
63
  newMethods <- names(newtable)
64
  for(what in newMethods) {
64
  for(what in newMethods) {
65
    obj <- get(what, envir = newtable)
65
    obj <- newtable[[what]]
66
    if(is.primitive(obj))
66
    if(is.primitive(obj))
67
      sig <- anySig
67
      sig <- anySig
68
    else if(is(obj, "MethodDefinition"))
68
    else if(is(obj, "MethodDefinition"))
Lines 103-109 Link Here
103
        signames <- generic@signature
103
        signames <- generic@signature
104
        length(signames) <- ns
104
        length(signames) <- ns
105
        .resetTable(table, ns, signames)
105
        .resetTable(table, ns, signames)
106
        assign(".SigLength", ns, envir = fenv)
106
        fenv[[".SigLength"]] <- ns
107
        n <- ns
107
        n <- ns
108
      }
108
      }
109
    }
109
    }
Lines 113-121 Link Here
113
            ## must replace in .AllMTable also
113
            ## must replace in .AllMTable also
114
            if(is.null(allTable))
114
            if(is.null(allTable))
115
                allTable <- get(".AllMTable", envir = fenv)
115
                allTable <- get(".AllMTable", envir = fenv)
116
            assign(what, obj, envir = allTable)
116
            allTable[[what]] <- obj
117
        }
117
        }
118
        assign(what, obj, envir = table)
118
        table[[what]] <- obj
119
    }
119
    }
120
    else if(exists(what, envir = table, inherits = FALSE) &&
120
    else if(exists(what, envir = table, inherits = FALSE) &&
121
            !all(obj@defined == "ANY") ) {
121
            !all(obj@defined == "ANY") ) {
Lines 148-154 Link Here
148
                objw@defined <- objw@target <- sigw
148
                objw@defined <- objw@target <- sigw
149
                remove(list = what, envir = obj)
149
                remove(list = what, envir = obj)
150
                var <- .pkgMethodLabel(objw)
150
                var <- .pkgMethodLabel(objw)
151
                if(nzchar(var)) assign(var, objw, envir = obj)
151
                if(nzchar(var)) obj[[var]] <- objw
152
            }
152
            }
153
        }
153
        }
154
    }
154
    }
(-)src/library/methods/R/oldClass.R (-3 / +3 lines)
Lines 184-194 Link Here
184
        n1 <- names(slots1)
184
        n1 <- names(slots1)
185
        bad <- character()
185
        bad <- character()
186
        for(what in n2[match(n2, n1, 0) > 0])
186
        for(what in n2[match(n2, n1, 0) > 0])
187
          if(!extends(elNamed(slots1, what), elNamed(slots2, what))) {
187
          if(!extends(slots1[[what]], slots2[[what]])) {
188
              message(gettextf("slot %s: class %s should extend class %s",
188
              message(gettextf("slot %s: class %s should extend class %s",
189
                               sQuote(what),
189
                               sQuote(what),
190
                               dQuote(elNamed(slots1, what)),
190
                               dQuote(slots1[[what]]),
191
                               dQuote(elNamed(slots2, what))),
191
                               dQuote(slots2[[what]])),
192
                      domain = NA)
192
                      domain = NA)
193
              bad <- c(bad, what)
193
              bad <- c(bad, what)
194
          }
194
          }

Return to bug 16490