picrin/lib/state.c

407 lines
8.6 KiB
C

/**
* See Copyright Notice in picrin.h
*/
#include "picrin.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;
}