pic_value
pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
{
pic_checkpoint *here;
pic_value val;
if (in != NULL) {
pic_apply0(pic, in); /* enter */
}
here = pic->cp;
pic->cp = pic_malloc(pic, sizeof(pic_checkpoint));
pic->cp->prev = here;
pic->cp->depth = here->depth + 1;
pic->cp->in = in;
pic->cp->out = out;
val = pic_apply0(pic, thunk);
pic->cp = here;
if (out != NULL) {
pic_apply0(pic, out); /* exit */
}
return val;
}
void
pic_wind(pic_state *pic, pic_checkpoint *here, pic_checkpoint *there)
{
if (here == there)
return;
if (here->depth < there->depth) {
pic_wind(pic, here, there->prev);
pic_apply0(pic, there->in);
}
else {
pic_apply0(pic, there->out);
pic_wind(pic, here->prev, there);
}
}
static pic_value
pic_error_with_exception_handler(pic_state *pic)
{
struct pic_proc *handler, *thunk;
pic_value val;
size_t xp_len;
ptrdiff_t xp_offset;
pic_get_args(pic, "ll", &handler, &thunk);
if (pic->xp >= pic->xpend) {
xp_len = (size_t)(pic->xpend - pic->xpbase) * 2;
xp_offset = pic->xp - pic->xpbase;
pic->xpbase = pic_realloc(pic, pic->xpbase, sizeof(struct pic_proc *) * xp_len);
pic->xp = pic->xpbase + xp_offset;
pic->xpend = pic->xpbase + xp_len;
}
*pic->xp++ = handler;
val = pic_apply0(pic, thunk);
--pic->xp;
return val;
}
void
pic_close(pic_state *pic)
{
xh_entry *it;
/* invoke exit handlers */
while (pic->wind) {
if (pic->wind->out) {
pic_apply0(pic, pic->wind->out);
}
pic->wind = pic->wind->prev;
}
/* free symbol names */
for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) {
free(xh_key(it, char *));
}
/* clear out root objects */
pic->sp = pic->stbase;
pic->ci = pic->cibase;
pic->xp = pic->xpbase;
pic->arena_idx = 0;
pic->err = pic_undef_value();
pic->globals = NULL;
pic->macros = NULL;
xh_clear(&pic->syms);
xh_clear(&pic->attrs);
pic->features = pic_nil_value();
pic->libs = pic_nil_value();
/* free all heap objects */
pic_gc_run(pic);
/* free heaps */
pic_heap_close(pic->heap);
/* free runtime context */
free(pic->stbase);
free(pic->cibase);
free(pic->xpbase);
/* free reader struct */
xh_destroy(&pic->reader->labels);
pic_trie_delete(pic, pic->reader->trie);
free(pic->reader);
/* free global stacks */
xh_destroy(&pic->syms);
xh_destroy(&pic->attrs);
/* free GC arena */
free(pic->arena);
free(pic);
}
static pic_value
pic_error_with_exception_handler(pic_state *pic)
{
struct pic_proc *handler, *thunk;
pic_value val;
pic_get_args(pic, "ll", &handler, &thunk);
pic_push_handler(pic, handler);
val = pic_apply0(pic, thunk);
pic_pop_handler(pic);
return val;
}
static pic_value
pic_cont_call_with_values(pic_state *pic)
{
struct pic_proc *producer, *consumer;
int argc;
pic_vec *args;
pic_get_args(pic, "ll", &producer, &consumer);
pic_apply0(pic, producer);
argc = pic_receive(pic, 0, NULL);
args = pic_make_vec(pic, argc);
pic_receive(pic, argc, args->data);
return pic_apply_trampoline(pic, consumer, argc, args->data);
}
