cell_t *new_array(secd_t *secd, size_t size) {
/* try to allocate memory */
cell_t *mem = alloc_array(secd, size);
assert_cell(mem, "new_array: memory allocation failed");
arr_meta(mem)->as.mcons.cells = true;
return new_array_for(secd, mem);
}
inline static cell_t *drop_array(secd_t *secd, cell_t *mem) {
cell_t *meta = arr_meta(mem);
-- meta->nref;
if (0 == meta->nref) {
drop_dependencies(secd, meta);
free_array(secd, mem);
}
return SECD_NIL;
}
void free_array(secd_t *secd, cell_t *mem) {
assertv(mem <= secd->arrlist, "free_array: tried to free arrlist");
assertv(secd->arrayptr < mem, "free_array: not an array");
cell_t *meta = arr_meta(mem);
cell_t *prev = mcons_prev(meta);
assertv(meta->nref == 0, "free_array: someone seems to still use the array");
mark_free(meta, true);
if (meta != secd->arrayptr) {
if (is_array_free(secd, prev)) {
/* merge with the previous array */
cell_t *pprev = prev->as.mcons.prev;
pprev->as.mcons.next = meta;
meta->as.mcons.prev = pprev;
}
cell_t *next = mcons_next(meta);
if (is_array_free(secd, next)) {
/* merge with the next array */
cell_t *newprev = meta->as.mcons.prev;
next->as.mcons.prev = newprev;
newprev->as.mcons.next = next;
}
mark_free(meta, true);
} else {
/* move arrayptr into the array area */
prev->as.mcons.next = SECD_NIL;
secd->arrayptr = prev;
if (is_array_free(secd, prev)) {
/* at most one array after 'arr' may be free */
cell_t *pprev = prev->as.mcons.prev;
pprev->as.mcons.next = SECD_NIL;
secd->arrayptr = pprev;
}
}
memdebugf("FREE ARR[%ld]", cell_index(secd, meta));
}
cell_t *serialize_cell(secd_t *secd, cell_t *cell) {
cell_t *opt = SECD_NIL;
switch (cell_type(cell)) {
case CELL_CONS: {
cell_t *cdrc = chain_index(secd, get_cdr(cell), SECD_NIL);
opt = chain_index(secd, get_car(cell), cdrc);
}
break;
case CELL_PORT:
opt = secd_pserialize(secd, cell);
break;
case CELL_SYM:
opt = new_cons(secd, cell, SECD_NIL);
break;
case CELL_INT:
case CELL_CHAR:
opt = new_cons(secd, cell, SECD_NIL);
break;
case CELL_OP: {
cell_t *namec = new_symbol(secd, opcode_table[ cell->as.op ].name);
opt = new_cons(secd, namec, SECD_NIL);
}
break;
case CELL_FUNC:
opt = new_cons(secd, new_number(secd, (long)cell->as.ptr), SECD_NIL);
break;
case CELL_ARRMETA: {
cell_t *typec = chain_sym(secd,
(cell->as.mcons.cells ? "cell" : "byte"),
SECD_NIL);
cell_t *nextc = chain_index(secd, mcons_next(cell), typec);
opt = chain_index(secd, mcons_prev(cell), nextc);
}
break;
case CELL_FRAME: {
cell_t *ioc = chain_index(secd, cell->as.frame.io, SECD_NIL);
cell_t *nextc = chain_index(secd, cell->as.frame.cons.cdr, ioc);
opt = chain_index(secd, cell->as.frame.cons.car, nextc);
}
break;
case CELL_KONT: {
cell_t *kctrl = chain_index(secd, cell->as.kont.ctrl, SECD_NIL);
cell_t *kenv = chain_index(secd, cell->as.kont.env, kctrl);
opt = chain_index(secd, cell->as.kont.stack, kenv);
}
break;
case CELL_FREE: {
cell_t *nextc = chain_index(secd, get_cdr(cell), SECD_NIL);
opt = chain_index(secd, get_car(cell), nextc);
}
break;
case CELL_REF:
opt = chain_index(secd, cell->as.ref, SECD_NIL);
break;
case CELL_ERROR:
opt = chain_string(secd, errmsg(cell), SECD_NIL);
break;
case CELL_UNDEF:
opt = SECD_NIL;
break;
case CELL_ARRAY:
opt = chain_index(secd, arr_val(cell, -1), SECD_NIL);
break;
case CELL_STR:
case CELL_BYTES:
opt = chain_index(secd, arr_meta((cell_t *)strmem(cell)), SECD_NIL);
break;
}
opt = new_cons(secd, secd_type_sym(secd, cell), opt);
cell_t *refc = new_cons(secd, new_number(secd, cell->nref), opt);
return new_cons(secd, new_number(secd, cell - secd->begin), refc);
}
inline static cell_t *share_array(secd_t *secd, cell_t *mem) {
share_cell(secd, arr_meta(mem));
return mem;
}
