/*
* Copy an object value
*/
OBJECT *
objcopy(OBJECT *op)
{
VALUE *v1, *v2;
OBJECT *np;
int i;
i = op->o_actions->oa_count;
if (i < USUAL_ELEMENTS)
i = USUAL_ELEMENTS;
if (i == USUAL_ELEMENTS)
np = (OBJECT *) malloc(sizeof(OBJECT));
else
np = (OBJECT *) malloc(objectsize(i));
if (np == NULL) {
math_error("Cannot allocate object");
/*NOTREACHED*/
}
np->o_actions = op->o_actions;
v1 = op->o_table;
v2 = np->o_table;
for (i = op->o_actions->oa_count; i-- > 0; v1++, v2++) {
copyvalue(v1, v2);
}
return np;
}
/*
* Copy an object value
*/
OBJECT *
objcopy(OBJECT *op)
{
VALUE *v1, *v2;
OBJECT *np;
int i;
i = op->o_actions->oa_count;
if (i < USUAL_ELEMENTS)
i = USUAL_ELEMENTS;
if (i == USUAL_ELEMENTS)
np = (OBJECT *) malloc(sizeof(OBJECT));
else
np = (OBJECT *) malloc(objectsize(i));
if (np == NULL) {
math_error("Cannot allocate object");
/*NOTREACHED*/
}
np->o_actions = op->o_actions;
v1 = op->o_table;
v2 = np->o_table;
for (i = op->o_actions->oa_count; i-- > 0; v1++, v2++) {
if (v1->v_type == V_NUM) {
v2->v_num = qlink(v1->v_num);
v2->v_type = V_NUM;
} else {
copyvalue(v1, v2);
}
v2->v_subtype = V_NOSUBTYPE;
}
return np;
}
/*
* Allocate a new object structure with the specified index.
*/
OBJECT *
objalloc(long index)
{
OBJECTACTIONS *oap;
OBJECT *op;
VALUE *vp;
int i;
if (index < 0 || index > maxobjcount) {
math_error("Allocating bad object index");
/*NOTREACHED*/
}
oap = objects[index];
if (oap == NULL) {
math_error("Object type not defined");
/*NOTREACHED*/
}
i = oap->oa_count;
if (i < USUAL_ELEMENTS)
i = USUAL_ELEMENTS;
if (i == USUAL_ELEMENTS)
op = (OBJECT *) malloc(sizeof(OBJECT));
else
op = (OBJECT *) malloc(objectsize(i));
if (op == NULL) {
math_error("Cannot allocate object");
/*NOTREACHED*/
}
op->o_actions = oap;
vp = op->o_table;
for (i = oap->oa_count; i-- > 0; vp++) {
vp->v_num = qlink(&_qzero_);
vp->v_type = V_NUM;
vp->v_subtype = V_NOSUBTYPE;
}
return op;
}
static R_size_t objectsize(SEXP s)
{
R_size_t cnt = 0, vcnt = 0;
SEXP tmp, dup;
Rboolean isVec = FALSE;
switch (TYPEOF(s)) {
case NILSXP:
return(0);
break;
case SYMSXP:
break;
case LISTSXP:
case LANGSXP:
case BCODESXP:
case DOTSXP:
cnt += objectsize(TAG(s));
cnt += objectsize(CAR(s));
cnt += objectsize(CDR(s));
break;
case CLOSXP:
cnt += objectsize(FORMALS(s));
cnt += objectsize(BODY(s));
/* no charge for the environment */
break;
case ENVSXP:
R_CheckStack(); /* in case attributes might lead to a cycle */
case PROMSXP:
case SPECIALSXP:
case BUILTINSXP:
break;
case CHARSXP:
vcnt = BYTE2VEC(length(s)+1);
isVec = TRUE;
break;
case LGLSXP:
case INTSXP:
vcnt = INT2VEC(xlength(s));
isVec = TRUE;
break;
case REALSXP:
vcnt = FLOAT2VEC(xlength(s));
isVec = TRUE;
break;
case CPLXSXP:
vcnt = COMPLEX2VEC(xlength(s));
isVec = TRUE;
break;
case STRSXP:
vcnt = PTR2VEC(xlength(s));
PROTECT(dup = Rf_csduplicated(s));
for (R_xlen_t i = 0; i < xlength(s); i++) {
tmp = STRING_ELT(s, i);
if(tmp != NA_STRING && !LOGICAL(dup)[i])
cnt += objectsize(tmp);
}
isVec = TRUE;
UNPROTECT(1);
break;
case ANYSXP:
/* we don't know about these */
break;
case VECSXP:
case EXPRSXP:
case WEAKREFSXP:
/* Generic Vector Objects */
vcnt = PTR2VEC(xlength(s));
for (R_xlen_t i = 0; i < xlength(s); i++)
cnt += objectsize(VECTOR_ELT(s, i));
isVec = TRUE;
break;
case EXTPTRSXP:
cnt += sizeof(void *); /* the actual pointer */
cnt += objectsize(EXTPTR_PROT(s));
cnt += objectsize(EXTPTR_TAG(s));
break;
case RAWSXP:
vcnt = BYTE2VEC(xlength(s));
isVec = TRUE;
break;
case S4SXP:
/* Has TAG and ATRIB but no CAR nor CDR */
cnt += objectsize(TAG(s));
break;
default:
UNIMPLEMENTED_TYPE("object.size", s);
}
/* add in node space:
we need to take into account the rounding up that goes on
in the node classes. */
if(isVec) {
cnt += sizeof(SEXPREC_ALIGN);
if (vcnt > 16) cnt += 8*vcnt;
else if (vcnt > 8) cnt += 128;
else if (vcnt > 6) cnt += 64;
else if (vcnt > 4) cnt += 48;
else if (vcnt > 2) cnt += 32;
else if (vcnt > 1) cnt += 16;
else if (vcnt > 0) cnt += 8;
} else cnt += sizeof(SEXPREC);
/* add in attributes: these are fake for CHARSXPs */
if(TYPEOF(s) != CHARSXP) cnt += objectsize(ATTRIB(s));
return(cnt);
}
SEXP objectSize(SEXP x)
{
return ScalarReal( (double) objectsize(x) );
}
SEXP attribute_hidden do_objectsize(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
return ScalarReal( (double) objectsize(CAR(args)) );
}
