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;
}
struct pic_dict *
pic_proc_env(pic_state *pic, struct pic_proc *proc)
{
assert(pic_proc_func_p(proc));
if (! proc->u.f.env) {
proc->u.f.env = pic_make_dict(pic);
}
return proc->u.f.env;
}
static pic_value
pic_dict_make_dictionary(pic_state *pic)
{
struct pic_dict *dict;
pic_get_args(pic, "");
dict = pic_make_dict(pic);
return pic_obj_value(dict);
}
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;
}
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;
}
static pic_value
pic_dict_dictionary(pic_state *pic)
{
struct pic_dict *dict;
pic_value *argv;
int argc, i;
pic_get_args(pic, "*", &argc, &argv);
dict = pic_make_dict(pic);
for (i = 0; i < argc; i += 2) {
pic_assert_type(pic, argv[i], sym);
pic_dict_set(pic, dict, pic_sym_ptr(argv[i]), argv[i+1]);
}
return pic_obj_value(dict);
}
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)));
}
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 *);
}
static void
import_table(pic_state *pic, pic_value spec, struct pic_dict *imports)
{
struct pic_lib *lib;
struct pic_dict *table;
pic_value val, tmp, prefix;
pic_sym *sym, *id, *tag;
table = pic_make_dict(pic);
if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) {
tag = pic_sym_ptr(pic_car(pic, spec));
if (tag == pic->sONLY) {
import_table(pic, pic_cadr(pic, spec), table);
pic_for_each (val, pic_cddr(pic, spec)) {
pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val)));
}
pic_state *
pic_open(int argc, char *argv[], char **envp)
{
struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short);
char t;
pic_state *pic;
size_t ai;
pic = malloc(sizeof(pic_state));
/* turn off GC */
pic->gc_enable = false;
/* root block */
pic->wind = NULL;
/* command line */
pic->argc = argc;
pic->argv = argv;
pic->envp = envp;
/* prepare VM stack */
pic->stbase = pic->sp = calloc(PIC_STACK_SIZE, sizeof(pic_value));
pic->stend = pic->stbase + PIC_STACK_SIZE;
/* callinfo */
pic->cibase = pic->ci = calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
pic->ciend = pic->cibase + PIC_STACK_SIZE;
/* exception handler */
pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
pic->xpend = pic->xpbase + PIC_RESCUE_SIZE;
/* memory heap */
pic->heap = pic_heap_open();
/* symbol table */
xh_init_str(&pic->syms, sizeof(pic_sym *));
/* global variables */
pic->globals = NULL;
/* macros */
pic->macros = NULL;
/* attributes */
xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *));
/* features */
pic->features = pic_nil_value();
/* libraries */
pic->libs = pic_nil_value();
pic->lib = NULL;
/* GC arena */
pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
pic->arena_size = PIC_ARENA_SIZE;
pic->arena_idx = 0;
/* raised error object */
pic->err = pic_undef_value();
/* standard ports */
pic->xSTDIN = NULL;
pic->xSTDOUT = NULL;
pic->xSTDERR = NULL;
/* native stack marker */
pic->native_stack_start = &t;
ai = pic_gc_arena_preserve(pic);
#define S(slot,name) pic->slot = pic_intern_cstr(pic, name);
S(sDEFINE, "define");
S(sLAMBDA, "lambda");
S(sIF, "if");
S(sBEGIN, "begin");
S(sSETBANG, "set!");
S(sQUOTE, "quote");
S(sQUASIQUOTE, "quasiquote");
S(sUNQUOTE, "unquote");
S(sUNQUOTE_SPLICING, "unquote-splicing");
S(sDEFINE_SYNTAX, "define-syntax");
S(sIMPORT, "import");
S(sEXPORT, "export");
S(sDEFINE_LIBRARY, "define-library");
S(sIN_LIBRARY, "in-library");
S(sCOND_EXPAND, "cond-expand");
S(sAND, "and");
S(sOR, "or");
S(sELSE, "else");
S(sLIBRARY, "library");
S(sONLY, "only");
S(sRENAME, "rename");
S(sPREFIX, "prefix");
S(sEXCEPT, "except");
S(sCONS, "cons");
S(sCAR, "car");
S(sCDR, "cdr");
S(sNILP, "null?");
S(sSYMBOLP, "symbol?");
S(sPAIRP, "pair?");
S(sADD, "+");
S(sSUB, "-");
S(sMUL, "*");
S(sDIV, "/");
S(sMINUS, "minus");
S(sEQ, "=");
S(sLT, "<");
S(sLE, "<=");
S(sGT, ">");
S(sGE, ">=");
S(sNOT, "not");
S(sREAD, "read");
S(sFILE, "file");
S(sCALL, "call");
S(sTAILCALL, "tail-call");
S(sGREF, "gref");
S(sLREF, "lref");
S(sCREF, "cref");
S(sRETURN, "return");
S(sCALL_WITH_VALUES, "call-with-values");
S(sTAILCALL_WITH_VALUES, "tailcall-with-values");
pic_gc_arena_restore(pic, ai);
#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name));
R(rDEFINE, "define");
R(rLAMBDA, "lambda");
R(rIF, "if");
R(rBEGIN, "begin");
R(rSETBANG, "set!");
R(rQUOTE, "quote");
R(rDEFINE_SYNTAX, "define-syntax");
R(rIMPORT, "import");
R(rEXPORT, "export");
R(rDEFINE_LIBRARY, "define-library");
R(rIN_LIBRARY, "in-library");
R(rCOND_EXPAND, "cond-expand");
pic_gc_arena_restore(pic, ai);
/* root tables */
pic->globals = pic_make_dict(pic);
pic->macros = pic_make_dict(pic);
/* root block */
pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
pic->wind->prev = NULL;
pic->wind->depth = 0;
pic->wind->in = pic->wind->out = NULL;
/* reader */
pic->reader = malloc(sizeof(struct pic_reader));
pic->reader->typecase = PIC_CASE_DEFAULT;
pic->reader->trie = pic_make_trie(pic);
xh_init_int(&pic->reader->labels, sizeof(pic_value));
/* init readers */
pic_init_reader(pic);
/* standard libraries */
pic->PICRIN_BASE = pic_open_library(pic, pic_read_cstr(pic, "(picrin base)"));
pic->PICRIN_USER = pic_open_library(pic, pic_read_cstr(pic, "(picrin user)"));
pic->lib = pic->PICRIN_USER;
/* standard I/O */
pic->xSTDIN = pic_make_standard_port(pic, xstdin, PIC_PORT_IN);
pic->xSTDOUT = pic_make_standard_port(pic, xstdout, PIC_PORT_OUT);
pic->xSTDERR = pic_make_standard_port(pic, xstderr, PIC_PORT_OUT);
pic_gc_arena_restore(pic, ai);
/* turn on GC */
pic->gc_enable = true;
pic_init_core(pic);
return pic;
}
pic_state *
pic_open(pic_allocf allocf, void *userdata)
{
pic_state *pic;
pic = allocf(userdata, NULL, sizeof(pic_state));
if (! pic) {
goto EXIT_PIC;
}
/* allocator */
pic->allocf = allocf;
/* user data */
pic->userdata = userdata;
/* context */
pic->default_cxt.ai = 0;
pic->default_cxt.pc = NULL;
pic->default_cxt.fp = NULL;
pic->default_cxt.sp = NULL;
pic->default_cxt.irep = NULL;
pic->default_cxt.prev = NULL;
pic->cxt = &pic->default_cxt;
/* arena */
pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *));
pic->arena_size = PIC_ARENA_SIZE;
pic->ai = 0;
if (! pic->arena) {
goto EXIT_ARENA;
}
/* turn off GC */
pic->gc_enable = false;
/* memory heap */
pic->heap = pic_heap_open(pic);
/* symbol table */
kh_init(oblist, &pic->oblist);
/* global variables */
pic->globals = pic_make_dict(pic);
/* features */
pic->features = pic_nil_value(pic);
/* dynamic environment */
pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic));
/* top continuation */
{
static const code_t halt_code[] = { 0x00 };
struct irep *irep;
struct proc *proc;
irep = (struct irep *)pic_obj_alloc(pic, PIC_TYPE_IREP);
irep->argc = 1;
irep->flags = IREP_CODE_STATIC;
irep->frame_size = 1;
irep->irepc = 0;
irep->objc = 0;
irep->irep = NULL;
irep->obj = NULL;
irep->code = halt_code;
irep->codec = sizeof halt_code / sizeof halt_code[0];
proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
proc->u.irep = irep;
proc->env = NULL;
pic->halt = obj_value(pic, proc);
}
/* panic handler */
pic->panicf = NULL;
/* turn on GC */
pic->gc_enable = true;
pic_init_core(pic);
pic_leave(pic, 0); /* empty arena */
return pic;
EXIT_ARENA:
allocf(userdata, pic, 0);
EXIT_PIC:
return NULL;
}
