SEXP attribute_hidden do_body(SEXP call, SEXP op, SEXP args, SEXP rho)
{
checkArity(op, args);
if (TYPEOF(CAR(args)) == CLOSXP)
return duplicate(BODY_EXPR(CAR(args)));
else return R_NilValue;
}
/* 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;
}
}
