/* used in subscript.c and subassign.c */
Rboolean NonNullStringMatch(SEXP s, SEXP t)
{
/* "" or NA string matches nothing */
if (s == NA_STRING || t == NA_STRING) return FALSE;
if (CHAR(s)[0] && CHAR(t)[0] && Seql(s, t))
return TRUE;
else
return FALSE;
}
static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
Rboolean replace, SEXP rho)
{
SEXP ans, names, klass;
int i, j, n;
Rboolean matched = FALSE;
/* if X is a list, recurse. Otherwise if it matches classes call f */
if(isNewList(X)) {
n = length(X);
if (replace) {
PROTECT(ans = shallow_duplicate(X));
} else {
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(X, R_NamesSymbol);
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
}
for(i = 0; i < n; i++)
SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes,
deflt, replace, rho));
UNPROTECT(1);
return ans;
}
if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
matched = TRUE;
else {
PROTECT(klass = R_data_class(X, FALSE));
for(i = 0; i < LENGTH(klass); i++)
for(j = 0; j < length(classes); j++)
if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
matched = TRUE;
UNPROTECT(1);
}
if(matched) {
/* This stores value to which the function is to be applied in
a variable X in the environment of the rapply closure call
that calls into the rapply .Internal. */
SEXP R_fcall; /* could allocate once and preserve for re-use */
SEXP Xsym = install("X");
defineVar(Xsym, X, rho);
INCREMENT_NAMED(X);
/* PROTECT(R_fcall = lang2(FUN, Xsym)); */
PROTECT(R_fcall = lang3(FUN, Xsym, R_DotsSymbol));
ans = R_forceAndCall(R_fcall, 1, rho);
if (MAYBE_REFERENCED(ans))
ans = lazy_duplicate(ans);
UNPROTECT(1);
return(ans);
} else if(replace) return lazy_duplicate(X);
else return lazy_duplicate(deflt);
}
static SEXP do_one(SEXP X, SEXP FUN, SEXP classes, SEXP deflt,
Rboolean replace, SEXP rho)
{
SEXP ans, names, klass, R_fcall;
int i, j, n;
Rboolean matched = FALSE;
/* if X is a list, recurse. Otherwise if it matches classes call f */
if(isNewList(X)) {
n = length(X);
PROTECT(ans = allocVector(VECSXP, n));
names = getAttrib(X, R_NamesSymbol);
/* or copy attributes if replace = TRUE? */
if(!isNull(names)) setAttrib(ans, R_NamesSymbol, names);
for(i = 0; i < n; i++)
SET_VECTOR_ELT(ans, i, do_one(VECTOR_ELT(X, i), FUN, classes,
deflt, replace, rho));
UNPROTECT(1);
return ans;
}
if(strcmp(CHAR(STRING_ELT(classes, 0)), "ANY") == 0) /* ASCII */
matched = TRUE;
else {
PROTECT(klass = R_data_class(X, FALSE));
for(i = 0; i < LENGTH(klass); i++)
for(j = 0; j < length(classes); j++)
if(Seql(STRING_ELT(klass, i), STRING_ELT(classes, j)))
matched = TRUE;
UNPROTECT(1);
}
if(matched) {
/* PROTECT(R_fcall = lang2(FUN, X)); */
PROTECT(R_fcall = lang3(FUN, X, R_DotsSymbol));
ans = eval(R_fcall, rho);
if (NAMED(ans))
ans = duplicate(ans);
UNPROTECT(1);
return(ans);
} else if(replace) return duplicate(X);
else return duplicate(deflt);
}
/* do the two objects compute as identical?
Also used in unique.c */
Rboolean
R_compute_identical(SEXP x, SEXP y, int flags)
{
SEXP ax, ay, atrx, atry;
if(x == y) /* same pointer */
return TRUE;
if(TYPEOF(x) != TYPEOF(y))
return FALSE;
if(OBJECT(x) != OBJECT(y))
return FALSE;
/* Skip attribute checks for CHARSXP
-- such attributes are used for the cache. */
if(TYPEOF(x) == CHARSXP)
{
/* This matches NAs */
return Seql(x, y);
}
ax = ATTRIB(x); ay = ATTRIB(y);
if (!ATTR_AS_SET) {
if(!R_compute_identical(ax, ay, flags)) return FALSE;
}
/* Attributes are special: they should be tagged pairlists. We
don't test them if they are not, and we do not test the order
if they are.
This code is not very efficient, but then neither is using
pairlists for attributes. If long attribute lists become more
common (and they are used for S4 slots) we should store them in
a hash table.
*/
else if(ax != R_NilValue || ay != R_NilValue) {
if(ax == R_NilValue || ay == R_NilValue)
return FALSE;
if(TYPEOF(ax) != LISTSXP || TYPEOF(ay) != LISTSXP) {
warning(_("ignoring non-pairlist attributes"));
} else {
SEXP elx, ely;
if(length(ax) != length(ay)) return FALSE;
/* They are the same length and should have
unique non-empty non-NA tags */
for(elx = ax; elx != R_NilValue; elx = CDR(elx)) {
const char *tx = CHAR(PRINTNAME(TAG(elx)));
for(ely = ay; ely != R_NilValue; ely = CDR(ely))
if(streql(tx, CHAR(PRINTNAME(TAG(ely))))) {
/* We need to treat row.names specially here */
if(streql(tx, "row.names")) {
PROTECT(atrx = getAttrib(x, R_RowNamesSymbol));
PROTECT(atry = getAttrib(y, R_RowNamesSymbol));
if(!R_compute_identical(atrx, atry, flags)) {
UNPROTECT(2);
return FALSE;
} else
UNPROTECT(2);
} else
if(!R_compute_identical(CAR(elx), CAR(ely), flags))
return FALSE;
break;
}
if(ely == R_NilValue) return FALSE;
}
}
}
switch (TYPEOF(x)) {
case NILSXP:
return TRUE;
case LGLSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)LOGICAL(x), (void *)LOGICAL(y),
length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
case INTSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)INTEGER(x), (void *)INTEGER(y),
length(x) * sizeof(int)) == 0 ? TRUE : FALSE;
case REALSXP:
{
int n = length(x);
if(n != length(y)) return FALSE;
else {
double *xp = REAL(x), *yp = REAL(y);
int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
for(i = 0; i < n; i++)
if(neWithNaN(xp[i], yp[i], ne_strict)) return FALSE;
}
return TRUE;
}
case CPLXSXP:
{
int n = length(x);
if(n != length(y)) return FALSE;
else {
Rcomplex *xp = COMPLEX(x), *yp = COMPLEX(y);
int i, ne_strict = NUM_EQ | (SINGLE_NA << 1);
for(i = 0; i < n; i++)
if(neWithNaN(xp[i].r, yp[i].r, ne_strict) ||
neWithNaN(xp[i].i, yp[i].i, ne_strict))
return FALSE;
}
return TRUE;
}
case STRSXP:
{
int i, n = length(x);
if(n != length(y)) return FALSE;
for(i = 0; i < n; i++) {
/* This special-casing for NAs is not needed */
Rboolean na1 = (STRING_ELT(x, i) == NA_STRING),
na2 = (STRING_ELT(y, i) == NA_STRING);
if(na1 ^ na2) return FALSE;
if(na1 && na2) continue;
if (! Seql(STRING_ELT(x, i), STRING_ELT(y, i))) return FALSE;
}
return TRUE;
}
case CHARSXP: /* Probably unreachable, but better safe than sorry... */
{
/* This matches NAs */
return Seql(x, y);
}
case VECSXP:
case EXPRSXP:
{
int i, n = length(x);
if(n != length(y)) return FALSE;
for(i = 0; i < n; i++)
if(!R_compute_identical(VECTOR_ELT(x, i),VECTOR_ELT(y, i), flags))
return FALSE;
return TRUE;
}
case LANGSXP:
case LISTSXP:
{
while (x != R_NilValue) {
if(y == R_NilValue)
return FALSE;
if(!R_compute_identical(CAR(x), CAR(y), flags))
return FALSE;
if(!R_compute_identical(PRINTNAME(TAG(x)), PRINTNAME(TAG(y)), flags))
return FALSE;
x = CDR(x);
y = CDR(y);
}
return(y == R_NilValue);
}
case CLOSXP:
return(R_compute_identical(FORMALS(x), FORMALS(y), flags) &&
R_compute_identical(BODY_EXPR(x), BODY_EXPR(y), flags) &&
(CLOENV(x) == CLOENV(y) ? TRUE : FALSE) &&
(IGNORE_BYTECODE || R_compute_identical(BODY(x), BODY(y), flags))
);
case SPECIALSXP:
case BUILTINSXP:
return(PRIMOFFSET(x) == PRIMOFFSET(y) ? TRUE : FALSE);
case ENVSXP:
case SYMSXP:
case WEAKREFSXP:
case BCODESXP: /**** is this the best approach? */
return(x == y ? TRUE : FALSE);
case EXTPTRSXP:
return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);
case RAWSXP:
if (length(x) != length(y)) return FALSE;
/* Use memcmp (which is ISO C90) to speed up the comparison */
return memcmp((void *)RAW(x), (void *)RAW(y),
length(x) * sizeof(Rbyte)) == 0 ? TRUE : FALSE;
/* case PROMSXP: args are evaluated, so will not be seen */
/* test for equality of the substituted expression -- or should
we require both expression and environment to be identical? */
/*#define PREXPR(x) ((x)->u.promsxp.expr)
#define PRENV(x) ((x)->u.promsxp.env)
return(R_compute_identical(subsititute(PREXPR(x), PRENV(x),
flags),
subsititute(PREXPR(y), PRENV(y))));*/
case S4SXP:
/* attributes already tested, so all slots identical */
return TRUE;
default:
/* these are all supposed to be types that represent constant
entities, so no further testing required ?? */
printf("Unknown Type: %s (%x)\n", type2char(TYPEOF(x)), TYPEOF(x));
return TRUE;
}
}
