/* This is allowed to change 'out' */
attribute_hidden
SEXP do_copyDFattr(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
SEXP in = CAR(args), out = CADR(args);
SET_ATTRIB(out, ATTRIB(in));
IS_S4_OBJECT(in) ? SET_S4_OBJECT(out) : UNSET_S4_OBJECT(out);
SET_OBJECT(out, OBJECT(in));
return out;
}
/* oldClass<-(), primitive */
SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
check1arg(args, call, "x");
if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
if(IS_S4_OBJECT(CAR(args)))
UNSET_S4_OBJECT(CAR(args));
setAttrib(CAR(args), R_ClassSymbol, CADR(args));
SET_NAMED(CAR(args), 0);
return CAR(args);
}
/* version that does not preserve ts information, for subsetting */
void copyMostAttribNoTs(SEXP inp, SEXP ans)
{
SEXP s;
if (ans == R_NilValue)
error(_("attempt to set an attribute on NULL"));
PROTECT(ans);
PROTECT(inp);
for (s = ATTRIB(inp); s != R_NilValue; s = CDR(s)) {
if ((TAG(s) != R_NamesSymbol) &&
(TAG(s) != R_ClassSymbol) &&
(TAG(s) != R_TspSymbol) &&
(TAG(s) != R_DimSymbol) &&
(TAG(s) != R_DimNamesSymbol)) {
installAttrib(ans, TAG(s), CAR(s));
} else if (TAG(s) == R_ClassSymbol) {
SEXP cl = CAR(s);
int i;
Rboolean ists = FALSE;
for (i = 0; i < LENGTH(cl); i++)
if (strcmp(CHAR(STRING_ELT(cl, i)), "ts") == 0) { /* ASCII */
ists = TRUE;
break;
}
if (!ists) installAttrib(ans, TAG(s), cl);
else if(LENGTH(cl) <= 1) {
} else {
SEXP new_cl;
int i, j, l = LENGTH(cl);
PROTECT(new_cl = allocVector(STRSXP, l - 1));
for (i = 0, j = 0; i < l; i++)
if (strcmp(CHAR(STRING_ELT(cl, i)), "ts")) /* ASCII */
SET_STRING_ELT(new_cl, j++, STRING_ELT(cl, i));
installAttrib(ans, TAG(s), new_cl);
UNPROTECT(1);
}
}
}
SET_OBJECT(ans, OBJECT(inp));
IS_S4_OBJECT(inp) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
UNPROTECT(2);
}
void copyMostAttrib(SEXP inp, SEXP ans)
{
SEXP s;
if (ans == R_NilValue)
error(_("attempt to set an attribute on NULL"));
PROTECT(ans);
PROTECT(inp);
for (s = ATTRIB(inp); s != R_NilValue; s = CDR(s)) {
if ((TAG(s) != R_NamesSymbol) &&
(TAG(s) != R_DimSymbol) &&
(TAG(s) != R_DimNamesSymbol)) {
installAttrib(ans, TAG(s), CAR(s));
}
}
SET_OBJECT(ans, OBJECT(inp));
IS_S4_OBJECT(inp) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
UNPROTECT(2);
}
static SEXP duplicate1(SEXP s, Rboolean deep)
{
SEXP t;
R_xlen_t i, n;
duplicate1_elts++;
duplicate_elts++;
switch (TYPEOF(s)) {
case NILSXP:
case SYMSXP:
case ENVSXP:
case SPECIALSXP:
case BUILTINSXP:
case EXTPTRSXP:
case BCODESXP:
case WEAKREFSXP:
return s;
case CLOSXP:
PROTECT(s);
PROTECT(t = allocSExp(CLOSXP));
SET_FORMALS(t, FORMALS(s));
SET_BODY(t, BODY(s));
SET_CLOENV(t, CLOENV(s));
DUPLICATE_ATTRIB(t, s, deep);
if (NOJIT(s)) SET_NOJIT(t);
if (MAYBEJIT(s)) SET_MAYBEJIT(t);
UNPROTECT(2);
break;
case LISTSXP:
PROTECT(s);
t = duplicate_list(s, deep);
UNPROTECT(1);
break;
case LANGSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, LANGSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case DOTSXP:
PROTECT(s);
PROTECT(t = duplicate_list(s, deep));
SET_TYPEOF(t, DOTSXP);
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
case CHARSXP:
return s;
break;
case EXPRSXP:
case VECSXP:
n = XLENGTH(s);
PROTECT(s);
PROTECT(t = allocVector(TYPEOF(s), n));
for(i = 0 ; i < n ; i++)
SET_VECTOR_ELT(t, i, duplicate_child(VECTOR_ELT(s, i), deep));
DUPLICATE_ATTRIB(t, s, deep);
COPY_TRUELENGTH(t, s);
UNPROTECT(2);
break;
case LGLSXP: DUPLICATE_ATOMIC_VECTOR(int, LOGICAL, t, s, deep); break;
case INTSXP: DUPLICATE_ATOMIC_VECTOR(int, INTEGER, t, s, deep); break;
case REALSXP: DUPLICATE_ATOMIC_VECTOR(double, REAL, t, s, deep); break;
case CPLXSXP: DUPLICATE_ATOMIC_VECTOR(Rcomplex, COMPLEX, t, s, deep); break;
case RAWSXP: DUPLICATE_ATOMIC_VECTOR(Rbyte, RAW, t, s, deep); break;
case STRSXP:
/* direct copying and bypassing the write barrier is OK since
t was just allocated and so it cannot be older than any of
the elements in s. LT */
DUPLICATE_ATOMIC_VECTOR(SEXP, STRING_PTR, t, s, deep);
break;
case PROMSXP:
return s;
break;
case S4SXP:
PROTECT(s);
PROTECT(t = allocS4Object());
DUPLICATE_ATTRIB(t, s, deep);
UNPROTECT(2);
break;
default:
UNIMPLEMENTED_TYPE("duplicate", s);
t = s;/* for -Wall */
}
if(TYPEOF(t) == TYPEOF(s) ) { /* surely it only makes sense in this case*/
SET_OBJECT(t, OBJECT(s));
(IS_S4_OBJECT(s) ? SET_S4_OBJECT(t) : UNSET_S4_OBJECT(t));
}
return t;
}
