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_calloc(pic_state *pic, size_t count, size_t size)
{
void *ptr = pic_malloc(pic, count * size);
memset(ptr, 0, count * size);
return ptr;
}
void *
pic_alloca(pic_state *pic, size_t n)
{
static const pic_data_type t = { "pic_alloca", pic_free };
return pic_data(pic, pic_data_value(pic, pic_malloc(pic, n), &t));
}
static pic_value
pic_vec_vector_to_string(pic_state *pic)
{
pic_vec *vec;
char *buf;
int n, start, end, i;
pic_str *str;
n = pic_get_args(pic, "v|ii", &vec, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = vec->len;
}
if (end < start) {
pic_errorf(pic, "vector->string: end index must not be less than start index");
}
buf = pic_malloc(pic, end - start);
for (i = start; i < end; ++i) {
pic_assert_type(pic, vec->data[i], char);
buf[i - start] = pic_char(vec->data[i]);
}
str = pic_make_str(pic, buf, end - start);
pic_free(pic, buf);
return pic_obj_value(str);
}
static pic_value
pic_str_list_to_string(pic_state *pic)
{
pic_str *str;
pic_value list, e, it;
int i;
char *buf;
pic_get_args(pic, "o", &list);
if (pic_length(pic, list) == 0) {
return pic_obj_value(pic_make_str(pic, NULL, 0));
}
buf = pic_malloc(pic, pic_length(pic, list));
pic_try {
i = 0;
pic_for_each (e, list, it) {
pic_assert_type(pic, e, char);
buf[i++] = pic_char(e);
}
str = pic_make_str(pic, buf, i);
}
pic_value
pic_blob_value(pic_state *pic, const unsigned char *buf, int len)
{
struct blob *bv;
bv = (struct blob *)pic_obj_alloc(pic, PIC_TYPE_BLOB);
bv->data = pic_malloc(pic, len);
bv->len = len;
if (buf) {
memcpy(bv->data, buf, len);
}
return obj_value(pic, bv);
}
static void NOINLINE
save_cont(pic_state *pic, struct fullcont *cont)
{
void pic_vm_tear_off(pic_state *);
char *pos;
pic_vm_tear_off(pic); /* tear off */
cont->prev_jmp = pic->cc;
cont->cp = pic->cp;
cont->stk_len = native_stack_length(&pos);
cont->stk_pos = pos;
assert(cont->stk_len > 0);
cont->stk_ptr = pic_malloc(pic, cont->stk_len);
memcpy(cont->stk_ptr, cont->stk_pos, cont->stk_len);
cont->sp_offset = pic->sp - pic->stbase;
cont->st_len = pic->stend - pic->stbase;
cont->st_ptr = pic_malloc(pic, sizeof(pic_value) * cont->st_len);
memcpy(cont->st_ptr, pic->stbase, sizeof(pic_value) * cont->st_len);
cont->ci_offset = pic->ci - pic->cibase;
cont->ci_len = pic->ciend - pic->cibase;
cont->ci_ptr = pic_malloc(pic, sizeof(struct callinfo) * cont->ci_len);
memcpy(cont->ci_ptr, pic->cibase, sizeof(struct callinfo) * cont->ci_len);
cont->ip = pic->ip;
cont->arena_idx = pic->arena_idx;
cont->arena_size = pic->arena_size;
cont->arena = pic_malloc(pic, sizeof(struct object *) * pic->arena_size);
memcpy(cont->arena, pic->arena, sizeof(struct object *) * pic->arena_size);
cont->retc = 0;
cont->retv = NULL;
}
struct pic_vector *
pic_make_vec(pic_state *pic, int len)
{
struct pic_vector *vec;
int i;
vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR);
vec->len = len;
vec->data = (pic_value *)pic_malloc(pic, sizeof(pic_value) * len);
for (i = 0; i < len; ++i) {
vec->data[i] = pic_undef_value();
}
return vec;
}
static struct pic_chunk *
pic_make_chunk(pic_state *pic, const char *str, size_t len)
{
struct pic_chunk *c;
c = pic_malloc(pic, sizeof(struct pic_chunk) + len);
c->refcnt = 1;
c->str = c->buf;
c->len = len;
c->buf[len] = 0;
memcpy(c->buf, str, len);
return c;
}
static struct pic_rope *
pic_make_rope(pic_state *pic, struct pic_chunk *c)
{
struct pic_rope *x;
x = pic_malloc(pic, sizeof(struct pic_rope));
x->refcnt = 1;
x->left = NULL;
x->right = NULL;
x->weight = c->len;
x->offset = 0;
x->chunk = c; /* delegate ownership */
return x;
}
static pic_value
pic_str_string_map(pic_state *pic)
{
struct pic_proc *proc;
pic_value *argv, vals, val;
int argc, i, len, j;
pic_str *str;
char *buf;
pic_get_args(pic, "l*", &proc, &argc, &argv);
if (argc == 0) {
pic_errorf(pic, "string-map: one or more strings expected, but got zero");
} else {
pic_assert_type(pic, argv[0], str);
len = pic_str_len(pic_str_ptr(argv[0]));
}
for (i = 1; i < argc; ++i) {
pic_assert_type(pic, argv[i], str);
len = len < pic_str_len(pic_str_ptr(argv[i]))
? len
: pic_str_len(pic_str_ptr(argv[i]));
}
buf = pic_malloc(pic, len);
pic_try {
for (i = 0; i < len; ++i) {
vals = pic_nil_value();
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
}
val = pic_apply_list(pic, proc, vals);
pic_assert_type(pic, val, char);
buf[i] = pic_char(val);
}
str = pic_make_str(pic, buf, len);
}
pic_catch {
pic_free(pic, buf);
pic_raise(pic, pic->err);
}
pic_free(pic, buf);
return pic_obj_value(str);
}
struct heap *
pic_heap_open(pic_state *pic)
{
struct heap *heap;
heap = pic_malloc(pic, sizeof(struct heap));
heap->base.s.ptr = &heap->base;
heap->base.s.size = 0; /* not 1, since it must never be used for allocation */
heap->freep = &heap->base;
heap->pages = NULL;
heap->weaks = NULL;
return heap;
}
static struct pic_rope *
rope_sub(pic_state *pic, struct pic_rope *x, size_t i, size_t j)
{
assert(i <= j);
assert(j <= x->weight);
if (i == 0 && x->weight == j) {
pic_rope_incref(pic, x);
return x;
}
if (x->chunk) {
struct pic_rope *y;
y = pic_malloc(pic, sizeof(struct pic_rope));
y->refcnt = 1;
y->left = NULL;
y->right = NULL;
y->weight = j - i;
y->offset = x->offset + i;
y->chunk = x->chunk;
CHUNK_INCREF(x->chunk);
return y;
}
if (j <= x->left->weight) {
return rope_sub(pic, x->left, i, j);
}
else if (x->left->weight <= i) {
return rope_sub(pic, x->right, i - x->left->weight, j - x->left->weight);
}
else {
struct pic_rope *r, *l;
l = rope_sub(pic, x->left, i, x->left->weight);
r = rope_sub(pic, x->right, 0, j - x->left->weight);
x = rope_cat(pic, l, r);
pic_rope_decref(pic, l);
pic_rope_decref(pic, r);
return x;
}
}
static struct pic_rope *
rope_cat(pic_state *pic, struct pic_rope *x, struct pic_rope *y)
{
struct pic_rope *z;
z = pic_malloc(pic, sizeof(struct pic_rope));
z->refcnt = 1;
z->left = x;
z->right = y;
z->weight = x->weight + y->weight;
z->offset = 0;
z->chunk = NULL;
pic_rope_incref(pic, x);
pic_rope_incref(pic, y);
return z;
}
static pic_value
pic_callcc(pic_state *pic, pic_value proc)
{
struct fullcont *cont = pic_malloc(pic, sizeof(struct fullcont));
if (setjmp(cont->jmp) != 0) {
return pic_valuesk(pic, cont->retc, cont->retv);
} else {
pic_value c[1];
save_cont(pic, cont);
/* save the continuation object in proc */
c[0] = pic_lambda(pic, cont_call, 1, pic_data_value(pic, cont, &cont_type));
return pic_applyk(pic, proc, 1, c);
}
}
static pic_value
pic_str_make_string(pic_state *pic)
{
int len;
char c = ' ';
char *buf;
pic_value ret;
pic_get_args(pic, "i|c", &len, &c);
buf = pic_malloc(pic, len);
memset(buf, c, len);
ret = pic_obj_value(pic_make_str(pic, buf, len));
pic_free(pic, buf);
return ret;
}
struct object *
pic_obj_alloc_unsafe(pic_state *pic, int type)
{
struct object *obj;
size_t size = type2size(type);
if (pic->gc_count > PIC_GC_PERIOD) {
pic_gc(pic);
pic->gc_count -= PIC_GC_PERIOD;
}
obj = pic_malloc(pic, size);
obj->tt = type;
obj->next = pic->gc_head.next;
pic->gc_head.next = obj;
pic->gc_count += size;
return obj;
}
static const char *
rope_cstr(pic_state *pic, struct pic_rope *x)
{
struct pic_chunk *c;
if (x->chunk && x->offset == 0 && x->weight == x->chunk->len) {
return x->chunk->str; /* reuse cached chunk */
}
c = pic_malloc(pic, sizeof(struct pic_chunk) + x->weight);
c->refcnt = 1;
c->len = x->weight;
c->str = c->buf;
c->str[c->len] = '\0';
flatten(pic, x, c, 0);
CHUNK_DECREF(c);
return c->str;
}
pic_sym *
pic_intern(pic_state *pic, pic_str *str)
{
xh_entry *e;
pic_sym *sym;
char *cstr;
e = xh_get_str(&pic->syms, pic_str_cstr(str));
if (e) {
sym = xh_val(e, pic_sym *);
pic_gc_protect(pic, pic_obj_value(sym));
return sym;
}
cstr = pic_malloc(pic, pic_strlen(str) + 1);
strcpy(cstr, pic_str_cstr(str));
sym = pic_make_symbol(pic, str);
xh_put_str(&pic->syms, cstr, &sym);
return sym;
}
pic_sym
pic_intern(pic_state *pic, const char *str, size_t len)
{
char *cstr;
xh_entry *e;
pic_sym id;
cstr = (char *)pic_malloc(pic, len + 1);
cstr[len] = '\0';
memcpy(cstr, str, len);
e = xh_get(&pic->syms, cstr);
if (e) {
return xh_val(e, pic_sym);
}
id = pic->sym_cnt++;
xh_put(&pic->syms, cstr, &id);
xh_put(&pic->sym_names, id, &cstr);
return id;
}
static void
heap_morecore(pic_state *pic)
{
union header *bp, *np;
struct heap_page *page;
assert(PAGE_UNITS >= 2);
page = pic_malloc(pic, PIC_HEAP_PAGE_SIZE);
page->next = pic->heap->pages;
bp = page->u.basep;
bp->s.size = 0; /* bp is never used for allocation */
free_chunk(pic, bp);
np = page->u.basep + 1;
np->s.size = PAGE_UNITS - 1;
free_chunk(pic, np);
pic->heap->pages = page;
}
pic_value
pic_callcc(pic_state *pic, struct pic_proc *proc)
{
struct pic_cont *cont = pic_malloc(pic, sizeof(struct pic_cont));
pic_save_point(pic, cont);
if (PIC_SETJMP(pic, cont->jmp.buf)) {
pic->jmp = pic->jmp->prev;
return pic_values_by_list(pic, cont->results);
}
else {
pic_value val;
val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, cont)));
pic->jmp = pic->jmp->prev;
return val;
}
}
static pic_value
pic_str_string(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_str *str;
char *buf;
pic_get_args(pic, "*", &argc, &argv);
buf = pic_malloc(pic, argc);
for (i = 0; i < argc; ++i) {
pic_assert_type(pic, argv[i], char);
buf[i] = pic_char(argv[i]);
}
str = pic_make_str(pic, buf, argc);
pic_free(pic, buf);
return pic_obj_value(str);
}