/* * 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)) ); }