The R Project SVN R

Rev

Rev 77192 | Rev 79095 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 77192 Rev 77317
Line 1026... Line 1026...
1026 
/* This is a special .Internal */
 1026 
/* This is a special .Internal */
1027 
SEXP attribute_hidden do_bind(SEXP call, SEXP op, SEXP args, SEXP env)
 1027 
SEXP attribute_hidden do_bind(SEXP call, SEXP op, SEXP args, SEXP env)
1028 
{
 1028 
{
1029 
    SEXP a, t, obj, method, rho, ans;
 1029 
    SEXP a, t, obj, method, rho, ans;
1030 
    int mode, deparse_level;
 1030 
    int mode, deparse_level;
1031 
    Rboolean compatible = TRUE, anyS4 = FALSE;
 1031 
    Rboolean anyS4 = FALSE;
1032 
    struct BindData data;
 1032 
    struct BindData data;
1033 
    char buf[512];
 1033 
    char buf[512];
1034 
 
 1034 
 
1035 
    /* since R 2.2.0: first argument "deparse.level" */
 1035 
    /* since R 2.2.0: first argument "deparse.level" */
1036 
    deparse_level = asInteger(eval(CAR(args), env));
 1036 
    deparse_level = asInteger(eval(CAR(args), env));
Line 1054... Line 1054...
1054 
     *	  memberships from the class attribute.
 1054 
     *	  memberships from the class attribute.
1055 
     *
 1055 
     *
1056 
     * 2) We inspect each class in turn to see if there is an
 1056 
     * 2) We inspect each class in turn to see if there is an
1057 
     *	  applicable method.
 1057 
     *	  applicable method.
1058 
     *
 1058 
     *
- 
 
 1059 
     * 3) If we find a method, we use it.  Otherwise, if there was an S4
- 
 
 1060 
     *    object among the arguments, we try S4 dispatch; otherwise, we
- 
 
 1061 
     *    use the default code.
- 
 
 1062 
     *
- 
 
 1063 
     * In versions of R up to 3.6.x, we used the following rule instead:
- 
 
 1064 
     *
1059 
     * 3) If we find an applicable method we make sure that it is
 1065 
     * 3) If we find an applicable method we make sure that it is
1060 
     *	  identical to any method determined for prior arguments.
 1066 
     *	  identical to any method determined for prior arguments.
1061 
     *	  If it is identical, we proceed, otherwise we immediately
 1067 
     *	  If it is identical, we proceed, otherwise we immediately
1062 
     *	  drop through to the default code.
 1068 
     *	  drop through to the default code.
1063 
     */
 1069 
     */
1064 
 
 1070 
 
1065 
    static int force_identical_methods = -1;
 - 
 
1066 
    char *force;
 - 
 
1067 
 
 - 
 
1068 
    if(force_identical_methods == -1) {
 - 
 
1069 
	force = getenv("_R_BIND_S3_DISPATCH_FORCE_IDENTICAL_METHODS_");
 - 
 
1070 
	force_identical_methods =
 - 
 
1071 
	    ((force != NULL) && StringTrue(force)) ? 1 : 0;
 - 
 
1072 
    }
 - 
 
1073 
 
 - 
 
1074 
    PROTECT(args = promiseArgs(args, env));
 1071 
    PROTECT(args = promiseArgs(args, env));
1075 
 
 1072 
 
1076 
    const char *generic = ((PRIMVAL(op) == 1) ? "cbind" : "rbind");
 1073 
    const char *generic = ((PRIMVAL(op) == 1) ? "cbind" : "rbind");
1077 
    const char *klass = "";
 - 
 
1078 
    method = R_NilValue;
 1074 
    method = R_NilValue;
1079 
    for (a = CDR(args); a != R_NilValue; a = CDR(a)) {
 1075 
    for (a = CDR(args); a != R_NilValue && method == R_NilValue; a = CDR(a)) {
1080 
	PROTECT(obj = eval(CAR(a), env));
 1076 
	PROTECT(obj = eval(CAR(a), env));
1081 
	if (tryS4 && !anyS4 && isS4(obj)) anyS4 = TRUE;
 1077 
	if (tryS4 && !anyS4 && isS4(obj)) anyS4 = TRUE;
1082 
	if (compatible && isObject(obj)) {
 1078 
	if (isObject(obj)) {
1083 
	    SEXP classlist = PROTECT(R_data_class2(obj));
 1079 
	    SEXP classlist = PROTECT(R_data_class2(obj));
1084 
	    for (int i = 0; i < length(classlist); i++) {
 1080 
	    for (int i = 0; i < length(classlist); i++) {
1085 
		const char *s = translateChar(STRING_ELT(classlist, i));
 1081 
		const char *s = translateChar(STRING_ELT(classlist, i));
1086 
		if(strlen(generic) + strlen(s) + 2 > 512)
 1082 
		if(strlen(generic) + strlen(s) + 2 > 512)
1087 
		    error(_("class name too long in '%s'"), generic);
 1083 
		    error(_("class name too long in '%s'"), generic);
1088 
		sprintf(buf, "%s.%s", generic, s);
 1084 
		sprintf(buf, "%s.%s", generic, s);
1089 
		SEXP classmethod = R_LookupMethod(install(buf), env, env,
 1085 
		SEXP classmethod = R_LookupMethod(install(buf), env, env,
1090 
						  R_BaseNamespace);
 1086 
						  R_BaseNamespace);
1091 
		if (classmethod != R_UnboundValue) {
 1087 
		if (classmethod != R_UnboundValue) {
1092 
		    if (klass[0] == '\0') {
 - 
 
1093 
			/* There is no previous class */
 - 
 
1094 
			/* We use this method. */
 - 
 
1095 
			klass = s;
 - 
 
1096 
			method = classmethod;
 1088 
		    method = classmethod;
1097 
		    }
 - 
 
1098 
		    else {
 1089 
		    break;
1099 
			/* Check compatibility with the */
 - 
 
1100 
			/* previous class.  If the two are not */
 - 
 
1101 
			/* compatible we drop through to the */
 - 
 
1102 
			/* default method. */
 - 
 
1103 
			if (strcmp(klass, s)) {
 - 
 
1104 
			    if(force_identical_methods)
 - 
 
1105 
				method = R_NilValue;
 - 
 
1106 
			    compatible = FALSE;
 - 
 
1107 
			}
 - 
 
1108 
		    }
 - 
 
1109 
		    break; /* go to next parameter */
 - 
 
1110 
		}
 1090 
		}
1111 
	    }
 1091 
	    }
1112 
	    UNPROTECT(1);
 1092 
	    UNPROTECT(1);
1113 
	}
 1093 
	}
1114 
	UNPROTECT(1);
 1094 
	UNPROTECT(1);
1115 
    }
 1095 
    }
1116 
 
 1096 
 
1117 
    tryS4 = anyS4 && (!compatible || method == R_NilValue);
 1097 
    tryS4 = anyS4 && (method == R_NilValue);
1118 
    if (tryS4) {
 1098 
    if (tryS4) {
1119 
	// keep 'deparse.level' as first arg and *name* it:
 1099 
	// keep 'deparse.level' as first arg and *name* it:
1120 
	SET_TAG(args, install("deparse.level"));
 1100 
	SET_TAG(args, install("deparse.level"));
1121 
	// and use methods:::cbind / rbind
 1101 
	// and use methods:::cbind / rbind
1122 
	method = findFun(install(generic), R_MethodsNamespace);
 1102 
	method = findFun(install(generic), R_MethodsNamespace);