static pic_value pic_error_with_exception_handler(pic_state *pic) { pic_value handler, thunk; pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); pic_get_args(pic, "ll", &handler, &thunk); stack = pic_call(pic, exc, 0); return pic_dynamic_bind(pic, exc, pic_cons(pic, handler, stack), thunk); }
pic_value pic_raise_continuable(pic_state *pic, pic_value err) { pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); stack = pic_call(pic, exc, 0); if (pic_nil_p(pic, stack)) { pic_panic(pic, "no exception handler"); } return pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise_continuable, 2, pic_car(pic, stack), err)); }
void pic_raise(pic_state *pic, pic_value err) { pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers"); stack = pic_call(pic, exc, 0); if (pic_nil_p(pic, stack)) { pic_panic(pic, "no exception handler"); } pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise, 2, pic_car(pic, stack), err)); PIC_UNREACHABLE(); }
pic_value pic_funcall(pic_state *pic, const char *name, int n, ...) { size_t ai = pic_enter(pic); pic_value proc, r; va_list ap; proc = pic_ref(pic, name); TYPE_CHECK(pic, proc, proc); va_start(ap, n); r = pic_vcall(pic, proc, n, ap); va_end(ap); pic_leave(pic, ai); return pic_protect(pic, r); }
pic_value pic_start_try(pic_state *pic, PIC_JMPBUF *jmp) { struct cont *cont; pic_value handler; pic_value var, old_val, new_val; pic_value in, out; struct checkpoint *here; /* call/cc */ cont = pic_alloca_cont(pic); pic_save_point(pic, cont, jmp); handler = pic_lambda(pic, native_exception_handler, 1, pic_make_cont(pic, cont)); /* with-exception-handler */ var = pic_ref(pic, "picrin.base", "current-exception-handlers"); old_val = pic_call(pic, var, 0); new_val = pic_cons(pic, handler, old_val); in = pic_lambda(pic, dynamic_set, 2, var, new_val); out = pic_lambda(pic, dynamic_set, 2, var, old_val); /* dynamic-wind */ pic_call(pic, in, 0); /* enter */ here = pic->cp; pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); pic->cp->prev = here; pic->cp->depth = here->depth + 1; pic->cp->in = pic_proc_ptr(pic, in); pic->cp->out = pic_proc_ptr(pic, out); return pic_cons(pic, pic_obj_value(here), out); }