static pic_value
pic_system_getenvs(pic_state *pic)
{
char **envp;
pic_value data = pic_nil_value();
size_t ai = pic_gc_arena_preserve(pic);
pic_get_args(pic, "");
if (! pic->envp) {
return pic_nil_value();
}
for (envp = pic->envp; *envp; ++envp) {
pic_str *key, *val;
size_t i;
for (i = 0; (*envp)[i] != '='; ++i)
;
key = pic_make_str(pic, *envp, i);
val = pic_make_str_cstr(pic, getenv(pic_str_cstr(key)));
/* push */
data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, data);
}
return data;
}
static pic_value
pic_proc_map(pic_state *pic)
{
struct pic_proc *proc;
size_t argc;
pic_value *args;
int i;
pic_value cars, ret;
pic_get_args(pic, "l*", &proc, &argc, &args);
ret = pic_nil_value();
do {
cars = pic_nil_value();
for (i = argc - 1; i >= 0; --i) {
if (! pic_pair_p(args[i])) {
break;
}
cars = pic_cons(pic, pic_car(pic, args[i]), cars);
args[i] = pic_cdr(pic, args[i]);
}
if (i >= 0)
break;
ret = pic_cons(pic, pic_apply(pic, proc, cars), ret);
} while (1);
return pic_reverse(pic, ret);
}
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);
}
static pic_value
pic_regexp_regexp_match(pic_state *pic)
{
pic_value reg;
const char *input;
regmatch_t match[100];
pic_value matches, positions;
pic_str *str;
int i, offset;
pic_get_args(pic, "oz", ®, &input);
pic_assert_type(pic, reg, regexp);
matches = pic_nil_value();
positions = pic_nil_value();
if (strchr(pic_regexp_data_ptr(reg)->flags, 'g') != NULL) {
/* global search */
offset = 0;
while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, match, 0) != REG_NOMATCH) {
pic_push(pic, pic_obj_value(pic_str_new(pic, input, match[0].rm_eo - match[0].rm_so)), matches);
pic_push(pic, pic_int_value(offset), positions);
offset += match[0].rm_eo;
input += match[0].rm_eo;
}
} else {
/* local search */
if (regexec(&pic_regexp_data_ptr(reg)->reg, input, 100, match, 0) == 0) {
for (i = 0; i < 100; ++i) {
if (match[i].rm_so == -1) {
break;
}
str = pic_str_new(pic, input + match[i].rm_so, match[i].rm_eo - match[i].rm_so);
pic_push(pic, pic_obj_value(str), matches);
pic_push(pic, pic_int_value(match[i].rm_so), positions);
}
}
}
if (pic_nil_p(matches)) {
matches = pic_false_value();
positions = pic_false_value();
} else {
matches = pic_reverse(pic, matches);
positions = pic_reverse(pic, positions);
}
return pic_values2(pic, matches, positions);
}
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();
}
PIC_NORETURN static void
file_error(pic_state *pic, const char *msg)
{
struct pic_error *e;
e = pic_make_error(pic, pic_intern(pic, "file"), msg, pic_nil_value());
pic_raise(pic, pic_obj_value(e));
}
struct pic_port *
pic_stdout(pic_state *pic)
{
pic_value obj;
obj = pic_funcall(pic, pic->PICRIN_BASE, "current-output-port", pic_nil_value());
return pic_port_ptr(obj);
}
pic_value
pic_reverse(pic_state *pic, pic_value list)
{
pic_value v, acc = pic_nil_value();
for (v = list; ! pic_nil_p(v); v = pic_cdr(pic ,v)) {
acc = pic_cons(pic, pic_car(pic, v), acc);
}
return acc;
}
pic_value
pic_list_by_array(pic_state *pic, int c, pic_value *vs)
{
pic_value v;
v = pic_nil_value();
while (c--) {
v = pic_cons(pic, vs[c], v);
}
return v;
}
pic_value
pic_make_list(pic_state *pic, int k, pic_value fill)
{
pic_value list;
int i;
list = pic_nil_value();
for (i = 0; i < k; ++i) {
list = pic_cons(pic, fill, list);
}
return list;
}
pic_value
pic_reverse(pic_state *pic, pic_value list)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value v, acc, it;
acc = pic_nil_value();
pic_for_each(v, list, it) {
acc = pic_cons(pic, v, acc);
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, acc);
}
void
pic_init_error(pic_state *pic)
{
pic_defvar(pic, "current-exception-handlers", pic_nil_value(pic), pic_false_value(pic));
pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler);
pic_defun(pic, "raise", pic_error_raise);
pic_defun(pic, "raise-continuable", pic_error_raise_continuable);
pic_defun(pic, "error", pic_error_error);
pic_defun(pic, "error-object?", pic_error_error_object_p);
pic_defun(pic, "error-object-message", pic_error_error_object_message);
pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants);
pic_defun(pic, "error-object-type", pic_error_error_object_type);
}
static pic_value
pic_dict_dictionary_to_alist(pic_state *pic)
{
struct pic_dict *dict;
pic_value item, alist = pic_nil_value();
pic_sym *sym;
khiter_t it;
pic_get_args(pic, "d", &dict);
pic_dict_for_each (sym, dict, it) {
item = pic_cons(pic, pic_obj_value(sym), pic_dict_ref(pic, dict, sym));
pic_push(pic, item, alist);
}
static pic_value
pic_system_getenv(pic_state *pic)
{
char *str, *val;
pic_get_args(pic, "z", &str);
val = getenv(str);
if (val == NULL)
return pic_nil_value();
else
return pic_obj_value(pic_make_str_cstr(pic, val));
}
static pic_value
pic_cont_call_with_values(pic_state *pic)
{
struct pic_proc *producer, *consumer;
size_t argc;
pic_value args[256];
pic_get_args(pic, "ll", &producer, &consumer);
pic_apply(pic, producer, pic_nil_value());
argc = pic_receive(pic, 256, args);
return pic_apply_trampoline(pic, consumer, pic_list_by_array(pic, argc, args));
}
static pic_value
pic_str_string_map(pic_state *pic)
{
struct pic_proc *proc;
pic_value *argv, vals, val;
int argc, i, len, j;
pic_str *str;
char *buf;
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]));
}
buf = pic_malloc(pic, len);
pic_try {
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);
}
val = pic_apply_list(pic, proc, vals);
pic_assert_type(pic, val, char);
buf[i] = pic_char(val);
}
str = pic_make_str(pic, buf, len);
}
pic_catch {
pic_free(pic, buf);
pic_raise(pic, pic->err);
}
pic_free(pic, buf);
return pic_obj_value(str);
}
pic_value
pic_list(pic_state *pic, size_t c, ...)
{
va_list ap;
pic_value v;
va_start(ap, c);
v = pic_nil_value();
while (c--) {
v = pic_cons(pic, va_arg(ap, pic_value), v);
}
va_end(ap);
return pic_reverse(pic, v);
}
static pic_value
pic_system_cmdline(pic_state *pic)
{
pic_value v = pic_nil_value();
int i;
pic_get_args(pic, "");
for (i = 0; i < pic->argc; ++i) {
size_t ai = pic_gc_arena_preserve(pic);
v = pic_cons(pic, pic_obj_value(pic_make_str_cstr(pic, pic->argv[i])), v);
pic_gc_arena_restore(pic, ai);
}
return pic_reverse(pic, v);
}
void
pic_load_stdlib(pic_state *pic)
{
static const char *fn = "piclib/built-in.scm";
FILE *file;
int n, i;
pic_value v, vs;
struct pic_proc *proc;
file = fopen(fn, "r");
if (file == NULL) {
fputs("fatal error: could not read built-in.scm", stderr);
abort();
}
n = pic_parse_file(pic, file, &vs);
if (n <= 0) {
fputs("fatal error: built-in.scm broken", stderr);
abort();
}
for (i = 0; i < n; ++i, vs = pic_cdr(pic, vs)) {
v = pic_car(pic, vs);
proc = pic_codegen(pic, v);
if (proc == NULL) {
fputs(pic->errmsg, stderr);
fputs("fatal error: built-in.scm compilation failure", stderr);
abort();
}
v = pic_apply(pic, proc, pic_nil_value());
if (pic_undef_p(v)) {
fputs(pic->errmsg, stderr);
fputs("fatal error: built-in.scm evaluation failure", stderr);
abort();
}
}
#if DEBUG
puts("successfully loaded stdlib");
#endif
}
static pic_value
pic_dict_dictionary_map(pic_state *pic)
{
struct pic_proc *proc;
struct pic_dict *dict;
khiter_t it;
khash_t(dict) *kh;
pic_value ret = pic_nil_value();
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_push(pic, pic_apply1(pic, proc, pic_obj_value(kh_key(kh, it))), ret);
}
}
return pic_reverse(pic, ret);
}
static pic_value
pic_regexp_regexp_split(pic_state *pic)
{
pic_value reg;
const char *input;
regmatch_t match;
pic_value output = pic_nil_value();
pic_get_args(pic, "oz", ®, &input);
pic_assert_type(pic, reg, regexp);
while (regexec(&pic_regexp_data_ptr(reg)->reg, input, 1, &match, 0) != REG_NOMATCH) {
pic_push(pic, pic_obj_value(pic_str_new(pic, input, match.rm_so)), output);
input += match.rm_eo;
}
pic_push(pic, pic_obj_value(pic_str_new_cstr(pic, input)), output);
return pic_reverse(pic, output);
}
static pic_value
pic_vec_vector_to_list(pic_state *pic)
{
struct pic_vector *vec;
pic_value list;
int n, start, end, i;
n = pic_get_args(pic, "v|ii", &vec, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = vec->len;
}
list = pic_nil_value();
for (i = start; i < end; ++i) {
pic_push(pic, vec->data[i], list);
}
return pic_reverse(pic, list);
}
pic_value
pic_values0(pic_state *pic)
{
return pic_values_by_list(pic, pic_nil_value());
}
pic_value
pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
{
char c;
pic_value irrs = pic_nil_value();
while ((c = *fmt++)) {
switch (c) {
default:
xfputc(pic, c, file);
break;
case '%':
c = *fmt++;
if (! c)
goto exit;
switch (c) {
default:
xfputc(pic, c, file);
break;
case '%':
xfputc(pic, '%', file);
break;
case 'c':
xfprintf(pic, file, "%c", va_arg(ap, int));
break;
case 's':
xfprintf(pic, file, "%s", va_arg(ap, const char *));
break;
case 'd':
xfprintf(pic, file, "%d", va_arg(ap, int));
break;
case 'p':
xfprintf(pic, file, "%p", va_arg(ap, void *));
break;
case 'f':
xfprintf(pic, file, "%f", va_arg(ap, double));
break;
}
break;
case '~':
c = *fmt++;
if (! c)
goto exit;
switch (c) {
default:
xfputc(pic, c, file);
break;
case '~':
xfputc(pic, '~', file);
break;
case '%':
xfputc(pic, '\n', file);
break;
case 'a':
irrs = pic_cons(pic, pic_fdisplay(pic, va_arg(ap, pic_value), file), irrs);
break;
case 's':
irrs = pic_cons(pic, pic_fwrite(pic, va_arg(ap, pic_value), file), irrs);
break;
}
break;
}
}
exit:
return pic_reverse(pic, irrs);
}
pic_state *
pic_open(int argc, char *argv[], char **envp)
{
pic_value t;
pic_state *pic;
int ai;
pic = (pic_state *)malloc(sizeof(pic_state));
/* command line */
pic->argc = argc;
pic->argv = argv;
pic->envp = envp;
/* root block */
pic->blk = (struct pic_block *)malloc(sizeof(struct pic_block));
pic->blk->prev = NULL;
pic->blk->depth = 0;
pic->blk->in = pic->blk->out = NULL;
pic->blk->refcnt = 1;
/* prepare VM stack */
pic->stbase = pic->sp = (pic_value *)calloc(PIC_STACK_SIZE, sizeof(pic_value));
pic->stend = pic->stbase + PIC_STACK_SIZE;
/* callinfo */
pic->cibase = pic->ci = (pic_callinfo *)calloc(PIC_STACK_SIZE, sizeof(pic_callinfo));
pic->ciend = pic->cibase + PIC_STACK_SIZE;
/* exception handlers */
pic->rescue = (struct pic_proc **)calloc(PIC_RESCUE_SIZE, sizeof(struct pic_proc *));
pic->ridx = 0;
pic->rlen = PIC_RESCUE_SIZE;
/* memory heap */
pic->heap = (struct pic_heap *)calloc(1, sizeof(struct pic_heap));
init_heap(pic->heap);
/* symbol table */
pic->sym_tbl = xh_new();
pic->sym_pool = (const char **)calloc(PIC_SYM_POOL_SIZE, sizeof(const char *));
pic->slen = 0;
pic->scapa = pic->slen + PIC_SYM_POOL_SIZE;
pic->uniq_sym_count = 0;
/* global variables */
pic->global_tbl = xh_new();
pic->globals = (pic_value *)calloc(PIC_GLOBALS_SIZE, sizeof(pic_value));
pic->glen = 0;
pic->gcapa = PIC_GLOBALS_SIZE;
/* libraries */
pic->lib_tbl = pic_nil_value();
pic->lib = NULL;
/* error handling */
pic->jmp = NULL;
pic->errmsg = NULL;
/* GC arena */
pic->arena_idx = 0;
/* native stack marker */
pic->native_stack_start = &t;
#define register_core_symbol(pic,slot,name) do { \
pic->slot = pic_intern_cstr(pic, name); \
} while (0)
ai = pic_gc_arena_preserve(pic);
register_core_symbol(pic, sDEFINE, "define");
register_core_symbol(pic, sLAMBDA, "lambda");
register_core_symbol(pic, sIF, "if");
register_core_symbol(pic, sBEGIN, "begin");
register_core_symbol(pic, sSETBANG, "set!");
register_core_symbol(pic, sQUOTE, "quote");
register_core_symbol(pic, sQUASIQUOTE, "quasiquote");
register_core_symbol(pic, sUNQUOTE, "unquote");
register_core_symbol(pic, sUNQUOTE_SPLICING, "unquote-splicing");
register_core_symbol(pic, sDEFINE_SYNTAX, "define-syntax");
register_core_symbol(pic, sDEFINE_MACRO, "define-macro");
register_core_symbol(pic, sDEFINE_LIBRARY, "define-library");
register_core_symbol(pic, sIMPORT, "import");
register_core_symbol(pic, sEXPORT, "export");
register_core_symbol(pic, sCONS, "cons");
register_core_symbol(pic, sCAR, "car");
register_core_symbol(pic, sCDR, "cdr");
register_core_symbol(pic, sNILP, "null?");
register_core_symbol(pic, sADD, "+");
register_core_symbol(pic, sSUB, "-");
register_core_symbol(pic, sMUL, "*");
register_core_symbol(pic, sDIV, "/");
register_core_symbol(pic, sMINUS, "minus");
register_core_symbol(pic, sEQ, "=");
register_core_symbol(pic, sLT, "<");
register_core_symbol(pic, sLE, "<=");
register_core_symbol(pic, sGT, ">");
register_core_symbol(pic, sGE, ">=");
pic_gc_arena_restore(pic, ai);
pic_init_core(pic);
/* set library */
pic_make_library(pic, pic_parse(pic, "user"));
pic_in_library(pic, pic_parse(pic, "user"));
return pic;
}
pic_value
pic_list1(pic_state *pic, pic_value obj1)
{
return pic_cons(pic, obj1, pic_nil_value());
}
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;
}
case PIC_TYPE_INT:
return pic_int(pic, x) == pic_int(pic, y);
default:
return pic_obj_ptr(x) == pic_obj_ptr(y);
}
}
#endif
KHASH_DECLARE(m, void *, int)
KHASH_DEFINE2(m, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal)
static bool
internal_equal_p(pic_state *pic, pic_value x, pic_value y, int depth, khash_t(m) *h)
{
pic_value localx = pic_nil_value(pic);
pic_value localy = pic_nil_value(pic);
int cx = 0;
int cy = 0;
if (depth > 10) {
if (depth > 200) {
pic_error(pic, "stack overflow in equal", 0);
}
if (pic_pair_p(pic, x) || pic_vec_p(pic, x)) {
int ret;
kh_put(m, h, pic_obj_ptr(x), &ret);
if (ret != 0) {
return true; /* `x' was seen already. */
}
}
static noreturn void
file_error(pic_state *pic, const char *msg)
{
pic_throw(pic, pic->sFILE, msg, pic_nil_value());
}
