2014-08-25 00:38:09 -04:00
|
|
|
/**
|
|
|
|
* See Copyright Notice in picrin.h
|
|
|
|
*/
|
|
|
|
|
|
|
|
#include "picrin.h"
|
|
|
|
#include "picrin/gc.h"
|
|
|
|
#include "picrin/read.h"
|
|
|
|
#include "picrin/proc.h"
|
|
|
|
#include "picrin/macro.h"
|
|
|
|
#include "picrin/cont.h"
|
2014-09-01 00:43:54 -04:00
|
|
|
#include "picrin/port.h"
|
2014-08-25 00:38:09 -04:00
|
|
|
#include "picrin/error.h"
|
2015-01-18 07:25:34 -05:00
|
|
|
#include "picrin/dict.h"
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
void pic_init_core(pic_state *);
|
|
|
|
|
|
|
|
pic_state *
|
2014-09-08 11:08:15 -04:00
|
|
|
pic_open(int argc, char *argv[], char **envp)
|
2014-08-25 00:38:09 -04:00
|
|
|
{
|
2014-09-16 02:06:45 -04:00
|
|
|
struct pic_port *pic_make_standard_port(pic_state *, xFILE *, short);
|
2014-08-25 00:38:09 -04:00
|
|
|
char t;
|
|
|
|
|
|
|
|
pic_state *pic;
|
|
|
|
size_t ai;
|
|
|
|
|
|
|
|
pic = malloc(sizeof(pic_state));
|
|
|
|
|
|
|
|
/* root block */
|
2014-09-17 02:09:15 -04:00
|
|
|
pic->wind = NULL;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
/* 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;
|
|
|
|
|
2014-09-18 01:50:01 -04:00
|
|
|
/* exception handler */
|
|
|
|
pic->xpbase = pic->xp = calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
|
|
|
|
pic->xpend = pic->xpbase + PIC_RESCUE_SIZE;
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
/* memory heap */
|
|
|
|
pic->heap = pic_heap_open();
|
|
|
|
|
|
|
|
/* symbol table */
|
|
|
|
xh_init_str(&pic->syms, sizeof(pic_sym));
|
|
|
|
xh_init_int(&pic->sym_names, sizeof(const char *));
|
|
|
|
pic->sym_cnt = 0;
|
|
|
|
pic->uniq_sym_cnt = 0;
|
|
|
|
|
|
|
|
/* global variables */
|
2015-01-18 07:25:34 -05:00
|
|
|
pic->globals = NULL;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
/* macros */
|
2015-01-18 07:25:34 -05:00
|
|
|
pic->macros = NULL;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2014-09-24 20:44:21 -04:00
|
|
|
/* attributes */
|
|
|
|
xh_init_ptr(&pic->attrs, sizeof(struct pic_dict *));
|
|
|
|
|
2014-09-09 12:41:10 -04:00
|
|
|
/* features */
|
|
|
|
pic->features = pic_nil_value();
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
/* libraries */
|
|
|
|
pic->libs = pic_nil_value();
|
|
|
|
pic->lib = NULL;
|
|
|
|
|
|
|
|
/* reader */
|
|
|
|
pic->reader = malloc(sizeof(struct pic_reader));
|
|
|
|
pic->reader->typecase = PIC_CASE_DEFAULT;
|
2014-09-12 06:49:00 -04:00
|
|
|
pic->reader->trie = pic_make_trie(pic);
|
2014-08-25 00:38:09 -04:00
|
|
|
xh_init_int(&pic->reader->labels, sizeof(pic_value));
|
|
|
|
|
2014-09-18 01:50:01 -04:00
|
|
|
/* raised error object */
|
2014-09-16 11:28:55 -04:00
|
|
|
pic->err = pic_undef_value();
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2014-09-01 00:43:54 -04:00
|
|
|
/* standard ports */
|
|
|
|
pic->xSTDIN = NULL;
|
|
|
|
pic->xSTDOUT = NULL;
|
|
|
|
pic->xSTDERR = NULL;
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
/* GC arena */
|
|
|
|
pic->arena = calloc(PIC_ARENA_SIZE, sizeof(struct pic_object **));
|
|
|
|
pic->arena_size = PIC_ARENA_SIZE;
|
|
|
|
pic->arena_idx = 0;
|
|
|
|
|
|
|
|
/* native stack marker */
|
|
|
|
pic->native_stack_start = &t;
|
|
|
|
|
2014-09-16 02:02:47 -04:00
|
|
|
#define S(slot,name) pic->slot = pic_intern_cstr(pic, name);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
ai = pic_gc_arena_preserve(pic);
|
2014-09-16 02:02:47 -04:00
|
|
|
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?");
|
2015-01-17 04:36:23 -05:00
|
|
|
S(sSYMBOL_P, "symbol?");
|
|
|
|
S(sPAIR_P, "pair?");
|
2014-09-16 02:02:47 -04:00
|
|
|
S(sADD, "+");
|
|
|
|
S(sSUB, "-");
|
|
|
|
S(sMUL, "*");
|
|
|
|
S(sDIV, "/");
|
|
|
|
S(sMINUS, "minus");
|
|
|
|
S(sEQ, "=");
|
|
|
|
S(sLT, "<");
|
|
|
|
S(sLE, "<=");
|
|
|
|
S(sGT, ">");
|
|
|
|
S(sGE, ">=");
|
|
|
|
S(sNOT, "not");
|
2014-09-16 11:28:55 -04:00
|
|
|
S(sREAD, "read");
|
|
|
|
S(sFILE, "file");
|
2014-08-25 00:38:09 -04:00
|
|
|
pic_gc_arena_restore(pic, ai);
|
|
|
|
|
2014-09-16 02:02:47 -04:00
|
|
|
#define R(slot,name) pic->slot = pic_gensym(pic, pic_intern_cstr(pic, name));
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
ai = pic_gc_arena_preserve(pic);
|
2014-09-16 02:02:47 -04:00
|
|
|
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");
|
2014-08-25 00:38:09 -04:00
|
|
|
pic_gc_arena_restore(pic, ai);
|
|
|
|
|
2015-01-18 07:25:34 -05:00
|
|
|
/* root tables */
|
|
|
|
pic->globals = pic_make_dict(pic);
|
|
|
|
pic->macros = pic_make_dict(pic);
|
|
|
|
|
2014-08-25 00:38:09 -04:00
|
|
|
/* root block */
|
2014-09-17 02:09:15 -04:00
|
|
|
pic->wind = pic_alloc(pic, sizeof(struct pic_winder));
|
|
|
|
pic->wind->prev = NULL;
|
|
|
|
pic->wind->depth = 0;
|
|
|
|
pic->wind->in = pic->wind->out = NULL;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2014-09-01 00:01:17 -04:00
|
|
|
/* init readers */
|
|
|
|
pic_init_reader(pic);
|
|
|
|
|
|
|
|
/* standard libraries */
|
2014-09-01 00:07:38 -04:00
|
|
|
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)"));
|
2014-09-01 00:01:17 -04:00
|
|
|
pic->lib = pic->PICRIN_USER;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
2014-09-01 00:43:54 -04:00
|
|
|
/* standard I/O */
|
2014-09-16 02:06:45 -04:00
|
|
|
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);
|
2014-09-01 00:43:54 -04:00
|
|
|
|
2014-09-01 00:01:17 -04:00
|
|
|
pic_init_core(pic);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
return pic;
|
|
|
|
}
|
|
|
|
|
|
|
|
void
|
|
|
|
pic_close(pic_state *pic)
|
|
|
|
{
|
2014-09-16 03:44:44 -04:00
|
|
|
xh_entry *it;
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
/* invoke exit handlers */
|
2014-09-17 02:09:15 -04:00
|
|
|
while (pic->wind) {
|
|
|
|
if (pic->wind->out) {
|
|
|
|
pic_apply0(pic, pic->wind->out);
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
2014-09-17 02:09:15 -04:00
|
|
|
pic->wind = pic->wind->prev;
|
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;
|
2014-09-16 11:28:55 -04:00
|
|
|
pic->err = pic_undef_value();
|
2015-01-18 07:25:34 -05:00
|
|
|
pic->globals = NULL;
|
|
|
|
pic->macros = NULL;
|
2014-09-24 20:44:21 -04:00
|
|
|
xh_clear(&pic->attrs);
|
2014-09-09 12:41:10 -04:00
|
|
|
pic->features = pic_nil_value();
|
2014-08-25 00:38:09 -04:00
|
|
|
pic->libs = pic_nil_value();
|
|
|
|
|
|
|
|
/* free all heap objects */
|
|
|
|
pic_gc_run(pic);
|
|
|
|
|
|
|
|
/* free heaps */
|
|
|
|
pic_heap_close(pic->heap);
|
|
|
|
|
|
|
|
/* free runtime context */
|
|
|
|
free(pic->stbase);
|
|
|
|
free(pic->cibase);
|
2014-09-18 01:50:01 -04:00
|
|
|
free(pic->xpbase);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
/* free reader struct */
|
|
|
|
xh_destroy(&pic->reader->labels);
|
|
|
|
pic_trie_delete(pic, pic->reader->trie);
|
|
|
|
free(pic->reader);
|
|
|
|
|
|
|
|
/* free global stacks */
|
|
|
|
xh_destroy(&pic->syms);
|
2014-09-24 20:44:21 -04:00
|
|
|
xh_destroy(&pic->attrs);
|
2014-08-25 00:38:09 -04:00
|
|
|
|
|
|
|
/* free GC arena */
|
|
|
|
free(pic->arena);
|
|
|
|
|
|
|
|
/* free symbol names */
|
2014-09-16 03:44:44 -04:00
|
|
|
for (it = xh_begin(&pic->sym_names); it != NULL; it = xh_next(it)) {
|
|
|
|
free(xh_val(it, char *));
|
2014-08-25 00:38:09 -04:00
|
|
|
}
|
|
|
|
xh_destroy(&pic->sym_names);
|
|
|
|
|
|
|
|
free(pic);
|
|
|
|
}
|