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

Collapse All | Expand All

(-)src/library/methods/R/RClassUtils.R (-16 / +13 lines)
Lines 965-971 Link Here
965
possibleExtends <- function(class1, class2, ClassDef1, ClassDef2)
965
possibleExtends <- function(class1, class2, ClassDef1, ClassDef2)
966
    .identC(class1, class2) || .identC(class2, "ANY")
966
    .identC(class1, class2) || .identC(class2, "ANY")
967
967
968
## "Real" definition (assigned in ./zzz.R )
969
.possibleExtends <-
968
.possibleExtends <-
970
    ## Find the information that says whether class1 extends class2,
969
    ## Find the information that says whether class1 extends class2,
971
    ## directly or indirectly.  This can be either a logical value or
970
    ## directly or indirectly.  This can be either a logical value or
Lines 976-1014 Link Here
976
{
975
{
977
    if(.identC(class1[[1L]], class2) || .identC(class2, "ANY"))
976
    if(.identC(class1[[1L]], class2) || .identC(class2, "ANY"))
978
        return(TRUE)
977
        return(TRUE)
979
    ext <- TRUE # may become a list of extends definitions
980
    if(is.null(ClassDef1)) # class1 not defined
978
    if(is.null(ClassDef1)) # class1 not defined
981
        return(FALSE)
979
        return(FALSE)
982
    ## else
983
    ext <- ClassDef1@contains
980
    ext <- ClassDef1@contains
984
    nm1 <- names(ext)
981
    nm1 <- names(ext)
985
    i <- match(class2, nm1)
982
    i <- which(nm1 == class2)
986
    if(is.na(i)) {
983
    if ( length(i) ) {
984
        return( ext[[i]] )
985
    } else if (is.null(ClassDef2)) {
986
        return(FALSE)
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
            ext <- ClassDef2@subclasses
989
            ext <- ClassDef2@subclasses
990
            ## check for a classUnion definition, not a plain "classRepresentation"
990
            ## check for a classUnion definition, not a plain "classRepresentation"
991
            if(!.identC(class(ClassDef2), "classRepresentation") &&
991
        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
992
                ## a simple TRUE iff class1 or one of its superclasses belongs to the union
994
		            i <- any(c(class1, nm1) %in% names(ext))
993
            return( any(c(class1, nm1) %in% names(ext)) )
995
            else {
994
            else {
996
                ## class1 could be multiple classes here.
995
                ## class1 could be multiple classes here.
997
                ## I think we want to know if any extend
996
                ## I think we want to know if any extend
998
                i <- match(class1, names(ext))
997
                i <- match(class1, names(ext))
999
                ii <- i[!is.na(i)]
998
                ii <- i[!is.na(i)]
1000
                i <- if(length(ii))  ii[1L] else i[1L]
999
            if(length(ii)) {
1000
               return(ext[[ ii[1L] ]])
1001
            } else {
1002
               return(FALSE)
1001
            }
1003
            }
1002
        }
1004
        }
1003
    }
1005
    }
1004
    if(is.na(i))
1005
        FALSE
1006
    else if(is.logical(i))
1007
        i
1008
    else
1009
        el(ext, i)
1010
}
1006
}
1011
1007
1008
1012
  ## complete the extends information in the class definition, by following
1009
  ## complete the extends information in the class definition, by following
1013
  ## transitive chains.
1010
  ## transitive chains.
1014
  ##
1011
  ##
(-)src/library/methods/R/is.R (-2 / +2 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
(-)src/library/methods/R/methodsTable.R (-1 / +1 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"))
(-)src/library/methods/src/methods_list_dispatch.c (-1 / +2 lines)
Lines 845-851 Link Here
845
{
845
{
846
    if(TYPEOF(e1) == STRSXP && TYPEOF(e2) == STRSXP &&
846
    if(TYPEOF(e1) == STRSXP && TYPEOF(e2) == STRSXP &&
847
       LENGTH(e1) == 1 && LENGTH(e2) == 1 &&
847
       LENGTH(e1) == 1 && LENGTH(e2) == 1 &&
848
       streql(CHAR(STRING_ELT(e1, 0)), CHAR(STRING_ELT(e2, 0))))
848
       //       streql(CHAR(STRING_ELT(e1, 0)), CHAR(STRING_ELT(e2, 0))))
849
       STRING_ELT(e1, 0) == STRING_ELT(e2, 0))
849
	return R_TRUE;
850
	return R_TRUE;
850
    else
851
    else
851
	return R_FALSE;
852
	return R_FALSE;

Return to bug 16490