void secd_print_env(secd_t *secd) {
cell_t *env = secd->env;
int i = 0;
secd_printf(secd, ";;Environment:\n");
while (not_nil(env)) {
secd_printf(secd, ";; Frame #%d:\n", i++);
cell_t *frame = get_car(env);
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
while (not_nil(symlist)) {
if (is_symbol(symlist)) {
secd_printf(secd, ";; . %s\t=>\t", symname(symlist));
dbg_print_cell(secd, vallist);
break;
}
cell_t *sym = get_car(symlist);
cell_t *val = get_car(vallist);
if (!is_symbol(sym)) {
errorf("print_env: not a symbol at *%p in symlist\n", sym);
dbg_printc(secd, sym);
}
secd_printf(secd, ";; %s\t=>\t", symname(sym));
dbg_print_cell(secd, val);
symlist = list_next(secd, symlist);
vallist = list_next(secd, vallist);
}
env = list_next(secd, env);
}
}
cell_t *lookup_env(secd_t *secd, const char *symbol, cell_t **symc) {
cell_t *env = secd->env;
assert(cell_type(env) == CELL_CONS,
"lookup_env: environment is not a list");
cell_t *res = lookup_fake_variables(secd, symbol);
if (not_nil(res))
return res;
hash_t symh = secd_strhash(symbol);
while (not_nil(env)) { // walk through frames
cell_t *frame = get_car(env);
if (is_nil(frame)) {
/* skip omega-frame */
env = list_next(secd, env);
continue;
}
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
while (not_nil(symlist)) { // walk through symbols
if (is_symbol(symlist)) {
if (symh == symhash(symlist) && str_eq(symbol, symname(symlist))) {
if (symc != NULL) *symc = symlist;
return vallist;
}
break;
}
cell_t *curc = get_car(symlist);
assert(is_symbol(curc),
"lookup_env: variable at [%ld] is not a symbol\n",
cell_index(secd, curc));
if (symh == symhash(curc) && str_eq(symbol, symname(curc))) {
if (symc != NULL) *symc = curc;
return get_car(vallist);
}
symlist = list_next(secd, symlist);
vallist = list_next(secd, vallist);
}
env = list_next(secd, env);
}
//errorf(";; error in lookup_env(): %s not found\n", symbol);
return new_error(secd, SECD_NIL, "Lookup failed for: '%s'", symbol);
}
void push_free(secd_t *secd, cell_t *c) {
assertv(c, "push_free(NULL)");
assertv(c->nref == 0,
"push_free: [%ld]->nref is %ld\n", cell_index(secd, c), (long)c->nref);
assertv(c < secd->fixedptr, "push_free: Trying to free array cell");
if (c + 1 < secd->fixedptr) {
/* just add the cell to the list secd->free */
c->type = CELL_FREE;
c->as.cons.car = SECD_NIL;
c->as.cons.cdr = secd->free;
if (not_nil(secd->free))
secd->free->as.cons.car = c;
secd->free = c;
++secd->free_cells;
memdebugf("FREE[%ld], %zd free\n",
cell_index(secd, c), secd->free_cells);
} else {
memdebugf("FREE[%ld] --\n", cell_index(secd, c));
--c;
while (c->type == CELL_FREE) {
/* it is a cell adjacent to the free space */
if (c != secd->free) {
cell_t *prev = c->as.cons.car;
cell_t *next = c->as.cons.cdr;
if (not_nil(prev)) {
prev->as.cons.cdr = next;
}
if (not_nil(next)) {
next->as.cons.car = prev;
}
} else {
cell_t *next = c->as.cons.cdr;
if (not_nil(next))
next->as.cons.car = SECD_NIL;
secd->free = next;
}
memdebugf("FREE[%ld] --\n", cell_index(secd, c));
--c;
--secd->free_cells;
}
secd->fixedptr = c + 1;
}
}
static cell_t *read_bytevector(secd_parser_t *p) {
secd_t *secd = p->secd;
assert(p->token == '(', "read_bytevector: '(' expected");
cell_t *tmplist = SECD_NIL;
cell_t *cur;
size_t len = 0;
while (lexnext(p) == TOK_NUM) {
assert((0 <= p->numtok) && (p->numtok < 256),
"read_bytevector: out of range");
cell_t *newc = new_cons(secd, new_number(secd, p->numtok), SECD_NIL);
if (not_nil(tmplist)) {
cur->as.cons.cdr = share_cell(secd, newc);
cur = newc;
} else {
tmplist = cur = newc;
}
++len;
}
cell_t *bvect = new_bytevector_of_size(secd, len);
assert_cell(bvect, "read_bytevector: failed to allocate");
unsigned char *mem = (unsigned char *)strmem(bvect);
cur = tmplist;
size_t i;
for (i = 0; i < len; ++i) {
mem[i] = (unsigned char)numval(list_head(cur));
cur = list_next(secd, cur);
}
free_cell(secd, tmplist);
return bvect;
}
cell_t *pop_free(secd_t *secd) {
cell_t *cell;
if (not_nil(secd->free)) {
/* take a cell from the list */
cell = secd->free;
secd->free = get_cdr(secd->free);
if (secd->free)
secd->free->as.cons.car = SECD_NIL;
memdebugf("NEW [%ld]\n", cell_index(secd, cell));
-- secd->free_cells;
} else {
assert(secd->free_cells == 0,
"pop_free: free=NIL when nfree=%zd\n", secd->free_cells);
/* move fixedptr */
if (secd->fixedptr >= secd->arrayptr)
return &secd_out_of_memory;
cell = secd->fixedptr;
++ secd->fixedptr;
memdebugf("NEW [%ld] ++\n", cell_index(secd, cell));
}
cell->type = CELL_UNDEF;
cell->nref = 0;
return cell;
}
/* check arity;
* possibly rewrite dot-lists into regular arguments;
* look for overriden *stdin*|*stdout* */
static cell_t *
walk_through_arguments(secd_t *secd, cell_t *frame, cell_t **args_io) {
cell_t *symlist = get_car(frame);
cell_t *vallist = get_cdr(frame);
size_t valcount = 0;
while (not_nil(symlist)) {
if (is_symbol(symlist)) {
break;
}
if (is_nil(vallist)) {
errorf(";; arity mismatch: %zd argument(s) is not enough\n", valcount);
return new_error(secd, SECD_NIL,
"arity mismatch: %zd argument(s) is not enough", valcount);
}
cell_t *sym = get_car(symlist);
check_io_args(secd, sym, get_car(vallist), args_io);
cell_t *nextsyms = list_next(secd, symlist);
cell_t *nextvals = list_next(secd, vallist);
++valcount;
symlist = nextsyms;
vallist = nextvals;
}
return SECD_NIL;
}
cell_t *sexp_parse(secd_t *secd, cell_t *port) {
cell_t *prevport = SECD_NIL;
if (not_nil(port)) {
assert(cell_type(port) == CELL_PORT, "sexp_parse: not a port");
prevport = secd->input_port; // share_cell, drop_cell
secd->input_port = share_cell(secd, port);
}
secd_parser_t p;
init_parser(secd, &p);
cell_t *res = sexp_read(secd, &p);
if (not_nil(prevport)) {
secd->input_port = prevport; //share_cell back
drop_cell(secd, port);
}
return res;
}
void print_array_layout(secd_t *secd) {
errorf(";; Array heap layout:\n");
errorf(";; arrayptr = %ld\n", cell_index(secd, secd->arrayptr));
errorf(";; arrlist = %ld\n", cell_index(secd, secd->arrlist));
errorf(";; Array list is:\n");
cell_t *cur = secd->arrlist;
while (not_nil(mcons_next(cur))) {
cur = mcons_next(cur);
errorf(";; %ld\t%ld (size=%zd,\t%s)\n", cell_index(secd, cur),
cell_index(secd, mcons_prev(cur)), arrmeta_size(secd, cur),
(is_array_free(secd, cur)? "free" : "used"));
}
}
void dbg_print_list(secd_t *secd, cell_t *list) {
printf(" -= ");
while (not_nil(list)) {
assertv(is_cons(list),
"Not a cons at [%ld]\n", cell_index(secd, list));
printf("[%ld]:%ld\t",
cell_index(secd, list),
cell_index(secd, get_car(list)));
dbg_print_cell(secd, get_car(list));
printf(" -> ");
list = list_next(secd, list);
}
printf("NIL\n");
}
/* Deallocation */
cell_t *drop_dependencies(secd_t *secd, cell_t *c) {
enum cell_type t = cell_type(c);
switch (t) {
case CELL_SYM:
if (c->as.sym.size != DONT_FREE_THIS)
free((char *)c->as.sym.data);
/* TODO: this silently ignores symbol memory corruption */
c->as.sym.size = DONT_FREE_THIS;
break;
case CELL_FRAME:
drop_cell(secd, c->as.frame.io);
// fall through
case CELL_CONS:
if (not_nil(c)) {
drop_cell(secd, get_car(c));
drop_cell(secd, get_cdr(c));
}
break;
case CELL_STR:
case CELL_ARRAY:
drop_array(secd, arr_mem(c));
break;
case CELL_REF:
drop_cell(secd, c->as.ref);
break;
case CELL_PORT:
secd_pclose(secd, c);
break;
case CELL_ARRMETA:
if (c->as.mcons.cells) {
size_t size = arrmeta_size(secd, c);
size_t i;
/* free the items */
for (i = 0; i < size; ++i) {
/* don't free uninitialized */
cell_t *ith = meta_mem(c) + i;
if (cell_type(ith) != CELL_UNDEF)
drop_dependencies(secd, ith);
}
}
break;
case CELL_INT: case CELL_FUNC: case CELL_OP:
case CELL_ERROR: case CELL_UNDEF:
return c;
default:
return new_error(secd, "drop_dependencies: unknown cell_type 0x%x", t);
}
return c;
}
static void sexp_print_list(secd_t *secd, cell_t *port, const cell_t *cell) {
secd_pprintf(secd, port, "(");
const cell_t *iter = cell;
while (not_nil(iter)) {
if (iter != cell) secd_pprintf(secd, port, " ");
if (cell_type(iter) != CELL_CONS) {
secd_pprintf(secd, port, ". ");
sexp_pprint(secd, port, iter); break;
}
cell_t *head = get_car(iter);
sexp_pprint(secd, port, head);
iter = list_next(secd, iter);
}
secd_pprintf(secd, port, ") ");
}
cell_t *make_native_frame(secd_t *secd,
const native_binding_t *binding)
{
int i;
cell_t *symlist = SECD_NIL;
cell_t *vallist = SECD_NIL;
for (i = 0; binding[i].name; ++i) {
cell_t *sym = new_symbol(secd, binding[i].name);
cell_t *val = new_const_clone(secd, binding[i].val);
if (not_nil(val))
sym->nref = val->nref = DONT_FREE_THIS;
symlist = new_cons(secd, sym, symlist);
vallist = new_cons(secd, val, vallist);
}
return new_frame(secd, symlist, vallist);
}
cell_t *alloc_array(secd_t *secd, size_t size) {
/* look through the list of arrays */
cell_t *cur = secd->arrlist;
while (not_nil(mcons_next(cur))) {
if (is_array_free(secd, cur)) {
size_t cursize = arrmeta_size(secd, cur);
if (cursize >= size) {
/* allocate this gap */
if (cursize > size + 1) {
/* make a free gap after */
cell_t *newmeta = cur + size + 1;
cell_t *prevmeta = mcons_prev(cur);
init_meta(secd, newmeta, prevmeta, cur);
cur->as.mcons.prev = newmeta;
prevmeta->as.mcons.next = newmeta;
mark_free(newmeta, true);
}
mark_free(cur, false);
return meta_mem(cur);
}
}
cur = mcons_next(cur);
}
/* no chunks of sufficient size found, move secd->arrayptr */
if (secd->arrayptr - secd->fixedptr <= (int)size)
return &secd_out_of_memory;
/* create new metadata cons at arrayptr - size - 1 */
cell_t *oldmeta = secd->arrayptr;
cell_t *meta = oldmeta - size - 1;
init_meta(secd, meta, oldmeta, SECD_NIL);
oldmeta->as.mcons.next = meta;
secd->arrayptr = meta;
memdebugf("NEW ARR[%ld], size %zd\n", cell_index(secd, meta), size);
mark_free(meta, false);
return meta_mem(meta);
}
static bool about_to_halt(secd_t *secd, int opind, cell_t **ret) {
switch (opind) {
case SECD_STOP:
*ret = SECD_NIL;
return true;
case SECD_RTN:
if (not_nil(secd->dump) && is_nil(get_car(secd->dump))) {
pop_dump(secd);
/* return into native code */
if (is_nil(secd->stack)) {
*ret = new_error(secd, SECD_NIL,
"secd_run: No value on stack to return");
} else {
*ret = list_head(secd->stack);
}
return true;
}
}
return false;
}
AnimalExport ann_img *
exact_propagation(Img *image, ImgPUInt32 *label, list *seed, char side)
{
char *fname="exact_propagation";
SEDR *sedr;
int maxrad, r, c, prev_col, n, rw, cl, i, j,
x, y, *pt, *pi, *pf, *lut, d, cp;
unsigned maxdist, k, pos;
int *p; /* @@@ perhaps a register variable is faster */
ImgPUInt32 *lbl_img, *dist, *pred;
puint32 *lbl_data, *dist_data, *pred_data;
pixval *img_data;
Img *img;
list_ptr ptr;
ann_img *aimg;
r = image->rows; c = image->cols;
/* estimate the maximum distance to grow */
if (side != INTERIOR)
maxrad = ceil(hypot(r,c));
else {
maxrad = (int) (ceil((float)MIN(r,c)/2));
for (n=0,i=0; i<r*c; i++)
n += (image->data[i] == FG);
maxrad = MIN(maxrad,(int) ceil(sqrt((double)n) / 2));
}
sedr = grow_sedr(maxrad);
if (!sedr) {
animal_err_register (fname, ANIMAL_ERROR_FAILURE,"");
return NULL;
}
img = impad(image, maxrad, maxrad, 0);
img_data = img->data;
prev_col = c;
r = img->rows; c = img->cols;
n=r*c;
dist = new_img_puint32(r,c);
dist_data = dist->data;
lut = dist->lut; /* table for (r,c) indexing */
lbl_img = impad_puint32(label, maxrad, maxrad, 0);
lbl_data = lbl_img->data;
pred = new_img_puint32(r,c);
pred_data = pred->data;
/*
We must mark as INVALID_DIST only those pixels that _will_ be
processed by the propagation.
*/
switch (side) {
case INTERIOR:
for (i=0; i<n; i++) {
pred_data[i] = prev_col*(i/c-maxrad) + i%c - maxrad;
if (img_data[i] == FG && lbl_data[i] == 0) /* (**) */
dist_data[i] = INVALID_DIST;
}
/* OBS: condition (**) tests for lbl_data[i] == 0 because the
* seed pixels don't need processing. In fact, the for loop
* for the propagation starts at i=1 (distance =1), not i=0
* (distance == 0). */
break;
case EXTERIOR:
for (i=0; i<n; i++) {
pred_data[i] = prev_col*(i/c-maxrad) + i%c - maxrad;
if (img_data[i] == BG)
dist_data[i] = INVALID_DIST;
}
break;
case BOTH:
for (i=0; i<n; i++) {
pred_data[i] = prev_col*(i/c-maxrad) + i%c - maxrad;
if (lbl_data[i] == 0)
dist_data[i] = INVALID_DIST;
}
break;
default:
ANIMAL_ERR_FIRST("exact_propagation", ANIMAL_ERROR_FAILURE, "Invalid side parameter", NULL);
}
maxdist = (unsigned) maxrad*maxrad;
/* -- distances >= 1 -- */
pt = sedr->pt;
p = pt+2;
for (i=1; i < (int)sedr->length && maxdist >= sedr->sqrd_dist[i]; i++) {
d = (int)sedr->sqrd_dist[i];
k=1;
ptr = get_list_head(seed);
pi = p;
pf = pt + sedr->npts[i];
do { /* loop the contour */
cp = get_list_point(ptr);
x = cp % prev_col + maxrad;
y = cp / prev_col + maxrad;
p = pi;
do { /* loop displacements with distance d */
rw = y + *p;
cl = x + *(p+1);
p+=2;
pos = cl + lut[rw];
if (dist_data[pos] == INVALID_DIST) {
dist_data[pos] = d;
lbl_data[pos] = k;
pred_data[pos] = cp;
}
/*
Four-fold unroll: # of pts at any distance is a multiple of 4
*/
rw = y + *p;
cl = x + *(p+1);
p+=2;
pos = cl + lut[rw];
if (dist_data[pos] == INVALID_DIST) {
dist_data[pos] = d;
lbl_data[pos] = k;
pred_data[pos] = cp;
}
rw = y + *p;
cl = x + *(p+1);
p+=2;
pos = cl + lut[rw];
if (dist_data[pos] == INVALID_DIST) {
dist_data[pos] = d;
lbl_data[pos] = k;
pred_data[pos] = cp;
}
rw = y + *p;
cl = x + *(p+1);
p+=2;
pos = cl + lut[rw];
if (dist_data[pos] == INVALID_DIST) {
dist_data[pos] = d;
lbl_data[pos] = k;
pred_data[pos] = cp;
}
} while (p < pf);
k++;
ptr = next_list_node(ptr);
} while (not_nil(ptr));
}
aimg = new_ann_img(image);
for (i=maxrad; i<r-maxrad; i++)
for (j=maxrad; j<c-maxrad; j++) {
RC(aimg->label,i-maxrad, j-maxrad) = RC(lbl_img, i, j);
RC(aimg->cost, i-maxrad, j-maxrad) = RC(dist, i, j);
RC(aimg->pred, i-maxrad, j-maxrad) = RC(pred, i, j);
}
/* Liberate memory */
imfree(&img);
imfree_puint32(&lbl_img);
imfree_puint32(&dist);
imfree_puint32(&pred);
return aimg;
}
cell_t *read_list(secd_t *secd, secd_parser_t *p) {
const char *parse_err = NULL;
cell_t *head = SECD_NIL;
cell_t *tail = SECD_NIL;
cell_t *newtail, *val;
while (true) {
int tok = lexnext(p);
switch (tok) {
case TOK_EOF: case ')':
-- p->nested;
return head;
case '(':
++ p->nested;
val = read_list(secd, p);
if (p->token == TOK_ERR) {
parse_err = "read_list: error reading subexpression";
goto error_exit;
}
if (p->token != ')') {
parse_err = "read_list: TOK_EOF, ')' expected";
goto error_exit;
}
break;
default:
val = read_token(secd, p);
if (is_error(val)) {
parse_err = "read_list: read_token failed";
goto error_exit;
}
/* reading dot-lists */
if (is_symbol(val) && (str_eq(symname(val), "."))) {
free_cell(secd, val);
switch (lexnext(p)) {
case TOK_ERR: case ')':
parse_err = "read_list: failed to read a token after dot";
goto error_exit;
case '(':
/* there may be a list after dot */
val = read_list(secd, p);
if (p->token != ')') {
parse_err = "read_list: expected a ')' reading sublist after dot";
goto error_exit;
}
lexnext(p); // consume ')'
break;
default:
val = read_token(secd, p);
lexnext(p);
}
if (is_nil(head)) /* Guile-like: (. val) returns val */
return val;
tail->as.cons.cdr = share_cell(secd, val);
return head;
}
}
newtail = new_cons(secd, val, SECD_NIL);
if (not_nil(head)) {
tail->as.cons.cdr = share_cell(secd, newtail);
tail = newtail;
} else {
head = tail = newtail;
}
}
error_exit:
free_cell(secd, head);
errorf("read_list: TOK_ERR, %s\n", parse_err);
return new_error(secd, SECD_NIL, parse_err);
}
