/* .Internal(identical(..)) */
SEXP attribute_hidden do_identical(SEXP call, SEXP op, SEXP args, SEXP env)
{
int num_eq = 1, single_NA = 1, attr_as_set = 1, ignore_bytecode = 1, nargs = length(args), flags;
/* avoid problems with earlier (and future) versions captured in S4 methods */
/* checkArity(op, args); */
if (nargs < 5)
error("%d arguments passed to .Internal(%s) which requires %d",
length(args), PRIMNAME(op), PRIMARITY(op));
if (nargs >= 5) {
num_eq = asLogical(CADDR(args));
single_NA = asLogical(CADDDR(args));
attr_as_set = asLogical(CAD4R(args));
}
if (nargs >= 6)
ignore_bytecode = asLogical(CAD4R(CDR(args)));
if(num_eq == NA_LOGICAL) error(_("invalid '%s' value"), "num.eq");
if(single_NA == NA_LOGICAL) error(_("invalid '%s' value"), "single.NA");
if(attr_as_set == NA_LOGICAL) error(_("invalid '%s' value"), "attrib.as.set");
if(ignore_bytecode == NA_LOGICAL) error(_("invalid '%s' value"), "ignore.bytecode");
flags = (num_eq ? 0 : 1) + (single_NA ? 0 : 2) + (attr_as_set ? 0 : 4) + (ignore_bytecode ? 0 : 8);
return ScalarLogical(R_compute_identical(CAR(args), CADR(args), flags));
}
struct VALC_settings VALC_settings_vet(SEXP set_list, SEXP env) {
struct VALC_settings settings = VALC_settings_init();
R_xlen_t set_len = 16;
if(TYPEOF(set_list) == VECSXP) {
if(xlength(set_list) != set_len) {
error(
"`vet/vetr` usage error: `settings` must be a list of length %zu.",
set_len
);
}
SEXP set_names = PROTECT(getAttrib(set_list, R_NamesSymbol));
if(set_names == R_NilValue || TYPEOF(set_names) != STRSXP) {
error(
"%s%s%s", "`vet/vetr` usage error: ",
"argument `settings` must be a named list as produced ",
"by `vetr_settings`."
);
}
const char * set_names_default[] = {
"type.mode", "attr.mode", "lang.mode", "fun.mode", "rec.mode",
"suppress.warnings", "fuzzy.int.max.len",
"width", "env.depth.max", "symb.sub.depth.max", "symb.size.max",
"nchar.max", "track.hash.content.size", "env",
"result.list.size.init", "result.list.size.max"
};
SEXP set_names_def_sxp = PROTECT(allocVector(STRSXP, set_len));
for(R_xlen_t i = 0; i < set_len; ++i) {
SEXP chr_name = PROTECT(mkChar(set_names_default[i]));
SET_STRING_ELT(set_names_def_sxp, i, chr_name);
UNPROTECT(1);
}
if(!R_compute_identical(set_names, set_names_def_sxp, 16)) {
error(
"%s%s",
"`vet/vetr` usage error: argument `settings` names are not in format ",
"produced by `vetr_settings`."
);
}
set_names_def_sxp = R_NilValue;
UNPROTECT(2);
// check the scalar integers
settings.type_mode =
VALC_is_scalar_int(VECTOR_ELT(set_list, 0), "type.mode", 0, 2);
settings.attr_mode =
VALC_is_scalar_int(VECTOR_ELT(set_list, 1), "attr.mode", 0, 2);
settings.lang_mode =
VALC_is_scalar_int(VECTOR_ELT(set_list, 2), "lang.mode", 0, 2);
settings.fun_mode =
VALC_is_scalar_int(VECTOR_ELT(set_list, 3), "fun.mode", 0, 2);
settings.rec_mode =
VALC_is_scalar_int(VECTOR_ELT(set_list, 4), "rec.mode", 0, 2);
settings.fuzzy_int_max_len = VALC_is_scalar_int(
VECTOR_ELT(set_list, 6), "fuzzy.int.max.len", INT_MIN, INT_MAX
);
settings.width =
VALC_is_scalar_int(VECTOR_ELT(set_list, 7), "width", -1, INT_MAX);
settings.env_depth_max =
VALC_is_scalar_int(VECTOR_ELT(set_list, 8), "env.depth.max", -1, INT_MAX);
settings.symb_sub_depth_max = VALC_is_scalar_int(
VECTOR_ELT(set_list, 9), "symb.sub.depth.max", 0, INT_MAX
);
settings.nchar_max =
VALC_is_scalar_int(VECTOR_ELT(set_list, 10), "nchar.max", 0, INT_MAX);
settings.symb_size_max = VALC_is_scalar_int(
VECTOR_ELT(set_list, 11), "symb.size.max", 0, INT_MAX
);
settings.track_hash_content_size = VALC_is_scalar_int(
VECTOR_ELT(set_list, 12), "track.hash.content.size", 0, INT_MAX
);
// Other checks
SEXP sup_warn = VECTOR_ELT(set_list, 5);
if(
TYPEOF(sup_warn) != LGLSXP || xlength(sup_warn) != 1 ||
asInteger(sup_warn) == NA_LOGICAL
) {
error(
"%s%s",
"`vet/vetr` usage error: setting `suppress.warnings` must be TRUE ",
"or FALSE"
);
}
settings.suppress_warnings = asLogical(sup_warn);
if(
TYPEOF(VECTOR_ELT(set_list, 13)) != ENVSXP &&
VECTOR_ELT(set_list, 13) != R_NilValue
) {
error(
"%s%s",
"`ver/vetr` usage error: setting `env` must be an environment ",
"or NULL"
);
}
settings.env = VECTOR_ELT(set_list, 13);
settings.result_list_size_init = VALC_is_scalar_int(
VECTOR_ELT(set_list, 14), "result.list.size.init", 1, INT_MAX - 1
);
settings.result_list_size_max = VALC_is_scalar_int(
VECTOR_ELT(set_list, 15), "result.list.size.max", 1, INT_MAX - 1
);
} else if (set_list != R_NilValue) {
error(
"%s (is %s).",
"`vet/vetr` usage error: argument `settings` must be a list or NULL",
type2char(TYPEOF(set_list))
);
}
if(TYPEOF(env) != ENVSXP) {
error("`vet/vetr` usage error: argument `env` must be an environment.");
}
if(settings.env == R_NilValue) settings.env = env;
return settings;
}
/*
Used to construct messages like:
`names(object[[1]]$a)[1]` should be "cat" (is "rat")
an underlying assumption is that the only attributes that end up coming
here are the special ones that have accessor functions.
Note that the calling function is responsible for handling parens so as to
allow for stuff like: `names(dimnames(object))` and of subbing in the attribute
names.
*/
struct ALIKEC_res_sub ALIKEC_compare_special_char_attrs_internal(
SEXP target, SEXP current, struct ALIKEC_settings set, int strict
) {
// We're playing with fire a little with PROTECT since we're not actually
// PROTECTing the result of ALIKEC_res_msg_def in most cases to avoid
// having to keep the stack balance across all branches; in theory the code
// returns before there should be any gc happening
struct ALIKEC_res res = ALIKEC_alike_internal(target, current, set);
PROTECT(res.message);
struct ALIKEC_res_sub res_sub = ALIKEC_res_sub_def();
// Special character attributes must be alike; not sure the logic here is
// completely correct, will have to verify
if(!res.success) {
res_sub.success = 0;
res_sub.message = res.message;
} else {
// But also have constraints on values
SEXPTYPE cur_type = TYPEOF(current), tar_type = TYPEOF(target);
R_xlen_t cur_len, tar_len, i;
// should have been handled previously
if(tar_type != cur_type) error("Internal Error 266"); // nocov
else if (!(tar_len = XLENGTH(target))) {
// zero len match to anything
} else if ((cur_len = XLENGTH(current)) != tar_len) {
// should have been handled previously
error("Internal Error 268"); // nocov
} else if (tar_type == INTSXP) {
if(!R_compute_identical(target, current, 16)){
res_sub.success = 0;
res_sub.message = ALIKEC_res_msg_def(
"be", "identical to target", "", ""
);
}
} else if (tar_type == STRSXP) {
// Only determine what name is wrong if we know there is a mismatch since
// we have to loop thorugh each value. Zero length targets match anything
// unless in strict mode
if(!R_compute_identical(target, current, 16)) {
for(i = (R_xlen_t) 0; i < tar_len; i++) {
const char * cur_name_val = CHAR(STRING_ELT(current, i));
const char * tar_name_val = CHAR(STRING_ELT(target, i));
if( // check dimnames names match
(strict || tar_name_val[0]) &&
strcmp(tar_name_val, cur_name_val) != 0
) {
res_sub.success=0;
res_sub.message = PROTECT(
ALIKEC_res_msg_def(
"be",
CSR_smprintf4(
ALIKEC_MAX_CHAR, "\"%s\"", tar_name_val, "", "", ""
),
"is",
CSR_smprintf4(
ALIKEC_MAX_CHAR, "\"%s\"", cur_name_val, "", "", ""
) ) );
SEXP wrap = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(wrap, 0,
lang3(R_BracketSymbol, R_NilValue, ScalarReal(i + 1))
);
SET_VECTOR_ELT(wrap, 1, CDR(VECTOR_ELT(wrap, 0)));
SET_VECTOR_ELT(res_sub.message, 1, wrap);
UNPROTECT(2);
break;
} } }
} else {
// nocov start
error("Internal Error in compare_special_char_attrs; contact maintainer");
// nocov end
}
}
UNPROTECT(1);
return res_sub;
}
/* 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;
}
}
