picrin/extlib/benz/cont.c

283 lines
5.8 KiB
C
Raw Normal View History

2014-08-25 00:38:09 -04:00
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
#include "picrin/proc.h"
2014-08-25 00:38:09 -04:00
#include "picrin/cont.h"
#include "picrin/pair.h"
#include "picrin/data.h"
2014-08-25 00:38:09 -04:00
#include "picrin/error.h"
2014-09-18 09:33:20 -04:00
void
pic_wind(pic_state *pic, struct pic_winder *here, struct pic_winder *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);
}
}
pic_value
pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
{
struct pic_winder *here;
pic_value val;
if (in != NULL) {
pic_apply0(pic, in); /* enter */
}
here = pic->wind;
pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
pic->wind->prev = here;
pic->wind->depth = here->depth + 1;
pic->wind->in = in;
pic->wind->out = out;
val = pic_apply0(pic, thunk);
pic->wind = here;
if (out != NULL) {
pic_apply0(pic, out); /* exit */
}
return val;
}
2014-09-24 07:06:14 -04:00
void
2014-09-24 02:34:46 -04:00
pic_save_point(pic_state *pic, struct pic_escape *escape)
2014-09-19 03:41:49 -04:00
{
escape->valid = true;
/* save runtime context */
escape->wind = pic->wind;
escape->sp_offset = pic->sp - pic->stbase;
escape->ci_offset = pic->ci - pic->cibase;
escape->xp_offset = pic->xp - pic->xpbase;
escape->arena_idx = pic->arena_idx;
escape->ip = pic->ip;
escape->results = pic_undef_value();
}
void
2014-09-24 02:34:46 -04:00
pic_load_point(pic_state *pic, struct pic_escape *escape)
2014-09-19 03:41:49 -04:00
{
if (! escape->valid) {
pic_errorf(pic, "calling dead escape continuation");
}
pic_wind(pic, pic->wind, escape->wind);
/* load runtime context */
pic->wind = escape->wind;
pic->sp = pic->stbase + escape->sp_offset;
pic->ci = pic->cibase + escape->ci_offset;
pic->xp = pic->xpbase + escape->xp_offset;
pic->arena_idx = escape->arena_idx;
pic->ip = escape->ip;
2014-09-24 02:33:21 -04:00
escape->valid = false;
2014-09-19 03:41:49 -04:00
}
2015-01-07 16:11:48 -05:00
static pic_value
2014-09-19 03:41:49 -04:00
escape_call(pic_state *pic)
{
2014-09-27 07:17:02 -04:00
size_t argc;
2014-09-19 03:41:49 -04:00
pic_value *argv;
struct pic_data *e;
pic_get_args(pic, "*", &argc, &argv);
2014-09-24 20:44:21 -04:00
e = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
2014-09-19 03:41:49 -04:00
2014-09-24 02:34:46 -04:00
pic_load_point(pic, e->data);
longjmp(((struct pic_escape *)e->data)->jmp, 1);
2014-09-19 03:41:49 -04:00
}
2014-09-24 02:34:46 -04:00
struct pic_proc *
2014-09-24 05:43:20 -04:00
pic_make_econt(pic_state *pic, struct pic_escape *escape)
2014-09-24 01:57:49 -04:00
{
static const pic_data_type escape_type = { "escape", pic_free, NULL };
struct pic_proc *cont;
struct pic_data *e;
cont = pic_make_proc(pic, escape_call, "<escape-procedure>");
e = pic_data_alloc(pic, &escape_type, escape);
/* save the escape continuation in proc */
2014-09-24 20:44:21 -04:00
pic_attr_set(pic, pic_obj_value(cont), "@@escape", pic_obj_value(e));
2014-09-24 01:57:49 -04:00
return cont;
}
2014-09-19 03:41:49 -04:00
pic_value
pic_escape(pic_state *pic, struct pic_proc *proc)
{
2014-09-24 07:06:14 -04:00
struct pic_escape *escape = pic_alloc(pic, sizeof(struct pic_escape));
2014-09-19 03:41:49 -04:00
2014-09-24 07:06:14 -04:00
pic_save_point(pic, escape);
2014-09-19 03:41:49 -04:00
2014-09-24 07:06:14 -04:00
if (setjmp(escape->jmp)) {
2014-09-19 03:41:49 -04:00
return pic_values_by_list(pic, escape->results);
}
else {
pic_value val;
2014-09-24 05:43:20 -04:00
val = pic_apply1(pic, proc, pic_obj_value(pic_make_econt(pic, escape)));
2014-09-19 03:41:49 -04:00
escape->valid = false;
return val;
}
}
2014-08-25 00:38:09 -04:00
pic_value
pic_values0(pic_state *pic)
{
return pic_values_by_list(pic, pic_nil_value());
}
pic_value
pic_values1(pic_state *pic, pic_value arg1)
{
return pic_values_by_list(pic, pic_list1(pic, arg1));
}
pic_value
pic_values2(pic_state *pic, pic_value arg1, pic_value arg2)
{
return pic_values_by_list(pic, pic_list2(pic, arg1, arg2));
}
pic_value
pic_values3(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3)
{
return pic_values_by_list(pic, pic_list3(pic, arg1, arg2, arg3));
}
pic_value
pic_values4(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4)
{
return pic_values_by_list(pic, pic_list4(pic, arg1, arg2, arg3, arg4));
}
pic_value
pic_values5(pic_state *pic, pic_value arg1, pic_value arg2, pic_value arg3, pic_value arg4, pic_value arg5)
{
return pic_values_by_list(pic, pic_list5(pic, arg1, arg2, arg3, arg4, arg5));
}
pic_value
2014-09-27 07:21:54 -04:00
pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
2014-08-25 00:38:09 -04:00
{
2014-09-27 07:21:54 -04:00
size_t i;
2014-08-25 00:38:09 -04:00
for (i = 0; i < argc; ++i) {
pic->sp[i] = argv[i];
}
2014-09-27 07:21:54 -04:00
pic->ci->retc = (int)argc;
2014-08-25 00:38:09 -04:00
return argc == 0 ? pic_none_value() : pic->sp[0];
}
pic_value
pic_values_by_list(pic_state *pic, pic_value list)
{
2015-01-22 05:28:31 -05:00
pic_value v, it;
int i;
2014-08-25 00:38:09 -04:00
i = 0;
2015-01-22 05:28:31 -05:00
pic_for_each (v, list, it) {
2014-08-25 00:38:09 -04:00
pic->sp[i++] = v;
}
pic->ci->retc = i;
return pic_nil_p(list) ? pic_none_value() : pic->sp[0];
}
2014-09-27 07:21:54 -04:00
size_t
pic_receive(pic_state *pic, size_t n, pic_value *argv)
2014-08-25 00:38:09 -04:00
{
pic_callinfo *ci;
2014-09-27 07:21:54 -04:00
size_t i, retc;
2014-08-25 00:38:09 -04:00
/* take info from discarded frame */
ci = pic->ci + 1;
2014-09-27 07:21:54 -04:00
retc = (size_t)ci->retc;
2014-08-25 00:38:09 -04:00
for (i = 0; i < retc && i < n; ++i) {
argv[i] = ci->fp[i];
}
return retc;
}
static pic_value
pic_cont_callcc(pic_state *pic)
{
struct pic_proc *cb;
pic_get_args(pic, "l", &cb);
2014-09-20 07:26:07 -04:00
return pic_escape(pic, cb);
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_cont_dynamic_wind(pic_state *pic)
{
struct pic_proc *in, *thunk, *out;
pic_get_args(pic, "lll", &in, &thunk, &out);
return pic_dynamic_wind(pic, in, thunk, out);
}
static pic_value
pic_cont_values(pic_state *pic)
{
2014-09-27 07:17:02 -04:00
size_t argc;
2014-08-25 00:38:09 -04:00
pic_value *argv;
pic_get_args(pic, "*", &argc, &argv);
return pic_values_by_array(pic, argc, argv);
}
static pic_value
pic_cont_call_with_values(pic_state *pic)
{
struct pic_proc *producer, *consumer;
2014-09-27 07:21:54 -04:00
size_t argc;
2014-08-25 00:38:09 -04:00
pic_value args[256];
pic_get_args(pic, "ll", &producer, &consumer);
pic_apply(pic, producer, pic_nil_value());
argc = pic_receive(pic, 256, args);
return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args));
}
void
pic_init_cont(pic_state *pic)
{
pic_defun(pic, "call-with-current-continuation", pic_cont_callcc);
2014-09-08 06:38:33 -04:00
pic_defun(pic, "call/cc", pic_cont_callcc);
2014-08-25 00:38:09 -04:00
pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
pic_defun(pic, "values", pic_cont_values);
pic_defun(pic, "call-with-values", pic_cont_call_with_values);
}