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_checkpoint *)pic_obj_alloc(pic, sizeof(pic_checkpoint), PIC_TT_CP);
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;
}
struct pic_lib *
pic_open_library(pic_state *pic, pic_value name)
{
struct pic_lib *lib;
struct pic_senv *senv;
struct pic_dict *exports;
if ((lib = pic_find_library(pic, name)) != NULL) {
#if DEBUG
printf("* reopen library: ");
pic_debug(pic, name);
puts("");
#endif
return lib;
}
senv = pic_null_syntactic_environment(pic);
exports = pic_make_dict(pic);
lib = (struct pic_lib *)pic_obj_alloc(pic, sizeof(struct pic_lib), PIC_TT_LIB);
lib->name = name;
lib->env = senv;
lib->exports = exports;
/* register! */
pic->libs = pic_acons(pic, name, pic_obj_value(lib), pic->libs);
return lib;
}
static pic_str *
pic_make_string(pic_state *pic, struct pic_rope *rope)
{
pic_str *str;
str = (pic_str *)pic_obj_alloc(pic, sizeof(pic_str), PIC_TT_STRING);
str->rope = rope; /* delegate ownership */
return str;
}
pic_value
pic_box(pic_state *pic, pic_value value)
{
struct pic_box *box;
box = (struct pic_box *)pic_obj_alloc(pic, sizeof(struct pic_box), PIC_TT_BOX);
box->value = value;
return pic_obj_value(box);
}
pic_sym *
pic_make_symbol(pic_state *pic, pic_str *str)
{
pic_sym *sym;
sym = (pic_sym *)pic_obj_alloc(pic, sizeof(struct pic_symbol), PIC_TT_SYMBOL);
sym->str = str;
return sym;
}
struct pic_dict *
pic_make_dict(pic_state *pic)
{
struct pic_dict *dict;
dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
kh_init(dict, &dict->hash);
return dict;
}
struct pic_blob *
pic_make_blob(pic_state *pic, size_t len)
{
struct pic_blob *bv;
bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB);
bv->data = pic_alloc(pic, len);
bv->len = len;
return bv;
}
struct pic_vector *
pic_vec_new(pic_state *pic, size_t len)
{
struct pic_vector *vec;
vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR);
vec->len = len;
vec->data = (pic_value *)pic_alloc(pic, sizeof(pic_value) * len);
return vec;
}
struct pic_env *
pic_make_env(pic_state *pic, struct pic_env *up)
{
struct pic_env *env;
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
env->up = up;
kh_init(env, &env->map);
return env;
}
pic_value
pic_make_weak(pic_state *pic)
{
struct weak *weak;
weak = (struct weak *)pic_obj_alloc(pic, sizeof(struct weak), PIC_TYPE_WEAK);
weak->prev = NULL;
kh_init(weak, &weak->hash);
return pic_obj_value(weak);
}
pic_value
pic_data_value(pic_state *pic, void *userdata, const pic_data_type *type)
{
struct data *data;
data = (struct data *)pic_obj_alloc(pic, PIC_TYPE_DATA);
data->type = type;
data->data = userdata;
return obj_value(pic, data);
}
struct pic_proc *
pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_context *cxt)
{
struct pic_proc *proc;
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->tag = PIC_PROC_TAG_IREP;
proc->u.i.irep = irep;
proc->u.i.cxt = cxt;
return proc;
}
struct pic_port *
pic_make_standard_port(pic_state *pic, xFILE *file, short dir)
{
struct pic_port *port;
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
port->file = file;
port->flags = dir | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
return port;
}
struct pic_proc *
pic_make_proc_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
{
struct pic_proc *proc;
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->kind = PIC_PROC_KIND_IREP;
proc->u.irep = irep;
proc->env = env;
return proc;
}
struct pic_reg *
pic_make_reg(pic_state *pic)
{
struct pic_reg *reg;
reg = (struct pic_reg *)pic_obj_alloc(pic, sizeof(struct pic_reg), PIC_TT_REG);
reg->prev = NULL;
kh_init(reg, ®->hash);
return reg;
}
pic_value
pic_cons(pic_state *pic, pic_value car, pic_value cdr)
{
struct pic_pair *pair;
pair = (struct pic_pair *)pic_obj_alloc(pic, sizeof(struct pic_pair), PIC_TT_PAIR);
pair->car = car;
pair->cdr = cdr;
return pic_obj_value(pair);
}
struct pic_proc *
pic_proc_new(pic_state *pic, pic_func_t cfunc)
{
struct pic_proc *proc;
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->cfunc_p = true;
proc->u.cfunc = cfunc;
proc->env = NULL;
return proc;
}
struct pic_proc *
pic_proc_new_irep(pic_state *pic, struct pic_irep *irep, struct pic_env *env)
{
struct pic_proc *proc;
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->cfunc_p = false;
proc->u.irep = irep;
proc->env = env;
return proc;
}
struct pic_id *
pic_make_id(pic_state *pic, pic_value var, struct pic_env *env)
{
struct pic_id *id;
assert(pic_var_p(var));
id = (struct pic_id *)pic_obj_alloc(pic, sizeof(struct pic_id), PIC_TT_ID);
id->var = var;
id->env = env;
return id;
}
struct pic_port *
pic_open_output_string(pic_state *pic)
{
struct pic_port *port;
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
return port;
}
struct pic_data *
pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata)
{
struct pic_data *data;
struct pic_dict *storage = pic_make_dict(pic);
data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA);
data->type = type;
data->data = userdata;
data->storage = storage;
return data;
}
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);
}
struct pic_proc *
pic_make_proc(pic_state *pic, pic_func_t func, const char *name)
{
struct pic_proc *proc;
assert(name != NULL);
proc = (struct pic_proc *)pic_obj_alloc(pic, sizeof(struct pic_proc), PIC_TT_PROC);
proc->kind = PIC_PROC_KIND_FUNC;
proc->u.func.f = func;
proc->u.func.name = pic_intern_cstr(pic, name);
proc->env = NULL;
return proc;
}
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 pic_value
pic_port_open_output_bytevector(pic_state *pic)
{
struct pic_port *port;
pic_get_args(pic, "");
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_OUT | PIC_PORT_BINARY;
port->status = PIC_PORT_OPEN;
return pic_obj_value(port);
}
struct pic_vector *
pic_vec_new(pic_state *pic, size_t len)
{
struct pic_vector *vec;
size_t i;
vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR);
vec->len = len;
vec->data = (pic_value *)pic_alloc(pic, sizeof(pic_value) * len);
for (i = 0; i < len; ++i) {
vec->data[i] = pic_none_value();
}
return vec;
}
void
pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size)
{
struct pic_env *env;
if (proc->env != NULL) {
pic_error(pic, "env slot already in use");
}
env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
env->valuec = cv_size;
env->values = (pic_value *)pic_calloc(pic, cv_size, sizeof(pic_value));
env->up = NULL;
proc->env = env;
}
struct pic_record *
pic_make_record(pic_state *pic, pic_value rectype)
{
struct pic_record *rec;
struct pic_dict *data;
data = pic_make_dict(pic);
rec = (struct pic_record *)pic_obj_alloc(pic, sizeof(struct pic_record), PIC_TT_RECORD);
rec->data = data;
pic_record_set(pic, rec, pic_intern_cstr(pic, "@@type"), rectype);
return rec;
}
struct pic_port *
pic_open_input_string(pic_state *pic, const char *str)
{
struct pic_port *port;
port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
port->file = xmopen();
port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
port->status = PIC_PORT_OPEN;
xfputs(str, port->file);
xfflush(port->file);
xrewind(port->file);
return port;
}
struct pic_error *
pic_make_error(pic_state *pic, pic_sym *type, const char *msg, pic_value irrs)
{
struct pic_error *e;
pic_str *stack;
stack = pic_get_backtrace(pic);
e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR);
e->type = type;
e->msg = pic_make_str_cstr(pic, msg);
e->irrs = irrs;
e->stack = stack;
return e;
}
