/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 2001-2016  The R Core Team
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  https://www.R-project.org/Licenses/
 */


#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <Defn.h>
/* -> Rinternals.h which exports R_compute_identical() */

/* Implementation of identical(x, y) */

/* How are  R "double"s compared : */
typedef enum {
    bit_NA__num_bit = 0,// S's default - look at bit pattern, also for NA/NaN's
    bit_NA__num_eq  = 1,// bitwise comparison for NA / NaN; '==' for other numbers
 single_NA__num_bit = 2,// one kind of NA or NaN; for num, use 'bit'comparison
 single_NA__num_eq  = 3,// one kind of NA or NaN; for num, use '==' : R's DEFAULT
} ne_strictness_type;
/* NOTE:  ne_strict = NUM_EQ + (SINGLE_NA * 2)  = NUM_EQ | (SINGLE_NA << 1)   */

static Rboolean neWithNaN(double x, double y, ne_strictness_type str);


/* .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,
	ignore_env = 0, ignore_srcref = 1, nargs = length(args), flags;
    /* avoid problems with earlier (and future) versions captured in S4
       methods: but this should be fixed where it is caused, in
       'methods'!

       checkArity(op, args); */
    if (nargs < 5)
	error("%d arguments passed to .Internal(%s) which requires %d",
	      length(args), PRIMNAME(op), PRIMARITY(op));

    SEXP x = CAR(args); args = CDR(args);
    SEXP y = CAR(args); args = CDR(args);
    num_eq = asLogical(CAR(args)); args = CDR(args);
    single_NA = asLogical(CAR(args)); args = CDR(args);
    attr_as_set = asLogical(CAR(args)); args = CDR(args);
    if (nargs >= 6)
	ignore_bytecode = asLogical(CAR(args));
    if (nargs >= 7)
	ignore_env = asLogical(CADR(args));
    if (nargs >= 8)
	ignore_srcref = asLogical(CADDR(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");
    if(ignore_env      == NA_LOGICAL) error(_("invalid '%s' value"), "ignore.environment");
    if(ignore_srcref   == NA_LOGICAL) error(_("invalid '%s' value"), "ignore.srcref");

    flags = (num_eq ? 0 : 1) + (single_NA ? 0 : 2) + (attr_as_set ? 0 : 4) +
	(ignore_bytecode ? 0 : 8) + (ignore_env ? 0 : 16) + (ignore_srcref ? 0 : 32);
    return ScalarLogical(R_compute_identical(x, y, flags));
}

#define NUM_EQ		(!(flags & 1))
#define SINGLE_NA       (!(flags & 2))
#define ATTR_AS_SET     (!(flags & 4))
#define IGNORE_BYTECODE (!(flags & 8))
#define IGNORE_ENV      (!(flags & 16))
#define IGNORE_SRCREF   (!(flags & 32))

/* 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) ||
       OBJECT(x) != OBJECT(y) ||
       IS_S4_OBJECT(x) != IS_S4_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);
    }
    if (IGNORE_SRCREF && TYPEOF(x) == CLOSXP) {
	/* Remove "srcref" attribute - and below, treat body(x), body(y) */
	SEXP x_ = PROTECT(duplicate(x)), y_ = PROTECT(duplicate(y));
	setAttrib(x_, R_SrcrefSymbol, R_NilValue);
	setAttrib(y_, R_SrcrefSymbol, R_NilValue);
	ax = ATTRIB(x_); ay = ATTRIB(y_);
	UNPROTECT(2);
    }
    else {
	ax = ATTRIB(x); ay = ATTRIB(y);
    }
    if (!ATTR_AS_SET) {
	PROTECT(ax);
	PROTECT(ay);
	Rboolean idattr = R_compute_identical(ax, ay, flags);
	UNPROTECT(2);
	if(! idattr) 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 */
	    /* ax, ay might be fresh allocations from duplicating into
	       x_, y_) above, so need to be protected from possible
	       allocations in getAttrib and recursive calls to
	       R_compute_identical in the loop. */
	    PROTECT(ax);
	    PROTECT(ay);
	    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(4); /* atrx, atry, ax, ay */
				return FALSE;
			    } else
				UNPROTECT(2); /* atrx, atry */
			} else
			    if(!R_compute_identical(CAR(elx), CAR(ely),
						    flags)) {
				UNPROTECT(2); /* ax, ay */
				return FALSE;
			    }
			break;
		    }
		if(ely == R_NilValue) {
		    UNPROTECT(2); /* ax, ay */
		    return FALSE;
		}
	    }
	    UNPROTECT(2); /* ax, ay */    
	}
    }
    switch (TYPEOF(x)) {
    case NILSXP:
	return TRUE;
    case LGLSXP:
	if (XLENGTH(x) != XLENGTH(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)LOGICAL(x), (void *)LOGICAL(y),
		      xlength(x) * sizeof(int)) == 0 ? TRUE : FALSE;
    case INTSXP:
	if (XLENGTH(x) != XLENGTH(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)INTEGER(x), (void *)INTEGER(y),
		      xlength(x) * sizeof(int)) == 0 ? TRUE : FALSE;
    case REALSXP:
    {
	R_xlen_t n = XLENGTH(x);
	if(n != XLENGTH(y)) return FALSE;
	else {
	    double *xp = REAL(x), *yp = REAL(y);
	    int ne_strict = NUM_EQ | (SINGLE_NA << 1);
	    for(R_xlen_t i = 0; i < n; i++)
		if(neWithNaN(xp[i], yp[i], ne_strict)) return FALSE;
	}
	return TRUE;
    }
    case CPLXSXP:
    {
	R_xlen_t n = XLENGTH(x);
	if(n != XLENGTH(y)) return FALSE;
	else {
	    Rcomplex *xp = COMPLEX(x), *yp = COMPLEX(y);
	    int ne_strict = NUM_EQ | (SINGLE_NA << 1);
	    for(R_xlen_t 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:
    {
	R_xlen_t i, n = XLENGTH(x);
	if(n != XLENGTH(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:
    {
	R_xlen_t i, n = XLENGTH(x);
	if(n != XLENGTH(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:
    {
	if(!R_compute_identical(FORMALS(x), FORMALS(y), flags)) return FALSE;
	if(IGNORE_BYTECODE) {
	    if(IGNORE_SRCREF) {
		SEXP x_ = PROTECT(R_body_no_src(x)),
		     y_ = PROTECT(R_body_no_src(y));
		Rboolean id_body = R_compute_identical(x_, y_, flags);
		UNPROTECT(2);
		if(!id_body) return FALSE;
	    } else if(!R_compute_identical(BODY_EXPR(x), BODY_EXPR(y), flags))
		return FALSE;
	} else { // !IGNORE_BYTECODE: use byte code for comparison of function bodies :
	    if(!R_compute_identical(BODY(x), BODY(y), flags)) return FALSE;
	}
	// now, formals and body are equal, check the enviroment(.)s:
	return (IGNORE_ENV || CLOENV(x) == CLOENV(y) ? TRUE : FALSE);
    }
    case SPECIALSXP:
    case BUILTINSXP:
	return(PRIMOFFSET(x) == PRIMOFFSET(y) ? TRUE : FALSE);
    case ENVSXP:
    case SYMSXP:
    case WEAKREFSXP: /**** is this the best approach? */
	return(x == y ? TRUE : FALSE);
    case BCODESXP:
	return R_compute_identical(BCODE_CODE(x), BCODE_CODE(y), flags) &&
	       R_compute_identical(BCODE_EXPR(x), BCODE_EXPR(y), flags) &&
	       R_compute_identical(BCODE_CONSTS(x), BCODE_CONSTS(y), flags);
    case EXTPTRSXP:
	return (EXTPTR_PTR(x) == EXTPTR_PTR(y) ? TRUE : FALSE);
    case RAWSXP:
	if (XLENGTH(x) != XLENGTH(y)) return FALSE;
	/* Use memcmp (which is ISO C90) to speed up the comparison */
	return memcmp((void *)RAW(x), (void *)RAW(y),
		      XLENGTH(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;
    }
}


/**
 * [N]ot [E]qual  (x, y)   <==>   x  "!="  y
 *  where the NA/NaN and "-0." / "+0." cases treatment depend on 'str'.
 *
 * @param x
 * @param y  the two "number"s to be compared
 * @param str a "strictness" indicator, one of 2*2 (one|bit)_NA__num_(eq|bit)
 *  "SINGLE_NA" means: x and y differ in the case
 *    that one, but not both are NaN.  Two NaN values are judged
 *    identical for this purpose, but NA != NaN
 *
 *  "NUM_EQ" means: (x != y) is used when both are not NA or NaN
 *  whereas "bit_NA" and "num_bit" use the bitwise memory comparison  memcmp();
 *  notably "*_num_bit" will differentiate '+0.' and '-0.'.
 *
 * @return FALSE or TRUE indicating if x or y differ
 */
static Rboolean neWithNaN(double x, double y, ne_strictness_type str)
{
    switch (str) {
    case single_NA__num_eq:
    case single_NA__num_bit:
	if(R_IsNA(x))
	    return(R_IsNA(y) ? FALSE : TRUE);
	if(R_IsNA(y))
	    return(R_IsNA(x) ? FALSE : TRUE);
	if(ISNAN(x))
	    return(ISNAN(y) ? FALSE : TRUE);

    case bit_NA__num_eq:
    case bit_NA__num_bit:
	; /* do nothing */
    }

    switch (str) {
    case single_NA__num_eq:
	return(x != y);
    case bit_NA__num_eq:
	if(!ISNAN(x) && !ISNAN(y))
	    return(x != y);
	else /* bitwise check for NA/NaN's */
	    return memcmp((const void *) &x,
			  (const void *) &y, sizeof(double)) ? TRUE : FALSE;
    case bit_NA__num_bit:
    case single_NA__num_bit:
	return memcmp((const void *) &x,
		      (const void *) &y, sizeof(double)) ? TRUE : FALSE;
    default: /* Wall */
	return FALSE;
    }
}