/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1997--2019  The R Core Team
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  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/
 */

/* This is currently restricted to vectors of length < 2^30 */

#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

#define R_USE_SIGNALS 1
#include <Defn.h>
#include <Internal.h>

#define NIL -1
#define ARGUSED(x) LEVELS(x)
#define SET_ARGUSED(x,v) SETLEVELS(x,v)

/* interval at which to check interrupts */
#define NINTERRUPT 1000000

typedef size_t hlen;

/* Hash function and equality test for keys */
typedef struct _HashData HashData;

struct _HashData {
    int K;
    hlen M;
    R_xlen_t nmax;
#ifdef LONG_VECTOR_SUPPORT
    Rboolean isLong;
#endif
    hlen (*hash)(SEXP, R_xlen_t, HashData *);
    int (*equal)(SEXP, R_xlen_t, SEXP, R_xlen_t);
    SEXP HashTable;

    int nomatch;
    Rboolean useUTF8;
    Rboolean useCache;
};

#define HTDATA_INT(d) (INTEGER0((d)->HashTable))
#define HTDATA_DBL(d) (REAL0((d)->HashTable))


/*
   Integer keys are hashed via a random number generator
   based on Knuth's recommendations.  The high order K bits
   are used as the hash code.

   NB: lots of this code relies on M being a power of two and
   on silent integer overflow mod 2^32.

   <FIXME> Integer keys are wasteful for logical and raw vectors, but
   the tables are small in that case.  It would be much easier to
   implement long vectors, though.
*/

/*  Currently the hash table is implemented as a (signed) integer
    array.  So there are two 31-bit restrictions, the length of the
    array and the values.  The values are initially NIL (-1).  O-based
    indices are inserted by isDuplicated, and invalidated by setting
    to NA_INTEGER.
*/

static hlen scatter(unsigned int key, HashData *d)
{
    return 3141592653U * key >> (32 - d->K);
}

static hlen lhash(SEXP x, R_xlen_t indx, HashData *d)
{
    int xi = LOGICAL_ELT(x, indx);
    if (xi == NA_LOGICAL) return 2U;
    return (hlen) xi;
}

static R_INLINE hlen ihash(SEXP x, R_xlen_t indx, HashData *d)
{
    int xi = INTEGER_ELT(x, indx);
    if (xi == NA_INTEGER) return 0;
    return scatter((unsigned int) xi, d);
}

/* We use unions here because Solaris gcc -O2 has trouble with
   casting + incrementing pointers.  We use tests here, but R currently
   assumes int is 4 bytes and double is 8 bytes.
 */
union foo {
    double d;
    unsigned int u[2];
};

static R_INLINE hlen rhash(SEXP x, R_xlen_t indx, HashData *d)
{
    /* There is a problem with signed 0s under IEC60559 */
    double xi = REAL_ELT(x, indx);
    double tmp = (xi == 0.0) ? 0.0 : xi;
    /* need to use both 32-byte chunks or endianness is an issue */
    /* we want all NaNs except NA equal, and all NAs equal */
    if (R_IsNA(tmp)) tmp = NA_REAL;
    else if (R_IsNaN(tmp)) tmp = R_NaN;
#if 2*SIZEOF_INT == SIZEOF_DOUBLE
    {
	union foo tmpu;
	tmpu.d = tmp;
	return scatter(tmpu.u[0] + tmpu.u[1], d);
    }
#else
    return scatter(*((unsigned int *) (&tmp)), d);
#endif
}

static Rcomplex unify_complex_na(Rcomplex z) {
    Rcomplex ans;
    ans.r = (z.r == 0.0) ? 0.0 : z.r;
    ans.i = (z.i == 0.0) ? 0.0 : z.i;
    if (R_IsNA(ans.r) || R_IsNA(ans.i))
	ans.r = ans.i = NA_REAL;
    else if (R_IsNaN(ans.r) || R_IsNaN(ans.i))
	ans.r = ans.i = R_NaN;
    return ans;
}

static hlen chash(SEXP x, R_xlen_t indx, HashData *d)
{
    Rcomplex tmp = unify_complex_na(COMPLEX_ELT(x, indx));

#if 2*SIZEOF_INT == SIZEOF_DOUBLE
    {
	unsigned int u;
	union foo tmpu;
	tmpu.d = tmp.r;
	u = tmpu.u[0] ^ tmpu.u[1];
	tmpu.d = tmp.i;
	u ^= tmpu.u[0] ^ tmpu.u[1];
	return scatter(u, d);
    }
#else
	return scatter((*((unsigned int *)(&tmp.r)) ^
			(*((unsigned int *)(&tmp.i)))), d);
#endif
}

/* Hash CHARSXP by address.  Hash values are int, For 64bit pointers,
 * we do (upper ^ lower) */
static R_INLINE hlen cshash(SEXP x, R_xlen_t indx, HashData *d)
{
    intptr_t z = (intptr_t) STRING_ELT(x, indx);
    unsigned int z1 = (unsigned int)(z & 0xffffffff), z2 = 0;
#if SIZEOF_LONG == 8
    z2 = (unsigned int)(z/0x100000000L);
#endif
    return scatter(z1 ^ z2, d);
}

static R_INLINE hlen shash(SEXP x, R_xlen_t indx, HashData *d)
{
    unsigned int k;
    const char *p;
    if(!d->useUTF8 && d->useCache) return cshash(x, indx, d);
    const void *vmax = vmaxget();
    /* Not having d->useCache really should not happen anymore. */
    p = translateCharUTF8(STRING_ELT(x, indx));
    k = 0;
    while (*p++)
	k = 11 * k + (unsigned int) *p; /* was 8 but 11 isn't a power of 2 */
    vmaxset(vmax); /* discard any memory used by translateChar */
    return scatter(k, d);
}

static int lequal(SEXP x, R_xlen_t i, SEXP y, R_xlen_t j)
{
    if (i < 0 || j < 0) return 0;
    return (LOGICAL_ELT(x, i) == LOGICAL_ELT(y, j));
}


static R_INLINE int iequal(SEXP x, R_xlen_t i, SEXP y, R_xlen_t j)
{
    if (i < 0 || j < 0) return 0;
    return (INTEGER_ELT(x, i) == INTEGER_ELT(y, j));
}

/* BDR 2002-1-17  We don't want NA and other NaNs to be equal */
static R_INLINE int requal(SEXP x, R_xlen_t i, SEXP y, R_xlen_t j)
{
    if (i < 0 || j < 0) return 0;
    double xi = REAL_ELT(x, i);
    double yj = REAL_ELT(y, j);
    if (!ISNAN(xi) && !ISNAN(yj))
	return (xi == yj);
    else if (R_IsNA(xi) && R_IsNA(yj)) return 1;
    else if (R_IsNaN(xi) && R_IsNaN(yj)) return 1;
    else return 0;
}

/* This is differentiating {NA,1}, {NA,0}, {NA, NaN}, {NA, NA},
 * but R's print() and format()  render all as "NA" */
static int cplx_eq(Rcomplex x, Rcomplex y)
{
    if (!ISNAN(x.r) && !ISNAN(x.i) && !ISNAN(y.r) && !ISNAN(y.i))
	return x.r == y.r && x.i == y.i;
    else if (R_IsNA(x.r) || R_IsNA(x.i)) // x is NA
	return (R_IsNA(y.r) || R_IsNA(y.i)) ? 1 : 0;
    else if (R_IsNA(y.r) || R_IsNA(y.i)) // y is NA but x is not
	return 0;
    // else : none is NA but there's at least one NaN;  hence  ISNAN(.) == R_IsNaN(.)
    return
	(((ISNAN(x.r) && ISNAN(y.r)) || (!ISNAN(x.r) && !ISNAN(y.r) && x.r == y.r)) && // Re
	 ((ISNAN(x.i) && ISNAN(y.i)) || (!ISNAN(x.i) && !ISNAN(y.i) && x.i == y.i))    // Im
	    ) ? 1 : 0;
}

static int cequal(SEXP x, R_xlen_t i, SEXP y, R_xlen_t j)
{
    if (i < 0 || j < 0) return 0;
    return cplx_eq(COMPLEX_ELT(x, i), COMPLEX_ELT(y, j));
}

static R_INLINE int sequal(SEXP x, R_xlen_t i, SEXP y, R_xlen_t j)
{
    if (i < 0 || j < 0) return 0;
    SEXP xi = STRING_ELT(x, i);
    SEXP yj = STRING_ELT(y, j);
    /* Two strings which have the same address must be the same,
       so avoid looking at the contents */
    if (xi == yj) return 1;
    /* Then if either is NA the other cannot be */
    /* Once all CHARSXPs are cached, Seql will handle this */
    if (xi == NA_STRING || yj == NA_STRING)
	return 0;
    /* another pre-test to avoid the call to Seql */
    if (IS_CACHED(xi) && IS_CACHED(yj) && ENC_KNOWN(xi) == ENC_KNOWN(yj))
	return 0;
    return Seql(xi, yj);
}

static hlen rawhash(SEXP x, R_xlen_t indx, HashData *d)
{
    return (hlen) RAW_ELT(x, indx);
}

static int rawequal(SEXP x, R_xlen_t i, SEXP y, R_xlen_t j)
{
    if (i < 0 || j < 0) return 0;
    return (RAW_ELT(x, i) == RAW_ELT(y, j));
}

static hlen vhash(SEXP x, R_xlen_t indx, HashData *d)
{
    int i;
    unsigned int key;
    SEXP _this = VECTOR_ELT(x, indx);

    key = OBJECT(_this) + 2*TYPEOF(_this) + 100U*(unsigned int) length(_this);
    /* maybe we should also look at attributes, but that slows us down */
    switch (TYPEOF(_this)) {
    case LGLSXP:
	/* This is not too clever: pack into 32-bits and then scatter? */
	for(i = 0; i < LENGTH(_this); i++) {
	    key ^= lhash(_this, i, d);
	    key *= 97;
	}
	break;
    case INTSXP:
	for(i = 0; i < LENGTH(_this); i++) {
	    key ^= ihash(_this, i, d);
	    key *= 97;
	}
	break;
    case REALSXP:
	for(i = 0; i < LENGTH(_this); i++) {
	    key ^= rhash(_this, i, d);
	    key *= 97;
	}
	break;
    case CPLXSXP:
	for(i = 0; i < LENGTH(_this); i++) {
	    key ^= chash(_this, i, d);
	    key *= 97;
	}
	break;
    case STRSXP:
	for(i = 0; i < LENGTH(_this); i++) {
	    key ^= shash(_this, i, d);
	    key *= 97;
	}
	break;
    case RAWSXP:
	for(i = 0; i < LENGTH(_this); i++) {
	    key ^= scatter((unsigned int)rawhash(_this, i, d), d);
	    key *= 97;
	}
	break;
    case VECSXP:
	for(i = 0; i < LENGTH(_this); i++) {
	    key ^= vhash(_this, i, d);
	    key *= 97;
	}
	break;
    default:
	break;
    }
    return scatter(key, d);
}

static int vequal(SEXP x, R_xlen_t i, SEXP y, R_xlen_t j)
{
    if (i < 0 || j < 0) return 0;
    return R_compute_identical(VECTOR_ELT(x, i), VECTOR_ELT(y, j), 0);
}

/*
  Choose M to be the smallest power of 2
  not less than 2*n and set K = log2(M).
  Need K >= 1 and hence M >= 2, and 2^M < 2^31-1, hence n <= 2^29.

  Dec 2004: modified from 4*n to 2*n, since in the worst case we have
  a 50% full table, and that is still rather efficient -- see
  R. Sedgewick (1998) Algorithms in C++ 3rd edition p.606.
*/
static void MKsetup(R_xlen_t n, HashData *d, R_xlen_t nmax)
{
#ifdef LONG_VECTOR_SUPPORT
    /* M = 2^32 is safe, hence n <= 2^31 -1 */
    if(n < 0) /* protect against overflow to -ve */
	error(_("length %d is too large for hashing"), n);
#else
    if(n < 0 || n >= 1073741824) /* protect against overflow to -ve */
	error(_("length %d is too large for hashing"), n);
#endif

    if (nmax != NA_INTEGER && nmax != 1) n = nmax;
    size_t n2 = 2U * (size_t) n;
    d->M = 2;
    d->K = 1;
    while (d->M < n2) {
	d->M *= 2;
	d->K++;
    }
    d->nmax = n;
}

#define IMAX 4294967296L
static void HashTableSetup(SEXP x, HashData *d, R_xlen_t nmax)
{
    d->useUTF8 = FALSE;
    d->useCache = TRUE;
    switch (TYPEOF(x)) {
    case LGLSXP:
	d->hash = lhash;
	d->equal = lequal;
	d->nmax = d->M = 4;
	d->K = 2; /* unused */
	break;
    case INTSXP:
    {
	d->hash = ihash;
	d->equal = iequal;
#ifdef LONG_VECTOR_SUPPORT
	R_xlen_t nn = XLENGTH(x);
	if (nn > IMAX) nn = IMAX;
	MKsetup(nn, d, nmax);
#else
	MKsetup(LENGTH(x), d, nmax);
#endif
    }
	break;
    case REALSXP:
	d->hash = rhash;
	d->equal = requal;
	MKsetup(XLENGTH(x), d, nmax);
	break;
    case CPLXSXP:
	d->hash = chash;
	d->equal = cequal;
	MKsetup(XLENGTH(x), d, nmax);
	break;
    case STRSXP:
	d->hash = shash;
	d->equal = sequal;
	MKsetup(XLENGTH(x), d, nmax);
	break;
    case RAWSXP:
	d->hash = rawhash;
	d->equal = rawequal;
	d->nmax = d->M = 256;
	d->K = 8; /* unused */
	break;
    case VECSXP:
	d->hash = vhash;
	d->equal = vequal;
	MKsetup(XLENGTH(x), d, nmax);
	break;
    default:
	UNIMPLEMENTED_TYPE("HashTableSetup", x);
    }
#ifdef LONG_VECTOR_SUPPORT
    d->isLong = IS_LONG_VEC(x);
    if (d->isLong) {
	d->HashTable = allocVector(REALSXP, (R_xlen_t) d->M);
	for (R_xlen_t i = 0; i < d->M; i++) HTDATA_DBL(d)[i] = NIL;
    } else
#endif
    {
	d->HashTable = allocVector(INTSXP, (R_xlen_t) d->M);
	for (R_xlen_t i = 0; i < d->M; i++) HTDATA_INT(d)[i] = NIL;
    }
}

/* Open address hashing */
/* Collision resolution is by linear probing */
/* The table is guaranteed large so this is sufficient */

static int isDuplicated(SEXP x, R_xlen_t indx, HashData *d)
{
#ifdef LONG_VECTOR_SUPPORT
    if (d->isLong) {
	double *h = HTDATA_DBL(d);
	hlen i = d->hash(x, indx, d);
	while (h[i] != NIL) {
	    if (d->equal(x, (R_xlen_t) h[i], x, indx))
		return h[i] >= 0 ? 1 : 0;
	    i = (i + 1) % d->M;
	}
	if (d->nmax-- < 0) error("hash table is full");
	h[i] = (double) indx;
    } else
#endif
    {
	int *h = HTDATA_INT(d);
	hlen i = d->hash(x, indx, d);
	while (h[i] != NIL) {
	    if (d->equal(x, h[i], x, indx))
		return h[i] >= 0 ? 1 : 0;
	    i = (i + 1) % d->M;
	}
	if (d->nmax-- < 0) error("hash table is full");
	h[i] = (int) indx;
    }
    return 0;
}

static void removeEntry(SEXP table, SEXP x, R_xlen_t indx, HashData *d)
{
#ifdef LONG_VECTOR_SUPPORT
    if (d->isLong) {
	double *h = HTDATA_DBL(d);
	hlen i = d->hash(x, indx, d);
	while (h[i] >= 0) {
	    if (d->equal(table, (R_xlen_t) h[i], x, indx)) {
		h[i] = NA_INTEGER;  /* < 0, only index values are inserted */
		return;
	    }
	    i = (i + 1) % d->M;
	}
    } else
#endif
    {
	int *h = HTDATA_INT(d);
	hlen i = d->hash(x, indx, d);
	while (h[i] >= 0) {
	    if (d->equal(table, h[i], x, indx)) {
		h[i] = NA_INTEGER;  /* < 0, only index values are inserted */
		return;
	    }
	    i = (i + 1) % d->M;
	}
    }
}

#define DUPLICATED_INIT						\
    HashData data;						\
    HashTableSetup(x, &data, nmax);				\
    if(TYPEOF(x) == STRSXP) {					\
	data.useUTF8 = FALSE; data.useCache = TRUE;		\
	for(i = 0; i < n; i++) {				\
	    if(IS_BYTES(STRING_ELT(x, i))) {			\
		data.useUTF8 = FALSE; break;			\
	    }							\
	    if(ENC_KNOWN(STRING_ELT(x, i))) {			\
		data.useUTF8 = TRUE;				\
	    }							\
	    if(!IS_CACHED(STRING_ELT(x, i))) {			\
		data.useCache = FALSE; break;			\
	    }							\
	}							\
    }

/* used in scan() */
SEXP duplicated(SEXP x, Rboolean from_last)
{
    SEXP ans;
    int *v, nmax = NA_INTEGER;

    if (!isVector(x)) error(_("'duplicated' applies only to vectors"));
    R_xlen_t i, n = XLENGTH(x);
    DUPLICATED_INIT;

    PROTECT(data.HashTable);
    PROTECT(ans = allocVector(LGLSXP, n));

    v = LOGICAL(ans);

    if(from_last)
	for (i = n-1; i >= 0; i--) {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    v[i] = isDuplicated(x, i, &data);
	}
    else
	for (i = 0; i < n; i++) {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    v[i] = isDuplicated(x, i, &data);
	}

    UNPROTECT(2);
    return ans;
}

static SEXP Duplicated(SEXP x, Rboolean from_last, int nmax)
{
    SEXP ans;
    int *v;

    if (!isVector(x)) error(_("'duplicated' applies only to vectors"));
    R_xlen_t i, n = XLENGTH(x);
    DUPLICATED_INIT;

    PROTECT(data.HashTable);
    PROTECT(ans = allocVector(LGLSXP, n));

    v = LOGICAL(ans);

    if(from_last)
	for (i = n-1; i >= 0; i--) {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    v[i] = isDuplicated(x, i, &data);
	}
    else
	for (i = 0; i < n; i++) {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    v[i] = isDuplicated(x, i, &data);
	}

    UNPROTECT(2);
    return ans;
}

/* simpler version of the above : return 1-based index of first, or 0 : */
R_xlen_t any_duplicated(SEXP x, Rboolean from_last)
{
    R_xlen_t result = 0;
    int nmax = NA_INTEGER;

    if (!isVector(x)) error(_("'duplicated' applies only to vectors"));
    R_xlen_t i, n = XLENGTH(x);

    DUPLICATED_INIT;
    PROTECT(data.HashTable);

    if(from_last) {
	for (i = n-1; i >= 0; i--) {
	    if(isDuplicated(x, i, &data)) { result = ++i; break; }
	}
    } else {
	for (i = 0; i < n; i++) {
	    if(isDuplicated(x, i, &data)) { result = ++i; break; }
	}
    }
    UNPROTECT(1);
    return result;
}

static SEXP duplicated3(SEXP x, SEXP incomp, Rboolean from_last, int nmax)
{
    SEXP ans;
    int *v, j, m;

    if (!isVector(x)) error(_("'duplicated' applies only to vectors"));
    R_xlen_t i, n = XLENGTH(x);
    DUPLICATED_INIT;

    PROTECT(data.HashTable);
    PROTECT(ans = allocVector(LGLSXP, n));

    v = LOGICAL(ans);

    if(from_last)
	for (i = n-1; i >= 0; i--) {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    v[i] = isDuplicated(x, i, &data);
	}
    else
	for (i = 0; i < n; i++) {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    v[i] = isDuplicated(x, i, &data);
	}

    if(length(incomp)) {
	PROTECT(incomp = coerceVector(incomp, TYPEOF(x)));
	m = length(incomp);
	for (i = 0; i < n; i++)
	    if(v[i]) {
		for(j = 0; j < m; j++)
		    if(data.equal(x, i, incomp, j)) {v[i] = 0; break;}
	    }
	UNPROTECT(1);
    }
    UNPROTECT(2);
    return ans;
}

/* return (1-based) index of first duplication, or 0 : */
R_xlen_t any_duplicated3(SEXP x, SEXP incomp, Rboolean from_last)
{
    int j, m = length(incomp), nmax = NA_INTEGER;

    if (!isVector(x)) error(_("'duplicated' applies only to vectors"));
    R_xlen_t i, n = XLENGTH(x);
    DUPLICATED_INIT;
    PROTECT(data.HashTable);

    if(!m) error(_("any_duplicated3(., <0-length incomp>)"));

    PROTECT(incomp = coerceVector(incomp, TYPEOF(x)));
    m = length(incomp);

    if(from_last)
	for (i = n-1; i >= 0; i--) {
#define IS_DUPLICATED_CHECK				\
	    if(isDuplicated(x, i, &data)) {		\
		Rboolean isDup = TRUE;			\
		for(j = 0; j < m; j++)			\
		    if(data.equal(x, i, incomp, j)) {	\
			isDup = FALSE; break;		\
		    }					\
		if(isDup) {				\
		    UNPROTECT(2);			\
		    return ++i;				\
		}					\
		/* else continue */			\
	    }
	    IS_DUPLICATED_CHECK;
	}
    else {
	for (i = 0; i < n; i++) {
	    IS_DUPLICATED_CHECK;
	}
    }

    UNPROTECT(2);
    return 0;
}

#undef IS_DUPLICATED_CHECK
#undef DUPLICATED_INIT


/* .Internal(duplicated(x))	  [op=0]
  .Internal(unique(x))		  [op=1]
   .Internal(anyDuplicated(x))	  [op=2]
*/
SEXP attribute_hidden do_duplicated(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x, incomp, dup, ans;
    int fromLast, nmax = NA_INTEGER;
    R_xlen_t i, k, n;

    checkArity(op, args);
    x = CAR(args);
    incomp = CADR(args);
    if (length(CADDR(args)) < 1)
	error(_("'fromLast' must be length 1"));
    fromLast = asLogical(CADDR(args));
    if (fromLast == NA_LOGICAL)
	error(_("'fromLast' must be TRUE or FALSE"));

    Rboolean fL = (Rboolean) fromLast;

    /* handle zero length vectors, and NULL */
    if ((n = xlength(x)) == 0)
	return(PRIMVAL(op) <= 1
	       ? allocVector(PRIMVAL(op) != 1 ? LGLSXP : TYPEOF(x), 0)
	       : ScalarInteger(0));

    if (!isVector(x)) {
	error(_("%s() applies only to vectors"),
	      (PRIMVAL(op) == 0 ? "duplicated" :
	       (PRIMVAL(op) == 1 ? "unique" : /* 2 */ "anyDuplicated")));
    }
    if (PRIMVAL(op) <= 1) {
	nmax = asInteger(CADDDR(args));
	if (nmax != NA_INTEGER && nmax <= 0)
	    error(_("'nmax' must be positive"));
    }

    if(length(incomp) && /* S has FALSE to mean empty */
       !(isLogical(incomp) && length(incomp) == 1 &&
	 LOGICAL_ELT(incomp, 0) == 0)) {
	if(PRIMVAL(op) == 2) {
	    /* return R's 1-based index :*/
	    R_xlen_t ind  = any_duplicated3(x, incomp, fL);
	    if(ind > INT_MAX) return ScalarReal((double) ind);
	    else return ScalarInteger((int)ind);
	} else
	    dup = duplicated3(x, incomp, fL, nmax);
    }
    else {
	if(PRIMVAL(op) == 2) {
	    R_xlen_t ind  = any_duplicated(x, fL);
	    if(ind > INT_MAX) return ScalarReal((double) ind);
	    else return ScalarInteger((int)ind);
	} else
	    dup = Duplicated(x, fL, nmax);
    }
    if (PRIMVAL(op) == 0) /* "duplicated()" */
	return dup;
    /*	ELSE
	use the results of "duplicated" to get "unique" */

    /* count unique entries */
    k = 0;
    for (i = 0; i < n; i++)
	if (LOGICAL_ELT(dup, i) == 0)
	    k++;

    PROTECT(dup);
    PROTECT(ans = allocVector(TYPEOF(x), k));

    k = 0;
    switch (TYPEOF(x)) {
    case LGLSXP:
	for (i = 0; i < n; i++)
	    if (LOGICAL_ELT(dup, i) == 0)
		LOGICAL0(ans)[k++] = LOGICAL_ELT(x, i);
	break;
    case INTSXP:
	for (i = 0; i < n; i++)
	    if (LOGICAL_ELT(dup, i) == 0)
		INTEGER0(ans)[k++] = INTEGER_ELT(x, i);
	break;
    case REALSXP:
	for (i = 0; i < n; i++)
	    if (LOGICAL_ELT(dup, i) == 0)
		REAL0(ans)[k++] = REAL_ELT(x, i);
	break;
    case CPLXSXP:
	for (i = 0; i < n; i++)
	    if (LOGICAL_ELT(dup, i) == 0)
		COMPLEX0(ans)[k++] = COMPLEX_ELT(x, i);
	break;
    case STRSXP:
	for (i = 0; i < n; i++)
	    if (LOGICAL_ELT(dup, i) == 0)
		SET_STRING_ELT(ans, k++, STRING_ELT(x, i));
	break;
    case VECSXP:
	for (i = 0; i < n; i++)
	    if (LOGICAL_ELT(dup, i) == 0)
		SET_VECTOR_ELT(ans, k++, VECTOR_ELT(x, i));
	break;
    case RAWSXP:
	for (i = 0; i < n; i++)
	    if (LOGICAL_ELT(dup, i) == 0)
		RAW0(ans)[k++] = RAW_ELT(x, i);
	break;
    default:
	UNIMPLEMENTED_TYPE("duplicated", x);
    }
    UNPROTECT(2);
    return ans;
}

/* Build a hash table, ignoring information on duplication */
static void DoHashing(SEXP table, HashData *d)
{
    R_xlen_t i, n = XLENGTH(table);
    for (i = 0; i < n; i++) {
//	if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	(void) isDuplicated(table, i, d);
    }
}

/* invalidate entries: normally few */
static void UndoHashing(SEXP x, SEXP table, HashData *d)
{
    for (R_xlen_t i = 0; i < XLENGTH(x); i++) removeEntry(table, x, i, d);
}

#define DEFLOOKUP(NAME, HASHFUN, EQLFUN)			\
    static R_INLINE int						\
    NAME(SEXP table, SEXP x, R_xlen_t indx, HashData *d)	\
    {								\
	int *h = HTDATA_INT(d);					\
	hlen i = HASHFUN(x, indx, d);				\
	while (h[i] != NIL) {					\
	    if (EQLFUN(table, h[i], x, indx))			\
		return h[i] >= 0 ? h[i] + 1 : d->nomatch;	\
	    i = (i + 1) % d->M;					\
	}							\
	return d->nomatch;					\
    }

/* definitions to help the C compiler to inline of most important cases */
DEFLOOKUP(iLookup, ihash, iequal)
DEFLOOKUP(rLookup, rhash, requal)
DEFLOOKUP(sLookup, shash, sequal)

/* definition for the general case */
DEFLOOKUP(Lookup, d->hash, d->equal)

/* Now do the table lookup */
static SEXP HashLookup(SEXP table, SEXP x, HashData *d)
{
    SEXP ans;
    R_xlen_t i, n;

    n = XLENGTH(x);
    PROTECT(ans = allocVector(INTSXP, n));
    int *pa = INTEGER0(ans);

    switch (TYPEOF(x)) {
    case INTSXP:
	for (i = 0; i < n; i++)
	    pa[i] = iLookup(table, x, i, d);
	break;
    case REALSXP:
	for (i = 0; i < n; i++)
	    pa[i] = rLookup(table, x, i, d);
	break;
    case STRSXP:
	for (i = 0; i < n; i++)
	    pa[i] = sLookup(table, x, i, d);
	break;
    default:
	for (i = 0; i < n; i++)
	    pa[i] = Lookup(table, x, i, d);
    }

    UNPROTECT(1);
    return ans;
}

static SEXP match_transform(SEXP s, SEXP env)
{
    if(OBJECT(s)) {
	if(inherits(s, "factor")) return asCharacterFactor(s);
	else if(inherits(s, "POSIXlt")) { /* and maybe more classes in the future:
					   * Call R's (generic)	 as.character(s) : */
	    SEXP call, r;
	    PROTECT(call = lang2(R_AsCharacterSymbol, s));
	    r = eval(call, env);
	    UNPROTECT(1);
	    return r;
	}
    }
    /* else */
    return duplicate(s);
}

// workhorse of R's match() and hence also  " ix %in% itable "
SEXP match5(SEXP itable, SEXP ix, int nmatch, SEXP incomp, SEXP env)
{
    R_xlen_t n = xlength(ix);
    /* handle zero length arguments */
    if (n == 0) return allocVector(INTSXP, 0);

    SEXP ans;
    if (length(itable) == 0) {
	ans = allocVector(INTSXP, n);
	int *pa = INTEGER0(ans);
	for (R_xlen_t i = 0; i < n; i++) pa[i] = nmatch;
	return ans;
    }

    int nprot = 0;
    SEXP x     = PROTECT(match_transform(ix,     env)); nprot++;
    SEXP table = PROTECT(match_transform(itable, env)); nprot++;
    /* or should we use PROTECT_WITH_INDEX and REPROTECT below ? */

    SEXPTYPE type;
    /* Coerce to a common type; type == NILSXP is ok here.
     * Note that above we coerce factors and "POSIXlt", only to character.
     * Hence, coerce to character or to `higher' type
     * (given that we have "Vector" or NULL) */
    if(TYPEOF(x) >= STRSXP || TYPEOF(table) >= STRSXP) type = STRSXP;
    else type = TYPEOF(x) < TYPEOF(table) ? TYPEOF(table) : TYPEOF(x);
    PROTECT(x	  = coerceVector(x,	type)); nprot++;
    PROTECT(table = coerceVector(table, type)); nprot++;

    // special case scalar x -- for speed only :
    if(XLENGTH(x) == 1 && !incomp) {
      int val = nmatch;
      int ntable = LENGTH(table);
      switch (type) {
      case STRSXP: {
	  SEXP x_val = STRING_ELT(x,0);
	  for (int i=0; i < ntable; i++) if (Seql(STRING_ELT(table,i), x_val)) {
		  val = i + 1; break;
	      }
	  break; }
      case LGLSXP:
      case INTSXP: {
	  int x_val = INTEGER_ELT(x, 0),
	      *table_p = INTEGER(table);
	  for (int i=0; i < ntable; i++) if (table_p[i] == x_val) {
		  val = i + 1; break;
	      }
	  break; }
      case REALSXP: {
	  double xv = REAL_ELT(x, 0);
	  // pblm with signed 0s under IEC60559
	  double x_val = (xv == 0.) ? 0. : xv;
	  double *table_p = REAL(table);
	  /* we want all NaNs except NA equal, and all NAs equal */
	  if (R_IsNA(x_val)) {
	      for (int i=0; i < ntable; i++) if (R_IsNA(table_p[i])) {
		      val = i + 1; break;
		  }
	  }
	  else if (R_IsNaN(x_val)) {
	      for (int i=0; i < ntable; i++) if (R_IsNaN(table_p[i])) {
		      val = i + 1; break;
		  }
	  }
	  else {
	      for (int i=0; i < ntable; i++) if (table_p[i] == x_val) {
		      val = i + 1; break;
	      }
	  }
	  break; }
      case CPLXSXP: {
	  Rcomplex x_val = COMPLEX_ELT(x, 0),
	      *table_p = COMPLEX(table);
	  for (int i=0; i < ntable; i++)
	      if (cplx_eq(table_p[i], x_val)) {
		  val = i + 1; break;
	      }
	  break; }
      case RAWSXP: {
	  Rbyte x_val = RAW_ELT(x, 0),
	      *table_p = RAW(table);
	  for (int i=0; i < ntable; i++) if (table_p[i] == x_val) {
		  val = i + 1; break;
	      }
	  break; }
      }
      PROTECT(ans = ScalarInteger(val)); nprot++;
    }
    else { // regular case
	HashData data;
	if (incomp) { PROTECT(incomp = coerceVector(incomp, type)); nprot++; }
	data.nomatch = nmatch;
	HashTableSetup(table, &data, NA_INTEGER);
	if(type == STRSXP) {
	    Rboolean useBytes = FALSE;
	    Rboolean useUTF8 = FALSE;
	    Rboolean useCache = TRUE;
	    for(R_xlen_t i = 0; i < xlength(x); i++) {
		SEXP s = STRING_ELT(x, i);
		if(IS_BYTES(s)) {
		    useBytes = TRUE;
		    useUTF8 = FALSE;
		    break;
		}
		if(ENC_KNOWN(s)) {
		    useUTF8 = TRUE;
		}
		if(!IS_CACHED(s)) {
		    useCache = FALSE;
		    break;
		}
	    }
	    if(!useBytes || useCache) {
		for(int i = 0; i < LENGTH(table); i++) {
		    SEXP s = STRING_ELT(table, i);
		    if(IS_BYTES(s)) {
			useBytes = TRUE;
			useUTF8 = FALSE;
			break;
		    }
		    if(ENC_KNOWN(s)) {
			useUTF8 = TRUE;
		    }
		    if(!IS_CACHED(s)) {
			useCache = FALSE;
			break;
		    }
		}
	    }
	    data.useUTF8 = useUTF8;
	    data.useCache = useCache;
	}
	PROTECT(data.HashTable); nprot++;
	DoHashing(table, &data);
	if (incomp) UndoHashing(incomp, table, &data);
	ans = HashLookup(table, x, &data);
    }
    UNPROTECT(nprot);
    return ans;
} // end{ match5 }

SEXP matchE(SEXP itable, SEXP ix, int nmatch, SEXP env)
{
    return match5(itable, ix, nmatch, NULL, env);
}

/* used from other code, not here: */
SEXP match(SEXP itable, SEXP ix, int nmatch)
{
    return match5(itable, ix, nmatch, NULL, R_BaseEnv);
}


// .Internal(match(x, table, nomatch, incomparables)) :
SEXP attribute_hidden do_match(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);

    if ((!isVector(CAR(args)) && !isNull(CAR(args)))
	|| (!isVector(CADR(args)) && !isNull(CADR(args))))
	error(_("'match' requires vector arguments"));

    int nomatch = asInteger(CADDR(args));
    SEXP incomp = CADDDR(args);

    if (isNull(incomp) || /* S has FALSE to mean empty */
	(length(incomp) == 1 && isLogical(incomp) &&
	 LOGICAL_ELT(incomp, 0) == 0))
	return match5(CADR(args), CAR(args), nomatch, NULL, env);
    else
	return match5(CADR(args), CAR(args), nomatch, incomp, env);
}

/* pmatch and charmatch return integer positions, so cannot be used
   for long vector tables */

/* Partial Matching of Strings */
/* Fully S Compatible version. */

/* Hmm, this was not all S compatible!	The desired behaviour is:
 * First do exact matches, and mark elements as used as they are matched
 *   unless dup_ok is true.
 * Then do partial matching, from left to right, using up the table
 *   unless dup_ok is true.  Multiple partial matches are ignored.
 * Empty strings are unmatched			      BDR 2000/2/16
 */

SEXP attribute_hidden do_pmatch(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, input, target;
    int mtch, n_target, mtch_count, dups_ok, no_match;
    size_t temp;
    int *used = NULL, *ians;
    const char **in, **tar;
    Rboolean no_dups;
    Rboolean useBytes = FALSE, useUTF8 = FALSE;

    checkArity(op, args);
    input = CAR(args);
    R_xlen_t n_input = XLENGTH(input);
    target = CADR(args);
    n_target = LENGTH(target); // not allowed to be long
    no_match = asInteger(CADDR(args));
    dups_ok = asLogical(CADDDR(args));
    if (dups_ok == NA_LOGICAL)
	error(_("invalid '%s' argument"), "duplicates.ok");
    no_dups = !dups_ok;

    if (!isString(input) || !isString(target))
	error(_("argument is not of mode character"));

    if(no_dups) {
	used = (int *) R_alloc((size_t) n_target, sizeof(int));
	for (int j = 0; j < n_target; j++) used[j] = 0;
    }

    for(R_xlen_t i = 0; i < n_input; i++) {
	if(IS_BYTES(STRING_ELT(input, i))) {
	    useBytes = TRUE;
	    useUTF8 = FALSE;
	    break;
	} else if(ENC_KNOWN(STRING_ELT(input, i))) {
	    useUTF8 = TRUE;
	}
    }
    if(!useBytes) {
	for(R_xlen_t i = 0; i < n_target; i++) {
	    if(IS_BYTES(STRING_ELT(target, i))) {
		useBytes = TRUE;
		useUTF8 = FALSE;
		break;
	    } else if(ENC_KNOWN(STRING_ELT(target, i))) {
		useUTF8 = TRUE;
	    }
	}
    }

    in = (const char **) R_alloc((size_t) n_input, sizeof(char *));
    tar = (const char **) R_alloc((size_t) n_target, sizeof(char *));
    PROTECT(ans = allocVector(INTSXP, n_input));
    ians = INTEGER0(ans);
    if(useBytes) {
	for(R_xlen_t i = 0; i < n_input; i++) {
	    in[i] = CHAR(STRING_ELT(input, i));
	    ians[i] = 0;
	}
	for(int j = 0; j < n_target; j++)
	    tar[j] = CHAR(STRING_ELT(target, j));
    }
    else if(useUTF8) {
	for(R_xlen_t i = 0; i < n_input; i++) {
	    in[i] = translateCharUTF8(STRING_ELT(input, i));
	    ians[i] = 0;
	}
	for(int j = 0; j < n_target; j++)
	    tar[j] = translateCharUTF8(STRING_ELT(target, j));
    } else {
	for(R_xlen_t i = 0; i < n_input; i++) {
	    in[i] = translateChar(STRING_ELT(input, i));
	    ians[i] = 0;
	}
	for(int j = 0; j < n_target; j++)
	    tar[j] = translateChar(STRING_ELT(target, j));
    }
    /* First pass, exact matching */
    R_xlen_t nexact = 0;
    /* Compromise when hashing used changed in 3.2.0 (PR#15697) */
    if (n_input <= 100 || n_target <= 100) {
	for (R_xlen_t i = 0; i < n_input; i++) {
	    const char *ss = in[i];
	    if (strlen(ss) == 0) continue;
	    for (int j = 0; j < n_target; j++) {
		if (no_dups && used[j]) continue;
		if (strcmp(ss, tar[j]) == 0) {
		    ians[i] = j + 1;
		    if (no_dups) used[j] = 1;
		    nexact++;
		    break;
		}
	    }
	}
    } else {
	HashData data;
	HashTableSetup(target, &data, NA_INTEGER);
	data.useUTF8 = useUTF8;
	data.nomatch = 0;
	DoHashing(target, &data);
	for (R_xlen_t i = 0; i < n_input; i++) {
	    if (strlen(in[i]) == 0) /* don't look up "" */
		continue;
	    int j = Lookup(target, input, i, &data);
	    if ((j == 0) || (no_dups && used[j - 1])) continue;
	    if (no_dups) used[j - 1] = 1;
	    ians[i] = j;
	    nexact++;
	}
    }

    if(nexact < n_input) {
	/* Second pass, partial matching */
	for (R_xlen_t i = 0; i < n_input; i++) {
	    const char *ss;
	    if (ians[i]) continue;
	    ss = in[i];
	    temp = strlen(ss);
	    if (temp == 0) continue;
	    mtch = 0;
	    mtch_count = 0;
	    for (int j = 0; j < n_target; j++) {
		if (no_dups && used[j]) continue;
		if (strncmp(ss, tar[j], temp) == 0) {
		    mtch = j + 1;
		    mtch_count++;
		}
	    }
	    if (mtch > 0 && mtch_count == 1) {
		if(no_dups) used[mtch - 1] = 1;
		ians[i] = mtch;
	    }
	}
	/* Third pass, set no matches */
	for (R_xlen_t i = 0; i < n_input; i++)
	    if(ians[i] == 0) ians[i] = no_match;

    }
    UNPROTECT(1);
    return ans;
}


/* Partial Matching of Strings */
/* Based on Therneau's charmatch. */

SEXP attribute_hidden do_charmatch(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, input, target;
    const char *ss, *st;
    Rboolean useBytes = FALSE, useUTF8 = FALSE;

    checkArity(op, args);

    input = CAR(args);
    R_xlen_t n_input = LENGTH(input);
    target = CADR(args);
    int n_target = LENGTH(target);

    if (!isString(input) || !isString(target))
	error(_("argument is not of mode character"));
    int no_match = asInteger(CADDR(args));

    for(R_xlen_t i = 0; i < n_input; i++) {
	if(IS_BYTES(STRING_ELT(input, i))) {
	    useBytes = TRUE;
	    useUTF8 = FALSE;
	    break;
	} else if(ENC_KNOWN(STRING_ELT(input, i))) {
	    useUTF8 = TRUE;
	}
    }
    if(!useBytes) {
	for(int i = 0; i < n_target; i++) {
	    if(IS_BYTES(STRING_ELT(target, i))) {
		useBytes = TRUE;
		useUTF8 = FALSE;
		break;
	    } else if(ENC_KNOWN(STRING_ELT(target, i))) {
		useUTF8 = TRUE;
	    }
	}
    }

    PROTECT(ans = allocVector(INTSXP, n_input));
    int *ians = INTEGER0(ans);

    const void *vmax = vmaxget();  // prudence: .Internal does this too.
    for(R_xlen_t i = 0; i < n_input; i++) {
	if(useBytes)
	    ss = CHAR(STRING_ELT(input, i));
	else if(useUTF8)
	    ss = translateCharUTF8(STRING_ELT(input, i));
	else
	    ss = translateChar(STRING_ELT(input, i));
	size_t temp = strlen(ss);
	int imatch = NA_INTEGER;
	Rboolean perfect = FALSE;
	/* we could reset vmax here too: worth it? */
	for(int j = 0; j < n_target; j++) {
	    if(useBytes)
		st = CHAR(STRING_ELT(target, j));
	    else if(useUTF8)
		st = translateCharUTF8(STRING_ELT(target, j));
	    else
		st = translateChar(STRING_ELT(target, j));
	    int k = strncmp(ss, st, temp);
	    if (k == 0) {
		if (strlen(st) == temp) {
		    if (perfect)
			imatch = 0;
		    else {
			perfect = TRUE;
			imatch = j + 1;
		    }
		}
		else if (!perfect) {
		    if (imatch == NA_INTEGER)
			imatch = j + 1;
		    else
			imatch = 0;
		}
	    }
	}
	ians[i] = (imatch == NA_INTEGER) ? no_match : imatch;
	vmaxset(vmax);
    }
    UNPROTECT(1);
    return ans;
}


/* Functions for matching the supplied arguments to the */
/* formal arguments of functions.  The returned value */
/* is a list with all components named. */

static SEXP StripUnmatched(SEXP s)
{
    if (s == R_NilValue) return s;

    if (CAR(s) == R_MissingArg && !ARGUSED(s) ) {
	return StripUnmatched(CDR(s));
    }
    else if (CAR(s) == R_DotsSymbol ) {
	return StripUnmatched(CDR(s));
    }
    else {
	SETCDR(s, StripUnmatched(CDR(s)));
	return s;
    }
}

static SEXP ExpandDots(SEXP s, int expdots)
{
    SEXP r;
    if (s == R_NilValue)
	return s;
    if (TYPEOF(CAR(s)) == DOTSXP ) {
	SET_TYPEOF(CAR(s), LISTSXP);	/* a safe mutation */
	if (expdots) {
	    r = CAR(s);
	    while (CDR(r) != R_NilValue ) {
		SET_ARGUSED(r, 1);
		r = CDR(r);
	    }
	    SET_ARGUSED(r, 1);
	    SETCDR(r, ExpandDots(CDR(s), expdots));
	    return CAR(s);
	}
    }
    else
	SET_ARGUSED(s, 0);
    SETCDR(s, ExpandDots(CDR(s), expdots));
    return s;
}
static SEXP subDots(SEXP rho)
{
    SEXP rval, dots, a, b, t;
    int len,i;

    dots = findVar(R_DotsSymbol, rho);

    if (dots == R_UnboundValue)
	error(_("... used in a situation where it does not exist"));

    if (dots == R_MissingArg)
	return dots;

    if (!isPairList(dots))
	error(_("... is not a pairlist"));

    len = length(dots);
    PROTECT(dots);
    PROTECT(rval=allocList(len));
    for(a = dots, b = rval, i = 1; i <= len; a = CDR(a), b = CDR(b), i++) {
	SET_TAG(b, TAG(a));
	t = CAR(a);
	while (TYPEOF(t) == PROMSXP)
	    t = PREXPR(t);
	if( isSymbol(t) || isLanguage(t) )
	    SETCAR(b, installDDVAL(i));
	else
	    SETCAR(b, t);
    }
    UNPROTECT(2);
    return rval;
}


SEXP attribute_hidden do_matchcall(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP formals, actuals, rlist;
    SEXP funcall, f, b, rval, sysp, t1, t2, tail;
//    RCNTXT *cptr;
    int expdots;

    checkArity(op,args);

    funcall = CADR(args);

    if (TYPEOF(funcall) == EXPRSXP)
	funcall = VECTOR_ELT(funcall, 0);

    if (TYPEOF(funcall) != LANGSXP)
	error(_("invalid '%s' argument"), "call");

    b = CAR(args);
    if (TYPEOF(b) != CLOSXP)
	error(_("invalid '%s' argument"), "definition");

    sysp = CAR(CDDDR(args));
    if (!isEnvironment(sysp))
	error(_("'envir' must be an environment"));

    /* Do we expand ... ? */

    expdots = asLogical(CAR(CDDR(args)));
    if (expdots == NA_LOGICAL)
	error(_("invalid '%s' argument"), "expand.dots");

    /* Get the formals and match the actual args */

    formals = FORMALS(b);
    PROTECT(actuals = shallow_duplicate(CDR(funcall)));

    /* If there is a ... symbol then expand it out in the sysp env
       We need to take some care since the ... might be in the middle
       of the actuals  */

    t2 = R_MissingArg;
    for (t1=actuals ; t1!=R_NilValue ; t1 = CDR(t1) ) {
	if (CAR(t1) == R_DotsSymbol) {
	    t2 = subDots(sysp);
	    break;
	}
    }
    /* now to splice t2 into the correct spot in actuals */
    if (t2 != R_MissingArg ) {	/* so we did something above */
	if( CAR(actuals) == R_DotsSymbol ) {
	    UNPROTECT(1);
	    actuals = listAppend(t2, CDR(actuals));
	    PROTECT(actuals);
	}
	else {
	    for(t1=actuals; t1!=R_NilValue; t1=CDR(t1)) {
		if( CADR(t1) == R_DotsSymbol ) {
		    tail = CDDR(t1);
		    SETCDR(t1, t2);
		    listAppend(actuals,tail);
		    break;
		}
	    }
	}
    } else { /* get rid of it */
	if( CAR(actuals) == R_DotsSymbol ) {
	    UNPROTECT(1);
	    actuals = CDR(actuals);
	    PROTECT(actuals);
	}
	else {
	    for(t1=actuals; t1!=R_NilValue; t1=CDR(t1)) {
		if( CADR(t1) == R_DotsSymbol ) {
		    tail = CDDR(t1);
		    SETCDR(t1, tail);
		    break;
		}
	    }
	}
    }
    rlist = matchArgs_RC(formals, actuals, call);

    /* Attach the argument names as tags */

    for (f = formals, b = rlist; b != R_NilValue; b = CDR(b), f = CDR(f)) {
	SET_TAG(b, TAG(f));
    }


    /* Handle the dots */

    PROTECT(rlist = ExpandDots(rlist, expdots));

    /* Eliminate any unmatched formals and any that match R_DotSymbol */
    /* This needs to be after ExpandDots as the DOTSXP might match ... */

    rlist = StripUnmatched(rlist);

    PROTECT(rval = allocSExp(LANGSXP));
    SETCAR(rval, lazy_duplicate(CAR(funcall)));
    SETCDR(rval, rlist);
    UNPROTECT(3);
    return rval;
}


#include <R_ext/RS.h> /* for Memzero */

#ifdef _AIX  /*some people just have to be different: is this still needed? */
#    include <memory.h>
#endif


static SEXP
rowsum(SEXP x, SEXP g, SEXP uniqueg, SEXP snarm, SEXP rn)
{
    SEXP matches,ans;
    int n, p, ng, narm;
    R_xlen_t offset = 0, offsetg = 0;
    HashData data;
    data.nomatch = 0;

    n = LENGTH(g);
    ng = length(uniqueg);
    narm = asLogical(snarm);
    if(narm == NA_LOGICAL) error("'na.rm' must be TRUE or FALSE");
    if(isMatrix(x)) p = ncols(x); else p = 1;

    HashTableSetup(uniqueg, &data, NA_INTEGER);
    PROTECT(data.HashTable);
    DoHashing(uniqueg, &data);
    PROTECT(matches = HashLookup(uniqueg, g, &data));
    int *pmatches = INTEGER(matches);

    PROTECT(ans = allocMatrix(TYPEOF(x), ng, p));

    switch(TYPEOF(x)){
    case REALSXP:
	Memzero(REAL0(ans), ng*p);
	for(int i = 0; i < p; i++) {
	    double *pa = REAL0(ans);
	    for(int j = 0; j < n; j++) {
		double xjpo = REAL_ELT(x, j + offset);
		if(!narm || !ISNAN(xjpo))
		    pa[pmatches[j] - 1 + offsetg] += xjpo;
	    }
	    offset += n;
	    offsetg += ng;
	}
	break;
    case INTSXP:
	Memzero(INTEGER0(ans), ng*p);
	for(int i = 0; i < p; i++) {
	    int *pa = INTEGER0(ans);
	    for(int j = 0; j < n; j++) {
		int xjpo = INTEGER_ELT(x, j + offset);
		if (xjpo == NA_INTEGER) {
		    if(!narm)
			pa[pmatches[j] - 1 + offsetg] = NA_INTEGER;
		} else if (pa[pmatches[j] - 1 + offsetg] != NA_INTEGER) {
		    /* check for integer overflows */
		    int itmp = pa[pmatches[j] - 1 + offsetg];
		    double dtmp = itmp;
		    dtmp += xjpo;
		    if (dtmp < INT_MIN || dtmp > INT_MAX) itmp = NA_INTEGER;
		    else itmp += xjpo;
		    pa[pmatches[j] - 1 + offsetg] = itmp;
		}
	    }
	    offset += n;
	    offsetg += ng;
	}
	break;
    default:
	error("non-numeric matrix in rowsum(): this should not happen");
    }
    if (TYPEOF(rn) != STRSXP) error("row names are not character");
    SEXP dn = allocVector(VECSXP, 2), dn2, dn3;
    setAttrib(ans, R_DimNamesSymbol, dn);
    SET_VECTOR_ELT(dn, 0, rn);
    dn2 = getAttrib(x, R_DimNamesSymbol);
    if(length(dn2) >= 2 &&
       !isNull(dn3 = VECTOR_ELT(dn2, 1))) SET_VECTOR_ELT(dn, 1, dn3);

    UNPROTECT(3); /* HashTable, matches, ans */
    return ans;
}

static SEXP
rowsum_df(SEXP x, SEXP g, SEXP uniqueg, SEXP snarm, SEXP rn)
{
    SEXP matches,ans,col,xcol;
    int p, narm;
    HashData data;
    data.nomatch = 0;

    R_xlen_t n = XLENGTH(g);
    p = LENGTH(x);
    R_xlen_t ng = XLENGTH(uniqueg);
    narm = asLogical(snarm);
    if(narm == NA_LOGICAL) error("'na.rm' must be TRUE or FALSE");

    HashTableSetup(uniqueg, &data, NA_INTEGER);
    PROTECT(data.HashTable);
    DoHashing(uniqueg, &data);
    PROTECT(matches = HashLookup(uniqueg, g, &data));
    int *pmatches = INTEGER(matches);

    PROTECT(ans = allocVector(VECSXP, p));

    for(int i = 0; i < p; i++) {
	xcol = VECTOR_ELT(x,i);
	if (!isNumeric(xcol))
	    error(_("non-numeric data frame in rowsum"));
	switch(TYPEOF(xcol)){
	case REALSXP:
	    PROTECT(col = allocVector(REALSXP,ng));
	    Memzero(REAL0(col), ng);
	    for(R_xlen_t j = 0; j < n; j++) {
		double xj = REAL_ELT(xcol, j);
		if(!narm || !ISNAN(xj))
		    REAL0(col)[pmatches[j] - 1] += xj;
	    }
	    SET_VECTOR_ELT(ans,i,col);
	    UNPROTECT(1);
	    break;
	case INTSXP:
	    PROTECT(col = allocVector(INTSXP, ng));
	    Memzero(INTEGER0(col), ng);
	    for(R_xlen_t j = 0; j < n; j++) {
		int xj = INTEGER_ELT(xcol, j);
		if (xj == NA_INTEGER) {
		    if(!narm)
			INTEGER0(col)[pmatches[j] - 1] = NA_INTEGER;
		} else if (INTEGER0(col)[pmatches[j] - 1] != NA_INTEGER) {
		    int itmp = INTEGER0(col)[pmatches[j] - 1];
		    double dtmp = itmp;
		    dtmp += xj;
		    if (dtmp < INT_MIN || dtmp > INT_MAX) itmp = NA_INTEGER;
		    else itmp += xj;
		    INTEGER0(col)[pmatches[j] - 1] = itmp;
		}
	    }
	    SET_VECTOR_ELT(ans, i, col);
	    UNPROTECT(1);
	    break;

	default:
	    error(_("this cannot happen"));
	}
    }
    namesgets(ans, getAttrib(x, R_NamesSymbol));
    if (TYPEOF(rn) != STRSXP) error("row names are not character");
    setAttrib(ans, R_RowNamesSymbol, rn);
    classgets(ans, mkString("data.frame"));

    UNPROTECT(3); /* HashTable, matches, ans */
    return ans;
}

SEXP attribute_hidden do_rowsum(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    if(PRIMVAL(op) == 1)
	return rowsum_df(CAR(args), CADR(args), CADDR(args), CADDDR(args),
			 CAD4R(args));
    else
	return rowsum(CAR(args), CADR(args), CADDR(args), CADDDR(args),
		      CAD4R(args));
}


/* returns 1-based duplicate no */
static int isDuplicated2(SEXP x, int indx, HashData *d)
{
    int *h = HTDATA_INT(d);
    hlen i = d->hash(x, indx, d);
    while (h[i] != NIL) {
	if (d->equal(x, h[i], x, indx))
	    return h[i] + 1;
	i = (i + 1) % d->M;
    }
    h[i] = indx;
    return 0;
}

static SEXP duplicated2(SEXP x, HashData *d)
{
    SEXP ans;
    int i, n;

    n = LENGTH(x);
    HashTableSetup(x, d, NA_INTEGER);
    PROTECT(d->HashTable);
    PROTECT(ans = allocVector(INTSXP, n));

    int *h = HTDATA_INT(d);
    int *v = INTEGER0(ans);
    for (i = 0; i < d->M; i++) h[i] = NIL;
    for (i = 0; i < n; i++) {
//	if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	v[i] = isDuplicated2(x, i, d);
    }
    UNPROTECT(2);
    return ans;
}

SEXP attribute_hidden do_makeunique(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP names, sep, ans, dup, newx;
    int i, cnt, *cnts, dp;
    int n, len, maxlen = 0;
    HashData data;
    const char *csep, *ss;
    const void *vmax;

    checkArity(op, args);
    names = CAR(args);
    if(!isString(names))
	error(_("'names' must be a character vector"));
    n = LENGTH(names);
    sep = CADR(args);
    if(!isString(sep) || LENGTH(sep) != 1)
	error(_("'%s' must be a character string"), "sep");
    csep = translateChar(STRING_ELT(sep, 0));
    PROTECT(ans = allocVector(STRSXP, n));
    vmax = vmaxget();
    for(i = 0; i < n; i++) {
	SET_STRING_ELT(ans, i, STRING_ELT(names, i));
	len = (int) strlen(translateChar(STRING_ELT(names, i)));
	if(len > maxlen) maxlen = len;
	vmaxset(vmax);
    }
    if(n > 1) {
	/* +2 for terminator and rounding error */
	char buf[maxlen + (int) strlen(csep)
		 + (int) (log((double)n)/log(10.0)) + 2];
	if(n < 10000) {
	    R_CheckStack2((size_t)n * sizeof(int));
	    cnts = (int *) alloca(((size_t) n) * sizeof(int));
	} else {
	    /* This is going to be slow so use expensive allocation
	       that will be recovered if interrupted. */
	    cnts = (int *) R_alloc((size_t) n,	sizeof(int));
	}
	for(i = 0; i < n; i++) cnts[i] = 1;
	data.nomatch = 0;
	PROTECT(newx = allocVector(STRSXP, 1));
	PROTECT(dup = duplicated2(names, &data));
	PROTECT(data.HashTable);
	vmax = vmaxget();
	for(i = 1; i < n; i++) { /* first cannot be a duplicate */
	    dp = INTEGER_ELT(dup, i); /* 1-based number of first occurrence */
	    if(dp == 0) continue;
	    ss = translateChar(STRING_ELT(names, i));
	    /* Try appending 1,2,3, ..., n-1 until it is not already in use */
	    for(cnt = cnts[dp - 1]; cnt < n; cnt++) {
		sprintf(buf, "%s%s%d", ss, csep, cnt);
		SET_STRING_ELT(newx, 0, mkChar(buf));
		if(Lookup(ans, newx, 0, &data) == data.nomatch) break;
	    }
	    SET_STRING_ELT(ans, i, STRING_ELT(newx, 0));
	    /* insert it */ (void) isDuplicated(ans, i, &data);
	    cnts[dp - 1] = cnt+1; /* cache the first unused cnt value */
	    vmaxset(vmax);
	}
	UNPROTECT(3);
    }
    UNPROTECT(1);
    return ans;
}

/* Use hashing to improve object.size. Here we want equal CHARSXPs,
   not equal contents. */

static int csequal(SEXP x, R_xlen_t i, SEXP y, R_xlen_t j)
{
    return STRING_ELT(x, i) == STRING_ELT(y, j);
}

static void HashTableSetup1(SEXP x, HashData *d)
{
    d->hash = cshash;
    d->equal = csequal;
#ifdef LONG_VECTOR_SUPPORT
    d->isLong = FALSE;
#endif
    MKsetup(XLENGTH(x), d, NA_INTEGER);
    d->HashTable = allocVector(INTSXP, (R_xlen_t) d->M);
    for (R_xlen_t i = 0; i < d->M; i++) HTDATA_INT(d)[i] = NIL;
}

/* used in utils */
SEXP Rf_csduplicated(SEXP x)
{
    if(TYPEOF(x) != STRSXP)
	error("C function 'csduplicated' not called on a STRSXP");
    R_xlen_t n = XLENGTH(x);
    HashData data;
    HashTableSetup1(x, &data);
    PROTECT(data.HashTable);
    SEXP ans = PROTECT(allocVector(LGLSXP, n));
    int *v = LOGICAL(ans);

    for (R_xlen_t i = 0; i < n; i++) v[i] = isDuplicated(x, i, &data);

    UNPROTECT(2);
    return ans;
}

#include <R_ext/Random.h>

// sample.int(.) --> .Internal(sample2(n, size)) :
SEXP attribute_hidden do_sample2(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    SEXP ans;
    double dn = asReal(CAR(args));
    int k = asInteger(CADR(args));
    if (!R_FINITE(dn) || dn < 0 || dn > 4.5e15 || (k > 0 && dn == 0))
	error(_("invalid first argument"));
    if (k < 0) error(_("invalid '%s' argument"), "size");
    if (k > dn/2) error("This algorithm is for size <= n/2");
    HashData data;
    GetRNGstate();
    if (dn > INT_MAX) {
	ans = PROTECT(allocVector(REALSXP, k));
	double *ry = REAL0(ans);
	HashTableSetup(ans, &data, NA_INTEGER);
	PROTECT(data.HashTable);
	for (int i = 0; i < k; i++)
	    for(int j = 0; j < 100; j++) { // average < 2
		ry[i] = R_unif_index(dn) + 1;
		if(!isDuplicated(ans, i, &data)) break;
	    }
   } else {
	ans = PROTECT(allocVector(INTSXP, k));
	int *iy = INTEGER0(ans);
	HashTableSetup(ans, &data, NA_INTEGER);
	PROTECT(data.HashTable);
	for (int i = 0; i < k; i++)
	    for(int j = 0; j < 100; j++) { // average < 2
		iy[i] = (int)(R_unif_index(dn) + 1);
		if(!isDuplicated(ans, i, &data)) break;
	    }
    }
    PutRNGstate();
    UNPROTECT(2);
    return ans;
}