picrin/extlib/benz/state.c

441 lines
9.5 KiB
C
Raw Normal View History

2014-08-25 00:38:09 -04:00
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
2016-02-18 23:58:45 -05:00
#include "picrin/object.h"
2014-08-25 00:38:09 -04:00
2015-01-26 00:31:36 -05:00
static void
pic_init_features(pic_state *pic)
{
pic_add_feature(pic, "picrin");
2015-07-19 13:19:41 -04:00
#if __STDC_IEC_559__
2015-01-26 00:31:36 -05:00
pic_add_feature(pic, "ieee-float");
#endif
2015-01-26 00:31:36 -05:00
#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
}
2016-02-09 11:38:05 -05:00
void
pic_add_feature(pic_state *pic, const char *feature)
{
2016-02-20 01:31:14 -05:00
pic_push(pic, pic_intern_cstr(pic, feature), pic->features);
2016-02-09 11:38:05 -05:00
}
static pic_value
pic_features(pic_state *pic)
{
pic_get_args(pic, "");
return pic->features;
}
2016-02-20 02:33:51 -05:00
#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, pic_obj_value(pic->lib->env)); \
} while (0)
2016-02-20 02:33:51 -05:00
#define declare_vm_procedure(name) do { \
pic_value sym; \
sym = pic_intern_lit(pic, name); \
pic_put_identifier(pic, sym, sym, pic_obj_value(pic->lib->env)); \
} while (0)
2016-02-09 11:38:05 -05:00
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 *);
2016-02-10 07:50:39 -05:00
void pic_init_weak(pic_state *);
2016-02-09 11:38:05 -05:00
extern const char pic_boot[][80];
2015-01-26 00:31:36 -05:00
static void
pic_init_core(pic_state *pic)
{
size_t ai;
2015-06-09 07:20:56 -04:00
2015-01-26 00:31:36 -05:00
pic_init_features(pic);
pic_deflibrary(pic, "picrin.base");
2016-02-19 02:17:13 -05:00
ai = pic_enter(pic);
2015-05-27 10:08:47 -04:00
2016-02-19 02:17:13 -05:00
#define DONE pic_leave(pic, ai);
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");
declare_vm_procedure("cons");
declare_vm_procedure("car");
declare_vm_procedure("cdr");
declare_vm_procedure("null?");
declare_vm_procedure("symbol?");
declare_vm_procedure("pair?");
declare_vm_procedure("+");
declare_vm_procedure("-");
declare_vm_procedure("*");
declare_vm_procedure("/");
declare_vm_procedure("=");
declare_vm_procedure("<");
declare_vm_procedure(">");
declare_vm_procedure("<=");
declare_vm_procedure(">=");
declare_vm_procedure("not");
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_write(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;
pic_defun(pic, "features", pic_features);
pic_try {
pic_load_cstr(pic, &pic_boot[0][0]);
}
pic_catch {
pic_print_backtrace(pic, xstdout);
pic_panic(pic, "");
2015-01-26 00:31:36 -05:00
}
}
2014-08-25 00:38:09 -04:00
pic_state *
2015-06-25 13:09:06 -04:00
pic_open(pic_allocf allocf, void *userdata)
2014-08-25 00:38:09 -04:00
{
char t;
pic_state *pic;
size_t ai;
2015-08-10 08:13:23 -04:00
pic = allocf(userdata, NULL, sizeof(pic_state));
2014-08-25 00:38:09 -04:00
2015-05-27 10:08:47 -04:00
if (! pic) {
goto EXIT_PIC;
}
2015-05-27 13:12:26 -04:00
/* allocator */
pic->allocf = allocf;
2015-06-25 13:09:06 -04:00
/* user data */
pic->userdata = userdata;
2015-01-18 22:14:29 -05:00
/* turn off GC */
pic->gc_enable = false;
2015-06-22 14:02:12 -04:00
/* continuation chain */
pic->cc = NULL;
pic->ccnt = 0;
2014-08-25 00:38:09 -04:00
/* root block */
2015-06-08 08:04:04 -04:00
pic->cp = NULL;
2014-08-25 00:38:09 -04:00
/* prepare VM stack */
2015-08-10 08:13:23 -04:00
pic->stbase = pic->sp = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_value));
2014-08-25 00:38:09 -04:00
pic->stend = pic->stbase + PIC_STACK_SIZE;
2015-05-27 10:08:47 -04:00
if (! pic->sp) {
goto EXIT_SP;
}
2014-08-25 00:38:09 -04:00
/* callinfo */
2015-08-10 08:13:23 -04:00
pic->cibase = pic->ci = allocf(userdata, NULL, PIC_STACK_SIZE * sizeof(pic_callinfo));
2014-08-25 00:38:09 -04:00
pic->ciend = pic->cibase + PIC_STACK_SIZE;
2015-05-27 10:08:47 -04:00
if (! pic->ci) {
goto EXIT_CI;
}
2014-09-18 01:50:01 -04:00
/* exception handler */
2015-08-10 08:13:23 -04:00
pic->xpbase = pic->xp = allocf(userdata, NULL, PIC_RESCUE_SIZE * sizeof(struct pic_proc *));
2014-09-18 01:50:01 -04:00
pic->xpend = pic->xpbase + PIC_RESCUE_SIZE;
2015-05-27 10:08:47 -04:00
if (! pic->xp) {
goto EXIT_XP;
}
/* GC arena */
2015-08-10 08:13:23 -04:00
pic->arena = allocf(userdata, NULL, PIC_ARENA_SIZE * sizeof(struct pic_object *));
2015-05-27 10:08:47 -04:00
pic->arena_size = PIC_ARENA_SIZE;
pic->arena_idx = 0;
if (! pic->arena) {
goto EXIT_ARENA;
}
2014-08-25 00:38:09 -04:00
/* memory heap */
pic->heap = pic_heap_open(pic);
2014-08-25 00:38:09 -04:00
/* symbol table */
2016-02-14 22:59:58 -05:00
kh_init(oblist, &pic->oblist);
2014-08-25 00:38:09 -04:00
/* unique symbol count */
pic->ucnt = 0;
2014-08-25 00:38:09 -04:00
/* global variables */
2016-02-19 14:35:15 -05:00
pic->globals = pic_make_weak(pic);
2014-08-25 00:38:09 -04:00
/* macros */
2016-02-19 14:35:15 -05:00
pic->macros = pic_make_weak(pic);
2014-08-25 00:38:09 -04:00
2014-09-09 12:41:10 -04:00
/* features */
pic->features = pic_nil_value(pic);
2014-09-09 12:41:10 -04:00
2014-08-25 00:38:09 -04:00
/* libraries */
kh_init(ltable, &pic->ltable);
2014-08-25 00:38:09 -04:00
pic->lib = NULL;
2016-02-04 10:30:11 -05:00
/* ireps */
pic->ireps.next = &pic->ireps;
pic->ireps.prev = &pic->ireps;
2014-09-18 01:50:01 -04:00
/* raised error object */
2016-02-20 05:00:41 -05:00
pic->err = pic_invalid_value(pic);
2014-08-25 00:38:09 -04:00
2015-06-18 14:06:57 -04:00
/* file pool */
2015-06-18 16:00:36 -04:00
memset(pic->files, 0, sizeof pic->files);
2016-02-18 15:54:50 -05:00
#if PIC_ENABLE_STDIO
xfopen_file(pic, stdin, "r");
xfopen_file(pic, stdout, "w");
xfopen_file(pic, stderr, "w");
pic->files[1].flag |= X_LNBUF;
pic->files[2].flag |= X_UNBUF;
#else
xfopen_null(pic, "r");
xfopen_null(pic, "w");
xfopen_null(pic, "w");
#endif
2015-06-18 14:06:57 -04:00
2015-06-08 09:28:17 -04:00
/* parameter table */
pic->ptable = pic_nil_value(pic);
2015-06-08 09:28:17 -04:00
2014-08-25 00:38:09 -04:00
/* native stack marker */
pic->native_stack_start = &t;
2016-02-19 02:17:13 -05:00
ai = pic_enter(pic);
2015-01-18 22:14:29 -05:00
2016-02-07 14:10:22 -05:00
#define S(slot,name) pic->slot = pic_intern_lit(pic, name)
2014-08-25 00:38:09 -04:00
S(sDEFINE, "define");
S(sDEFINE_MACRO, "define-macro");
S(sLAMBDA, "lambda");
S(sIF, "if");
S(sBEGIN, "begin");
S(sSETBANG, "set!");
2014-09-16 02:02:47 -04:00
S(sQUOTE, "quote");
S(sQUASIQUOTE, "quasiquote");
S(sUNQUOTE, "unquote");
S(sUNQUOTE_SPLICING, "unquote-splicing");
2015-06-10 02:18:03 -04:00
S(sSYNTAX_QUOTE, "syntax-quote");
S(sSYNTAX_QUASIQUOTE, "syntax-quasiquote");
S(sSYNTAX_UNQUOTE, "syntax-unquote");
S(sSYNTAX_UNQUOTE_SPLICING, "syntax-unquote-splicing");
2014-09-16 02:02:47 -04:00
S(sIMPORT, "import");
S(sEXPORT, "export");
S(sDEFINE_LIBRARY, "define-library");
S(sCOND_EXPAND, "cond-expand");
2015-01-19 00:35:42 -05:00
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(sEQ, "=");
S(sLT, "<");
S(sLE, "<=");
S(sGT, ">");
S(sGE, ">=");
S(sNOT, "not");
2014-08-25 00:38:09 -04:00
2016-02-19 02:17:13 -05:00
pic_leave(pic, ai);
2014-08-25 00:38:09 -04:00
/* root tables */
2016-02-10 07:50:39 -05:00
pic->globals = pic_make_weak(pic);
pic->macros = pic_make_weak(pic);
2014-08-25 00:38:09 -04:00
/* root block */
pic->cp = (struct pic_checkpoint *)pic_obj_alloc(pic, sizeof(struct pic_checkpoint), PIC_TYPE_CP);
2015-06-08 08:04:04 -04:00
pic->cp->prev = NULL;
pic->cp->depth = 0;
pic->cp->in = pic->cp->out = NULL;
2014-08-25 00:38:09 -04:00
2015-01-18 22:14:29 -05:00
/* reader */
2015-06-18 14:14:55 -04:00
pic_reader_init(pic);
2015-06-08 09:28:17 -04:00
/* parameter table */
2016-02-19 14:35:15 -05:00
pic->ptable = pic_cons(pic, pic_make_weak(pic), pic->ptable);
2015-06-08 09:28:17 -04:00
/* standard libraries */
pic_make_library(pic, "picrin.user");
pic_in_library(pic, "picrin.user");
2014-08-25 00:38:09 -04:00
2016-02-19 02:17:13 -05:00
pic_leave(pic, ai);
2015-01-18 22:14:29 -05:00
/* turn on GC */
pic->gc_enable = true;
pic_init_core(pic);
2014-08-25 00:38:09 -04:00
2016-02-19 02:17:13 -05:00
pic_leave(pic, ai);
2015-05-27 10:08:47 -04:00
2014-08-25 00:38:09 -04:00
return pic;
2015-05-27 10:08:47 -04:00
EXIT_ARENA:
2015-08-10 08:13:23 -04:00
allocf(userdata, pic->xp, 0);
2015-05-27 10:08:47 -04:00
EXIT_XP:
2015-08-10 08:13:23 -04:00
allocf(userdata, pic->ci, 0);
2015-05-27 10:08:47 -04:00
EXIT_CI:
2015-08-10 08:13:23 -04:00
allocf(userdata, pic->sp, 0);
2015-05-27 10:08:47 -04:00
EXIT_SP:
2015-08-10 08:13:23 -04:00
allocf(userdata, pic, 0);
2015-05-27 10:08:47 -04:00
EXIT_PIC:
return NULL;
2014-08-25 00:38:09 -04:00
}
void
pic_close(pic_state *pic)
{
2015-05-27 13:12:26 -04:00
pic_allocf allocf = pic->allocf;
2014-08-25 00:38:09 -04:00
/* clear out root objects */
pic->sp = pic->stbase;
pic->ci = pic->cibase;
2014-09-18 01:50:01 -04:00
pic->xp = pic->xpbase;
2014-08-25 00:38:09 -04:00
pic->arena_idx = 0;
2016-02-20 05:00:41 -05:00
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);
2014-08-25 00:38:09 -04:00
/* free all heap objects */
2016-02-13 23:17:12 -05:00
pic_gc(pic);
2014-08-25 00:38:09 -04:00
2016-02-04 10:30:11 -05:00
#if 0
{
/* FIXME */
int i = 0;
struct pic_list *list;
for (list = pic->ireps.next; list != &pic->ireps; list = list->next) {
i++;
}
printf("%d\n", i);
}
#endif
2015-06-10 09:37:05 -04:00
/* flush all xfiles */
2015-06-18 13:05:56 -04:00
xfflush(pic, NULL);
2015-06-10 09:37:05 -04:00
2014-08-25 00:38:09 -04:00
/* free heaps */
pic_heap_close(pic, pic->heap);
2014-08-25 00:38:09 -04:00
/* free reader struct */
2015-06-18 14:14:55 -04:00
pic_reader_destroy(pic);
2014-08-25 00:38:09 -04:00
/* free runtime context */
2015-08-10 08:13:23 -04:00
allocf(pic->userdata, pic->stbase, 0);
allocf(pic->userdata, pic->cibase, 0);
allocf(pic->userdata, pic->xpbase, 0);
2014-08-25 00:38:09 -04:00
/* free global stacks */
kh_destroy(oblist, &pic->oblist);
kh_destroy(ltable, &pic->ltable);
2014-08-25 00:38:09 -04:00
/* free GC arena */
2015-08-10 08:13:23 -04:00
allocf(pic->userdata, pic->arena, 0);
2014-08-25 00:38:09 -04:00
2015-08-10 08:13:23 -04:00
allocf(pic->userdata, pic, 0);
2014-08-25 00:38:09 -04:00
}