static pic_value
pic_blob_bytevector(pic_state *pic)
{
pic_value *argv;
size_t argc, i;
pic_blob *blob;
unsigned char *data;
pic_get_args(pic, "*", &argc, &argv);
blob = pic_make_blob(pic, argc);
data = blob->data;
for (i = 0; i < argc; ++i) {
pic_assert_type(pic, argv[i], int);
if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) {
pic_errorf(pic, "byte out of range");
}
*data++ = (unsigned char)pic_int(argv[i]);
}
return pic_obj_value(blob);
}
static pic_value
pic_vec_vector_copy(pic_state *pic)
{
pic_vec *vec, *to;
int n, start, end, i = 0;
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-copy: end index must not be less than start index");
}
to = pic_make_vec(pic, end - start);
while (start < end) {
to->data[i++] = vec->data[start++];
}
return pic_obj_value(to);
}
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
cont_call(pic_state *pic)
{
struct pic_proc *self = pic_get_proc(pic);
int argc;
pic_value *argv;
int id;
struct pic_cont *cc, *cont;
pic_get_args(pic, "*", &argc, &argv);
id = pic_int(pic_proc_env_ref(pic, self, "id"));
/* check if continuation is alive */
for (cc = pic->cc; cc != NULL; cc = cc->prev) {
if (cc->id == id) {
break;
}
}
if (cc == NULL) {
pic_errorf(pic, "calling dead escape continuation");
}
cont = pic_data_ptr(pic_proc_env_ref(pic, self, "escape"))->data;
cont->results = pic_list_by_array(pic, argc, argv);
pic_load_point(pic, cont);
PIC_LONGJMP(pic, cont->jmp, 1);
PIC_UNREACHABLE();
}
static pic_value
pic_blob_bytevector_copy(pic_state *pic)
{
pic_blob *from, *to;
int n;
size_t start, end, i = 0;
n = pic_get_args(pic, "b|kk", &from, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = from->len;
}
if (end < start) {
pic_errorf(pic, "make-bytevector: end index must not be less than start index");
}
to = pic_make_blob(pic, end - start);
while (start < end) {
to->data[i++] = from->data[start++];
}
return pic_obj_value(to);
}
static pic_value
pic_vec_string_to_vector(pic_state *pic)
{
pic_str *str;
int n, start, end, i;
pic_vec *vec;
n = pic_get_args(pic, "s|ii", &str, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = pic_str_len(str);
}
if (end < start) {
pic_errorf(pic, "string->vector: end index must not be less than start index");
}
vec = pic_make_vec(pic, end - start);
for (i = 0; i < end - start; ++i) {
vec->data[i] = pic_char_value(pic_str_ref(pic, str, i + start));
}
return pic_obj_value(vec);
}
static pic_value
pic_str_string_for_each(pic_state *pic)
{
struct pic_proc *proc;
int argc, len, i, j;
pic_value *argv, vals;
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]));
}
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);
}
pic_apply_list(pic, proc, vals);
}
return pic_undef_value();
}
void
pic_load_point(pic_state *pic, struct pic_cont *cont)
{
pic_jmpbuf *jmp;
for (jmp = pic->jmp; jmp != NULL; jmp = jmp->prev) {
if (jmp == &cont->jmp) {
break;
}
}
if (jmp == NULL) {
pic_errorf(pic, "calling dead escape continuation");
}
pic_wind(pic, pic->cp, cont->cp);
/* load runtime context */
pic->cp = cont->cp;
pic->sp = pic->stbase + cont->sp_offset;
pic->ci = pic->cibase + cont->ci_offset;
pic->xp = pic->xpbase + cont->xp_offset;
pic->arena_idx = cont->arena_idx;
pic->ip = cont->ip;
pic->ptable = cont->ptable;
}
pic_str *
pic_make_str(pic_state *pic, const char *str, int len)
{
if (str == NULL && len > 0) {
pic_errorf(pic, "zero length specified against NULL ptr");
}
return pic_make_string(pic, pic_make_rope(pic, pic_make_chunk(pic, str, len)));
}
void
pic_set_box(pic_state *pic, pic_value box, pic_value value)
{
if (! pic_box_p(box)) {
pic_errorf(pic, "expected box, but got ~s", box);
}
pic_box_ptr(box)->value = value;
}
pic_value
pic_unbox(pic_state *pic, pic_value box)
{
if (! pic_box_p(box)) {
pic_errorf(pic, "expected box, but got ~s", box);
}
return pic_box_ptr(box)->value;
}
pic_value
pic_record_ref(pic_state *pic, struct pic_record *rec, pic_sym *slot)
{
if (! pic_dict_has(pic, rec->data, slot)) {
pic_errorf(pic, "slot named ~s is not found for record: ~s", pic_obj_value(slot), rec);
}
return pic_dict_ref(pic, rec->data, slot);
}
void
pic_close_port(pic_state *pic, struct pic_port *port)
{
if (xfclose(port->file) == EOF) {
pic_errorf(pic, "close-port: failure");
}
port->status = PIC_PORT_CLOSE;
}
char
pic_str_ref(pic_state *pic, pic_str *str, int i)
{
int c;
c = rope_at(str->rope, i);
if (c == -1) {
pic_errorf(pic, "index out of range %d", i);
}
return (char)c;
}
void
pic_raise(pic_state *pic, pic_value err)
{
pic_value val;
val = pic_raise_continuable(pic, err);
pic_pop_handler(pic);
pic_errorf(pic, "error handler returned with ~s on error ~s", val, err);
}
void
pic_in_library(pic_state *pic, pic_value spec)
{
struct pic_lib *lib;
lib = pic_find_library(pic, spec);
if (! lib) {
pic_errorf(pic, "library not found: ~a", spec);
}
pic->lib = lib;
}
void
pic_reg_del(pic_state *pic, struct pic_reg *reg, void *key)
{
khash_t(reg) *h = ®->hash;
khiter_t it;
it = kh_get(reg, h, key);
if (it == kh_end(h)) {
pic_errorf(pic, "no slot named ~s found in register", pic_obj_value(key));
}
kh_del(reg, h, it);
}
pic_value
pic_reg_ref(pic_state *pic, struct pic_reg *reg, void *key)
{
khash_t(reg) *h = ®->hash;
khiter_t it;
it = kh_get(reg, h, key);
if (it == kh_end(h)) {
pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key));
}
return kh_val(h, it);
}
void
pic_set_cdr(pic_state *pic, pic_value obj, pic_value val)
{
struct pic_pair *pair;
if (! pic_pair_p(obj)) {
pic_errorf(pic, "pair required");
}
pair = pic_pair_ptr(obj);
pair->cdr = val;
}
pic_value
pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym *key)
{
khash_t(dict) *h = &dict->hash;
khiter_t it;
it = kh_get(dict, h, key);
if (it == kh_end(h)) {
pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key));
}
return kh_val(h, it);
}
void
pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym *key)
{
khash_t(dict) *h = &dict->hash;
khiter_t it;
it = kh_get(dict, h, key);
if (it == kh_end(h)) {
pic_errorf(pic, "no slot named ~s found in dictionary", pic_obj_value(key));
}
kh_del(dict, h, it);
}
static pic_value
pic_vec_vector_ref(pic_state *pic)
{
struct pic_vector *v;
int k;
pic_get_args(pic, "vi", &v, &k);
if (v->len <= k) {
pic_errorf(pic, "vector-ref: index out of range");
}
return v->data[k];
}
static pic_value
pic_blob_bytevector_u8_set(pic_state *pic)
{
struct pic_blob *bv;
int k, v;
pic_get_args(pic, "bii", &bv, &k, &v);
if (v < 0 || v > 255)
pic_errorf(pic, "byte out of range");
bv->data[k] = (unsigned char)v;
return pic_none_value();
}
static pic_value
pic_vec_vector_set(pic_state *pic)
{
struct pic_vector *v;
int k;
pic_value o;
pic_get_args(pic, "vio", &v, &k, &o);
if (v->len <= k) {
pic_errorf(pic, "vector-set!: index out of range");
}
v->data[k] = o;
return pic_undef_value();
}
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);
}
int
pic_length(pic_state *pic, pic_value obj)
{
int c = 0;
if (! pic_list_p(obj)) {
pic_errorf(pic, "length: expected list, but got ~s", obj);
}
while (! pic_nil_p(obj)) {
obj = pic_cdr(pic, obj);
++c;
}
return c;
}
void
pic_raise(pic_state *pic, pic_value obj)
{
pic_value a;
struct pic_proc *handler;
if (pic->ridx == 0) {
pic_abort(pic, "logic flaw: no exception handler remains");
}
handler = pic->rescue[--pic->ridx];
pic_gc_protect(pic, pic_obj_value(handler));
a = pic_apply_argv(pic, handler, 1, obj);
/* when the handler returns */
pic_errorf(pic, "handler returned", 2, pic_obj_value(handler), a);
}
struct pic_dict *
pic_attr(pic_state *pic, pic_value obj)
{
struct pic_dict *dict;
if (! pic_obj_p(obj)) {
pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj);
}
if (! pic_reg_has(pic, pic->attrs, pic_ptr(obj))) {
dict = pic_make_dict(pic);
pic_reg_set(pic, pic->attrs, pic_ptr(obj), pic_obj_value(dict));
return dict;
}
return pic_dict_ptr(pic_reg_ref(pic, pic->attrs, pic_ptr(obj)));
}
static pic_value
pic_str_string_append(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_str *str;
pic_get_args(pic, "*", &argc, &argv);
str = pic_make_str(pic, NULL, 0);
for (i = 0; i < argc; ++i) {
if (! pic_str_p(argv[i])) {
pic_errorf(pic, "type error");
}
str = pic_str_cat(pic, str, pic_str_ptr(argv[i]));
}
return pic_obj_value(str);
}
struct pic_dict *
pic_attr(pic_state *pic, pic_value obj)
{
xh_entry *e;
if (pic_vtype(obj) != PIC_VTYPE_HEAP) {
pic_errorf(pic, "attribute: expected heap object, but got immediate value ~s", obj);
}
e = xh_get_ptr(&pic->attrs, pic_ptr(obj));
if (e == NULL) {
struct pic_dict *dict = pic_make_dict(pic);
e = xh_put_ptr(&pic->attrs, pic_ptr(obj), &dict);
assert(dict == xh_val(e, struct pic_dict *));
}
return xh_val(e, struct pic_dict *);
}