/** * See Copyright Notice in picrin.h */ #include "picrin.h" #include "value.h" #include "object.h" #include "state.h" static pic_value pic_features(pic_state *pic) { pic_get_args(pic, ""); return pic->features; } static void pic_init_features(pic_state *pic) { pic_defun(pic, "features", pic_features); pic_add_feature(pic, "picrin"); #if __STDC_IEC_559__ pic_add_feature(pic, "ieee-float"); #endif #if _POSIX_SOURCE pic_add_feature(pic, "posix"); #endif #if _WIN32 pic_add_feature(pic, "windows"); #endif #if __unix__ pic_add_feature(pic, "unix"); #endif #if __gnu_linux__ pic_add_feature(pic, "gnu-linux"); #endif #if __FreeBSD__ pic_add_feature(pic, "freebsd"); #endif #if __i386__ pic_add_feature(pic, "i386"); #elif __x86_64__ pic_add_feature(pic, "x86-64"); #elif __ppc__ pic_add_feature(pic, "ppc"); #elif __sparc__ pic_add_feature(pic, "sparc"); #endif #if __ILP32__ pic_add_feature(pic, "ilp32"); #elif __LP64__ pic_add_feature(pic, "lp64"); #endif #if defined(__BYTE_ORDER__) # if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ pic_add_feature(pic, "little-endian"); # elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ pic_add_feature(pic, "big-endian"); # endif #else # if __LITTLE_ENDIAN__ pic_add_feature(pic, "little-endian"); # elif __BIG_ENDIAN__ pic_add_feature(pic, "big-endian"); # endif #endif } void pic_add_feature(pic_state *pic, const char *feature) { pic_push(pic, pic_intern_cstr(pic, feature), pic->features); } #define import_builtin_syntax(name) do { \ pic_value nick, real; \ nick = pic_intern_lit(pic, "builtin:" name); \ real = pic_intern_lit(pic, name); \ pic_put_identifier(pic, nick, real, env); \ } while (0) void pic_init_bool(pic_state *); void pic_init_pair(pic_state *); void pic_init_port(pic_state *); void pic_init_number(pic_state *); void pic_init_proc(pic_state *); void pic_init_symbol(pic_state *); void pic_init_vector(pic_state *); void pic_init_blob(pic_state *); void pic_init_cont(pic_state *); void pic_init_char(pic_state *); void pic_init_error(pic_state *); void pic_init_str(pic_state *); void pic_init_var(pic_state *); void pic_init_write(pic_state *); void pic_init_read(pic_state *); void pic_init_dict(pic_state *); void pic_init_record(pic_state *); void pic_init_eval(pic_state *); void pic_init_lib(pic_state *); void pic_init_weak(pic_state *); void pic_boot(pic_state *); #define DONE pic_leave(pic, ai); static void pic_init_core(pic_state *pic) { size_t ai = pic_enter(pic); pic_value env; pic_deflibrary(pic, "picrin.base"); env = pic_library_environment(pic, pic->lib); import_builtin_syntax("define"); import_builtin_syntax("set!"); import_builtin_syntax("quote"); import_builtin_syntax("lambda"); import_builtin_syntax("if"); import_builtin_syntax("begin"); import_builtin_syntax("define-macro"); pic_init_features(pic); DONE; pic_init_bool(pic); DONE; pic_init_pair(pic); DONE; pic_init_port(pic); DONE; pic_init_number(pic); DONE; pic_init_proc(pic); DONE; pic_init_symbol(pic); DONE; pic_init_vector(pic); DONE; pic_init_blob(pic); DONE; pic_init_cont(pic); DONE; pic_init_char(pic); DONE; pic_init_error(pic); DONE; pic_init_str(pic); DONE; pic_init_var(pic); DONE; pic_init_read(pic); DONE; pic_init_dict(pic); DONE; pic_init_record(pic); DONE; pic_init_eval(pic); DONE; pic_init_lib(pic); DONE; pic_init_weak(pic); DONE; #if PIC_USE_WRITE pic_init_write(pic); DONE; #endif pic_boot(pic); DONE; } 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; /* turn off GC */ pic->gc_enable = false; /* continuation chain */ pic->cc = NULL; /* root block */ pic->cp = NULL; /* prepare VM stack */ pic->stbase = pic->sp = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_value)); pic->stend = pic->stbase + PIC_STACK_SIZE; if (! pic->sp) { goto EXIT_SP; } /* callinfo */ pic->cibase = pic->ci = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(struct callinfo)); pic->ciend = pic->cibase + PIC_STACK_SIZE; if (! pic->ci) { goto EXIT_CI; } /* GC arena */ pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct object *)); pic->arena_size = PIC_ARENA_SIZE; pic->arena_idx = 0; if (! pic->arena) { goto EXIT_ARENA; } /* memory heap */ pic->heap = pic_heap_open(pic); /* symbol table */ kh_init(oblist, &pic->oblist); /* unique symbol count */ pic->ucnt = 0; /* global variables */ pic->globals = pic_invalid_value(pic); /* macros */ pic->macros = pic_invalid_value(pic); /* features */ pic->features = pic_nil_value(pic); /* libraries */ kh_init(ltable, &pic->ltable); pic->lib = NULL; /* ireps */ pic->ireps.next = &pic->ireps; pic->ireps.prev = &pic->ireps; /* raised error object */ pic->panicf = NULL; pic->err = pic_invalid_value(pic); /* root tables */ pic->globals = pic_make_weak(pic); pic->macros = pic_make_weak(pic); /* root block */ pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP); pic->cp->prev = NULL; pic->cp->depth = 0; pic->cp->in = pic->cp->out = NULL; /* user land */ pic_deflibrary(pic, "picrin.user"); /* turn on GC */ pic->gc_enable = true; pic_init_core(pic); pic_in_library(pic, "picrin.user"); pic_leave(pic, 0); /* empty arena */ return pic; EXIT_ARENA: allocf(userdata, pic->ci, 0); EXIT_CI: allocf(userdata, pic->sp, 0); EXIT_SP: allocf(userdata, pic, 0); EXIT_PIC: return NULL; } void pic_close(pic_state *pic) { pic_allocf allocf = pic->allocf; /* clear out root objects */ pic->sp = pic->stbase; pic->ci = pic->cibase; pic->arena_idx = 0; pic->err = pic_invalid_value(pic); pic->globals = pic_invalid_value(pic); pic->macros = pic_invalid_value(pic); pic->features = pic_nil_value(pic); /* free all libraries */ kh_clear(ltable, &pic->ltable); /* free all heap objects */ pic_gc(pic); /* free heaps */ pic_heap_close(pic, pic->heap); /* free runtime context */ allocf(pic->userdata, pic->stbase, 0); allocf(pic->userdata, pic->cibase, 0); /* free global stacks */ kh_destroy(oblist, &pic->oblist); kh_destroy(ltable, &pic->ltable); /* free GC arena */ allocf(pic->userdata, pic->arena, 0); allocf(pic->userdata, pic, 0); } pic_value pic_global_ref(pic_state *pic, pic_value uid) { pic_value val; if (! pic_weak_has(pic, pic->globals, uid)) { pic_error(pic, "undefined variable", 1, uid); } val = pic_weak_ref(pic, pic->globals, uid);; if (pic_invalid_p(pic, val)) { pic_error(pic, "uninitialized global variable", 1, uid); } return val; } void pic_global_set(pic_state *pic, pic_value uid, pic_value value) { if (! pic_weak_has(pic, pic->globals, uid)) { pic_error(pic, "undefined variable", 1, uid); } pic_weak_set(pic, pic->globals, uid, value); } pic_value pic_ref(pic_state *pic, const char *lib, const char *name) { pic_value sym, env; sym = pic_intern_cstr(pic, name); env = pic_library_environment(pic, lib); return pic_global_ref(pic, pic_find_identifier(pic, sym, env)); } void pic_set(pic_state *pic, const char *lib, const char *name, pic_value val) { pic_value sym, env; sym = pic_intern_cstr(pic, name); env = pic_library_environment(pic, lib); pic_global_set(pic, pic_find_identifier(pic, sym, env), val); } void pic_define(pic_state *pic, const char *lib, const char *name, pic_value val) { pic_value sym, uid, env; sym = pic_intern_cstr(pic, name); env = pic_library_environment(pic, lib); uid = pic_find_identifier(pic, sym, env); if (pic_weak_has(pic, pic->globals, uid)) { pic_warnf(pic, "redefining variable: %s", pic_str(pic, pic_sym_name(pic, uid), NULL)); } pic_weak_set(pic, pic->globals, uid, val); } void pic_defun(pic_state *pic, const char *name, pic_func_t f) { pic_define(pic, pic_current_library(pic), name, pic_make_proc(pic, f, 0, NULL)); pic_export(pic, pic_intern_cstr(pic, name)); } void pic_defvar(pic_state *pic, const char *name, pic_value init) { pic_define(pic, pic_current_library(pic), name, pic_make_var(pic, init, pic_false_value(pic))); pic_export(pic, pic_intern_cstr(pic, name)); } pic_value pic_funcall(pic_state *pic, const char *lib, const char *name, int n, ...) { pic_value proc, r; va_list ap; proc = pic_ref(pic, lib, name); TYPE_CHECK(pic, proc, proc); va_start(ap, n); r = pic_vcall(pic, proc, n, ap); va_end(ap); return r; }