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