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; }