static pic_value
pic_vec_vector_copy_i(pic_state *pic)
{
pic_vec *to, *from;
int n, at, start, end;
n = pic_get_args(pic, "viv|ii", &to, &at, &from, &start, &end);
switch (n) {
case 3:
start = 0;
case 4:
end = from->len;
}
if (to == from && (start <= at && at < end)) {
/* copy in reversed order */
at += end - start;
while (start < end) {
to->data[--at] = from->data[--end];
}
return pic_undef_value();
}
while (start < end) {
to->data[at++] = from->data[start++];
}
return pic_undef_value();
}
static pic_value
pic_vec_vector_for_each(pic_state *pic)
{
struct pic_proc *proc;
int argc, i, len, j;
pic_value *argv, vals;
pic_get_args(pic, "l*", &proc, &argc, &argv);
len = INT_MAX;
for (i = 0; i < argc; ++i) {
pic_assert_type(pic, argv[i], vec);
len = len < pic_vec_ptr(argv[i])->len
? len
: pic_vec_ptr(argv[i])->len;
}
for (i = 0; i < len; ++i) {
vals = pic_nil_value();
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_vec_ptr(argv[j])->data[i], vals);
}
pic_apply_list(pic, proc, vals);
}
return pic_undef_value();
}
static pic_value
pic_str_string_for_each(pic_state *pic)
{
struct pic_proc *proc;
int argc, len, i, j;
pic_value *argv, vals;
pic_get_args(pic, "l*", &proc, &argc, &argv);
if (argc == 0) {
pic_errorf(pic, "string-map: one or more strings expected, but got zero");
} else {
pic_assert_type(pic, argv[0], str);
len = pic_str_len(pic_str_ptr(argv[0]));
}
for (i = 1; i < argc; ++i) {
pic_assert_type(pic, argv[i], str);
len = len < pic_str_len(pic_str_ptr(argv[i]))
? len
: pic_str_len(pic_str_ptr(argv[i]));
}
for (i = 0; i < len; ++i) {
vals = pic_nil_value();
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
}
pic_apply_list(pic, proc, vals);
}
return pic_undef_value();
}
static pic_value
weak_call(pic_state *pic)
{
pic_value key, val, weak;
int n;
n = pic_get_args(pic, "o|o", &key, &val);
if (! pic_obj_p(pic, key)) {
pic_error(pic, "attempted to set a non-object key", 1, key);
}
weak = pic_closure_ref(pic, 0);
if (n == 1) {
if (! pic_weak_has(pic, weak, key)) {
return pic_false_value(pic);
}
return pic_cons(pic, key, pic_weak_ref(pic, weak, key));
} else {
if (pic_undef_p(pic, val)) {
if (pic_weak_has(pic, weak, key)) {
pic_weak_del(pic, weak, key);
}
} else {
pic_weak_set(pic, weak, key, val);
}
return pic_undef_value(pic);
}
}
static pic_value
pic_write_display(pic_state *pic)
{
pic_value v, port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write_value(pic, v, port, DISPLAY_MODE, OP_WRITE);
return pic_undef_value(pic);
}
static pic_value
pic_write_write_shared(pic_state *pic)
{
pic_value v, port = pic_stdout(pic);
pic_get_args(pic, "o|p", &v, &port);
write_value(pic, v, port, WRITE_MODE, OP_WRITE_SHARED);
return pic_undef_value(pic);
}
void
pic_close(pic_state *pic)
{
xh_entry *it;
/* invoke exit handlers */
while (pic->wind) {
if (pic->wind->out) {
pic_apply0(pic, pic->wind->out);
}
pic->wind = pic->wind->prev;
}
/* free symbol names */
for (it = xh_begin(&pic->syms); it != NULL; it = xh_next(it)) {
free(xh_key(it, char *));
}
/* clear out root objects */
pic->sp = pic->stbase;
pic->ci = pic->cibase;
pic->xp = pic->xpbase;
pic->arena_idx = 0;
pic->err = pic_undef_value();
pic->globals = NULL;
pic->macros = NULL;
xh_clear(&pic->syms);
xh_clear(&pic->attrs);
pic->features = pic_nil_value();
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);
free(pic->xpbase);
/* 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);
xh_destroy(&pic->attrs);
/* free GC arena */
free(pic->arena);
free(pic);
}
pic_value
pic_values(pic_state *pic, int argc, pic_value *argv)
{
int i;
for (i = 0; i < argc; ++i) {
pic->sp[i] = argv[i];
}
pic->ci->retc = (int)argc;
return argc == 0 ? pic_undef_value() : pic->sp[0];
}
pic_value
pic_values_by_array(pic_state *pic, size_t argc, pic_value *argv)
{
size_t i;
for (i = 0; i < argc; ++i) {
pic->sp[i] = argv[i];
}
pic->ci->retc = (int)argc;
return argc == 0 ? pic_undef_value() : pic->sp[0];
}
static pic_value
pic_str_string_set(pic_state *pic)
{
pic_str *str;
char c;
int k;
pic_get_args(pic, "sic", &str, &k, &c);
pic_str_set(pic, str, k, c);
return pic_undef_value();
}
static pic_value
pic_load_load(pic_state *pic)
{
pic_value envid;
char *fn;
pic_get_args(pic, "z|o", &fn, &envid);
pic_load(pic, fn);
return pic_undef_value();
}
pic_value
pic_file_delete(pic_state *pic)
{
char *fname;
pic_get_args(pic, "z", &fname);
if (remove(fname) != 0) {
file_error(pic, "file cannot be deleted");
}
return pic_undef_value();
}
static pic_value
pic_record_record_set(pic_state *pic)
{
struct pic_record *rec;
pic_sym *slot;
pic_value val;
pic_get_args(pic, "rmo", &rec, &slot, &val);
pic_record_set(pic, rec, slot, val);
return pic_undef_value();
}
static pic_value
reg_set(pic_state *pic, struct pic_reg *reg, void *key, pic_value val)
{
if (pic_undef_p(val)) {
if (pic_reg_has(pic, reg, key)) {
pic_reg_del(pic, reg, key);
}
} else {
pic_reg_set(pic, reg, key, val);
}
return pic_undef_value();
}
pic_value
pic_values_by_list(pic_state *pic, pic_value list)
{
pic_value v, it;
int i;
i = 0;
pic_for_each (v, list, it) {
pic->sp[i++] = v;
}
pic->ci->retc = i;
return pic_nil_p(list) ? pic_undef_value() : pic->sp[0];
}
struct pic_vector *
pic_make_vec(pic_state *pic, int len)
{
struct pic_vector *vec;
int i;
vec = (struct pic_vector *)pic_obj_alloc(pic, sizeof(struct pic_vector), PIC_TT_VECTOR);
vec->len = len;
vec->data = (pic_value *)pic_malloc(pic, sizeof(pic_value) * len);
for (i = 0; i < len; ++i) {
vec->data[i] = pic_undef_value();
}
return vec;
}
static pic_value
dynamic_set(pic_state *pic)
{
pic_value var, val;
pic_get_args(pic, "");
var = pic_closure_ref(pic, 0);
val = pic_closure_ref(pic, 1);
pic_proc_ptr(pic, var)->locals[0] = val;
return pic_undef_value(pic);
}
static pic_value
pic_vec_vector_set(pic_state *pic)
{
struct pic_vector *v;
int k;
pic_value o;
pic_get_args(pic, "vio", &v, &k, &o);
if (v->len <= k) {
pic_errorf(pic, "vector-set!: index out of range");
}
v->data[k] = o;
return pic_undef_value();
}
static pic_value
pic_load_load(pic_state *pic)
{
pic_value envid;
char *fn;
struct pic_port *port;
pic_get_args(pic, "z|o", &fn, &envid);
port = pic_open_file(pic, fn, PIC_PORT_IN | PIC_PORT_TEXT);
pic_load(pic, port);
pic_close_port(pic, port);
return pic_undef_value();
}
static pic_value
pic_blob_bytevector_u8_set(pic_state *pic)
{
unsigned char *buf;
int len, k, v;
pic_get_args(pic, "bii", &buf, &len, &k, &v);
if (v < 0 || v > 255)
pic_error(pic, "byte out of range", 0);
VALID_INDEX(pic, len, k);
buf[k] = (unsigned char)v;
return pic_undef_value(pic);
}
void
pic_save_point(pic_state *pic, struct pic_cont *cont)
{
cont->jmp.prev = pic->jmp;
pic->jmp = &cont->jmp;
/* save runtime context */
cont->cp = pic->cp;
cont->sp_offset = pic->sp - pic->stbase;
cont->ci_offset = pic->ci - pic->cibase;
cont->xp_offset = pic->xp - pic->xpbase;
cont->arena_idx = pic->arena_idx;
cont->ip = pic->ip;
cont->ptable = pic->ptable;
cont->results = pic_undef_value();
}
static pic_value
pic_dict_dictionary_set(pic_state *pic)
{
struct pic_dict *dict;
pic_sym *key;
pic_value val;
pic_get_args(pic, "dmo", &dict, &key, &val);
if (pic_undef_p(val)) {
if (pic_dict_has(pic, dict, key)) {
pic_dict_del(pic, dict, key);
}
}
else {
pic_dict_set(pic, dict, key, val);
}
return pic_undef_value();
}
static pic_value
pic_dict_dictionary_for_each(pic_state *pic)
{
struct pic_proc *proc;
struct pic_dict *dict;
khiter_t it;
khash_t(dict) *kh;
pic_get_args(pic, "ld", &proc, &dict);
kh = &dict->hash;
for (it = kh_begin(kh); it != kh_end(kh); ++it) {
if (kh_exist(kh, it)) {
pic_apply1(pic, proc, pic_obj_value(kh_key(kh, it)));
}
}
return pic_undef_value();
}
static pic_value
pic_str_string_fill_ip(pic_state *pic)
{
pic_str *str;
char c;
int n, start, end;
n = pic_get_args(pic, "sc|ii", &str, &c, &start, &end);
switch (n) {
case 2:
start = 0;
case 3:
end = pic_str_len(str);
}
while (start < end) {
pic_str_set(pic, str, start++, c);
}
return pic_undef_value();
}
static pic_value
pic_blob_bytevector_copy_i(pic_state *pic)
{
unsigned char *to, *from;
int n, at, start, end, tolen, fromlen;
n = pic_get_args(pic, "bib|ii", &to, &tolen, &at, &from, &fromlen, &start, &end);
switch (n) {
case 3:
start = 0;
case 4:
end = fromlen;
}
VALID_ATRANGE(pic, tolen, at, fromlen, start, end);
memmove(to + at, from + start, end - start);
return pic_undef_value(pic);
}
static pic_value
pic_load_load(pic_state *pic)
{
pic_value envid, port;
char *fn;
FILE *fp;
pic_get_args(pic, "z|o", &fn, &envid);
fp = fopen(fn, "r");
if (fp == NULL) {
pic_error(pic, "load: could not open file", 1, pic_cstr_value(pic, fn));
}
port = pic_fopen(pic, fp, "r");
pic_load(pic, port);
pic_fclose(pic, port);
return pic_undef_value(pic);
}
static pic_value
pic_vec_vector_fill_i(pic_state *pic)
{
pic_vec *vec;
pic_value obj;
int n, start, end;
n = pic_get_args(pic, "vo|ii", &vec, &obj, &start, &end);
switch (n) {
case 2:
start = 0;
case 3:
end = vec->len;
}
while (start < end) {
vec->data[start++] = obj;
}
return pic_undef_value();
}
static pic_value
pic_str_string_copy_ip(pic_state *pic)
{
pic_str *to, *from;
int n, at, start, end;
n = pic_get_args(pic, "sis|ii", &to, &at, &from, &start, &end);
switch (n) {
case 3:
start = 0;
case 4:
end = pic_str_len(from);
}
if (to == from) {
from = pic_str_sub(pic, from, 0, end);
}
while (start < end) {
pic_str_set(pic, to, at++, pic_str_ref(pic, from, start++));
}
return pic_undef_value();
}
void
pic_close(pic_state *pic)
{
size_t i;
/* free global stacks */
free(pic->stbase);
free(pic->cibase);
free(pic->rescue);
free(pic->globals);
xh_destroy(pic->sym_tbl);
xh_destroy(pic->global_tbl);
pic->glen = 0;
pic->rlen = 0;
pic->arena_idx = 0;
pic->lib_tbl = pic_undef_value();
/* free all values */
pic_gc_run(pic);
/* free heaps */
finalize_heap(pic->heap);
free(pic->heap);
/* free symbol names */
for (i = 0; i < pic->slen; ++i) {
free((void *)pic->sym_pool[i]);
}
free(pic->sym_pool);
PIC_BLK_DECREF(pic, pic->blk);
free(pic);
}
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;
}
