bool
pic_list_p(pic_value obj)
{
pic_value local, rapid;
int i;
/* Floyd's cycle-finding algorithm. */
local = rapid = obj;
while (true) {
/* advance rapid fast-forward; runs 2x faster than local */
for (i = 0; i < 2; ++i) {
if (pic_pair_p(rapid)) {
rapid = pic_pair_ptr(rapid)->cdr;
}
else {
return pic_nil_p(rapid);
}
}
/* advance local */
local = pic_pair_ptr(local)->cdr;
if (pic_eq_p(local, rapid)) {
return false;
}
}
}
bool
pic_list_p(pic_state *pic, pic_value obj)
{
while (pic_pair_p(obj))
obj = pic_pair_ptr(obj)->cdr;
return pic_nil_p(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;
}
static void
write_pair(struct writer_control *p, struct pic_pair *pair)
{
pic_state *pic = p->pic;
xFILE *file = p->file;
pic_sym *tag;
if (pic_pair_p(pair->cdr) && pic_nil_p(pic_cdr(pic, pair->cdr)) && pic_sym_p(pair->car)) {
tag = pic_sym_ptr(pair->car);
if (tag == pic->sQUOTE) {
xfprintf(pic, file, "'");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sUNQUOTE) {
xfprintf(pic, file, ",");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sUNQUOTE_SPLICING) {
xfprintf(pic, file, ",@");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sQUASIQUOTE) {
xfprintf(pic, file, "`");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sSYNTAX_QUOTE) {
xfprintf(pic, file, "#'");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sSYNTAX_UNQUOTE) {
xfprintf(pic, file, "#,");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sSYNTAX_UNQUOTE_SPLICING) {
xfprintf(pic, file, "#,@");
write_core(p, pic_car(pic, pair->cdr));
return;
}
else if (tag == pic->sSYNTAX_QUASIQUOTE) {
xfprintf(pic, file, "#`");
write_core(p, pic_car(pic, pair->cdr));
return;
}
}
xfprintf(pic, file, "(");
write_pair_help(p, pair);
xfprintf(pic, file, ")");
}
int
pic_length(pic_state *pic, pic_value obj)
{
int c = 0;
while (! pic_nil_p(obj)) {
obj = pic_cdr(pic, obj);
++c;
}
return c;
}
static void
write_pair(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
{
pic_value tag;
if (pic_pair_p(pic, pic_cdr(pic, pair)) && pic_nil_p(pic, pic_cddr(pic, pair)) && pic_sym_p(pic, pic_car(pic, pair))) {
tag = pic_car(pic, pair);
if (EQ(tag, "quote")) {
pic_fprintf(pic, port, "'");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "unquote")) {
pic_fprintf(pic, port, ",");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "unquote-splicing")) {
pic_fprintf(pic, port, ",@");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "quasiquote")) {
pic_fprintf(pic, port, "`");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-quote")) {
pic_fprintf(pic, port, "#'");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-unquote")) {
pic_fprintf(pic, port, "#,");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-unquote-splicing")) {
pic_fprintf(pic, port, "#,@");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
else if (EQ(tag, "syntax-quasiquote")) {
pic_fprintf(pic, port, "#`");
write_core(pic, pic_cadr(pic, pair), port, p);
return;
}
}
pic_fprintf(pic, port, "(");
write_pair_help(pic, pair, port, p);
pic_fprintf(pic, port, ")");
}
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);
}
pic_value
pic_raise_continuable(pic_state *pic, pic_value err)
{
pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers");
stack = pic_call(pic, exc, 0);
if (pic_nil_p(pic, stack)) {
pic_panic(pic, "no exception handler");
}
return pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise_continuable, 2, pic_car(pic, stack), err));
}
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];
}
void
pic_raise(pic_state *pic, pic_value err)
{
pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers");
stack = pic_call(pic, exc, 0);
if (pic_nil_p(pic, stack)) {
pic_panic(pic, "no exception handler");
}
pic_dynamic_bind(pic, exc, pic_cdr(pic, stack), pic_lambda(pic, raise, 2, pic_car(pic, stack), err));
PIC_UNREACHABLE();
}
int
pic_length(pic_state *pic, pic_value obj)
{
int c = 0;
if (! pic_list_p(obj)) {
pic_errorf(pic, "length: expected list, but got ~s", obj);
}
while (! pic_nil_p(obj)) {
obj = pic_cdr(pic, obj);
++c;
}
return c;
}
pic_value
pic_assq(pic_state *pic, pic_value key, pic_value assoc)
{
pic_value cell;
enter:
if (pic_nil_p(assoc))
return assoc;
cell = pic_car(pic, assoc);
if (pic_eq_p(key, pic_car(pic, cell)))
return cell;
assoc = pic_cdr(pic, assoc);
goto enter;
}
static void
write_pair_help(struct writer_control *p, struct pic_pair *pair)
{
pic_state *pic = p->pic;
khash_t(l) *lh = &p->labels;
khash_t(v) *vh = &p->visited;
khiter_t it;
int ret;
write_core(p, pair->car);
if (pic_nil_p(pair->cdr)) {
return;
}
else if (pic_pair_p(pair->cdr)) {
/* shared objects */
if ((it = kh_get(l, lh, pic_ptr(pair->cdr))) != kh_end(lh) && kh_val(lh, it) != -1) {
xfprintf(pic, p->file, " . ");
kh_put(v, vh, pic_ptr(pair->cdr), &ret);
if (ret == 0) { /* if exists */
xfprintf(pic, p->file, "#%d#", kh_val(lh, it));
return;
}
xfprintf(pic, p->file, "#%d=", kh_val(lh, it));
}
else {
xfprintf(pic, p->file, " ");
}
write_pair_help(p, pic_pair_ptr(pair->cdr));
if (p->op == OP_WRITE) {
if ((it = kh_get(l, lh, pic_ptr(pair->cdr))) != kh_end(lh) && kh_val(lh, it) != -1) {
it = kh_get(v, vh, pic_ptr(pair->cdr));
kh_del(v, vh, it);
}
}
return;
}
else {
xfprintf(pic, p->file, " . ");
write_core(p, pair->cdr);
}
}
static void
write_pair_help(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p)
{
pic_value cdr = pic_cdr(pic, pair);
write_core(pic, pic_car(pic, pair), port, p);
if (pic_nil_p(pic, cdr)) {
return;
}
else if (pic_pair_p(pic, cdr) && ! is_shared_object(pic, cdr, p)) {
pic_fprintf(pic, port, " ");
write_pair_help(pic, cdr, port, p);
}
else {
pic_fprintf(pic, port, " . ");
write_core(pic, cdr, port, p);
}
}
static bool
internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *ht)
{
pic_value local = pic_nil_value();
size_t c;
if (depth > 10) {
if (depth > 200) {
pic_errorf(pic, "Stack overflow in equal\n");
}
if (pic_pair_p(x) || pic_vec_p(x)) {
if (xh_get_ptr(ht, pic_obj_ptr(x)) != NULL) {
return true; /* `x' was seen already. */
} else {
xh_put_ptr(ht, pic_obj_ptr(x), NULL);
}
}
}
c = 0;
LOOP:
if (pic_eqv_p(x, y))
return true;
if (pic_type(x) != pic_type(y))
return false;
switch (pic_type(x)) {
case PIC_TT_STRING:
return str_equal_p(pic_str_ptr(x), pic_str_ptr(y));
case PIC_TT_BLOB:
return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
case PIC_TT_PAIR: {
if (pic_nil_p(local)) {
local = x;
}
if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, ht)) {
x = pic_cdr(pic, x);
y = pic_cdr(pic, y);
c++;
if (c == 2) {
c = 0;
local = pic_cdr(pic, local);
if (pic_eq_p(local, x)) {
return true;
}
}
goto LOOP;
} else {
return false;
}
}
case PIC_TT_VECTOR: {
size_t i;
struct pic_vector *u, *v;
u = pic_vec_ptr(x);
v = pic_vec_ptr(y);
if (u->len != v->len) {
return false;
}
for (i = 0; i < u->len; ++i) {
if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, ht))
return false;
}
return true;
}
default:
return false;
}
}
pic_value
pic_apply(pic_state *pic, struct pic_proc *proc, pic_value argv)
{
struct pic_code *pc, c;
int ai = pic_gc_arena_preserve(pic);
jmp_buf jmp;
size_t argc, i;
struct pic_code boot[2];
#if PIC_DIRECT_THREADED_VM
static void *oplabels[] = {
&&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, &&L_OP_PUSHFLOAT,
&&L_OP_PUSHINT, &&L_OP_PUSHCHAR, &&L_OP_PUSHCONST,
&&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET,
&&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET, &&L_OP_LAMBDA,
&&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
&&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV,
&&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP
};
#endif
if (setjmp(jmp) == 0) {
pic->jmp = &jmp;
}
else {
goto L_RAISE;
}
argc = pic_length(pic, argv) + 1;
#if VM_DEBUG
puts("== booting VM...");
printf(" proc = ");
pic_debug(pic, pic_obj_value(proc));
puts("");
printf(" argv = ");
pic_debug(pic, argv);
puts("");
printf(" irep = ");
print_irep(pic, proc->u.irep);
puts("\nLet's go!");
#endif
PUSH(pic_obj_value(proc));
for (i = 1; i < argc; ++i) {
PUSH(pic_car(pic, argv));
argv = pic_cdr(pic, argv);
}
/* boot! */
boot[0].insn = OP_CALL;
boot[0].u.i = argc;
boot[1].insn = OP_STOP;
pc = boot;
c = *pc;
goto L_CALL;
VM_LOOP {
CASE(OP_POP) {
POPN(1);
NEXT;
}
CASE(OP_PUSHNIL) {
PUSH(pic_nil_value());
NEXT;
}
CASE(OP_PUSHTRUE) {
PUSH(pic_true_value());
NEXT;
}
CASE(OP_PUSHFALSE) {
PUSH(pic_false_value());
NEXT;
}
CASE(OP_PUSHFLOAT) {
PUSH(pic_float_value(c.u.f));
NEXT;
}
CASE(OP_PUSHINT) {
PUSH(pic_int_value(c.u.i));
NEXT;
}
CASE(OP_PUSHCHAR) {
PUSH(pic_char_value(c.u.c));
NEXT;
}
CASE(OP_PUSHCONST) {
PUSH(pic->pool[c.u.i]);
NEXT;
}
CASE(OP_GREF) {
PUSH(pic->globals[c.u.i]);
NEXT;
}
CASE(OP_GSET) {
pic->globals[c.u.i] = POP();
NEXT;
}
CASE(OP_LREF) {
PUSH(pic->ci->fp[c.u.i]);
NEXT;
}
CASE(OP_LSET) {
pic->ci->fp[c.u.i] = POP();
NEXT;
}
CASE(OP_CREF) {
int depth = c.u.r.depth;
struct pic_env *env;
env = pic->ci->env;
while (depth--) {
env = env->up;
}
PUSH(env->values[c.u.r.idx]);
NEXT;
}
CASE(OP_CSET) {
int depth = c.u.r.depth;
struct pic_env *env;
env = pic->ci->env;
while (depth--) {
env = env->up;
}
env->values[c.u.r.idx] = POP();
NEXT;
}
CASE(OP_JMP) {
pc += c.u.i;
JUMP;
}
CASE(OP_JMPIF) {
pic_value v;
v = POP();
if (! pic_false_p(v)) {
pc += c.u.i;
JUMP;
}
NEXT;
}
CASE(OP_CALL) {
pic_value x, v;
pic_callinfo *ci;
struct pic_proc *proc;
L_CALL:
x = pic->sp[-c.u.i];
if (! pic_proc_p(x)) {
pic->errmsg = "invalid application";
goto L_RAISE;
}
proc = pic_proc_ptr(x);
ci = PUSHCI();
ci->argc = c.u.i;
ci->pc = pc;
ci->fp = pic->sp - c.u.i;
ci->env = NULL;
if (pic_proc_cfunc_p(x)) {
v = proc->u.cfunc(pic);
pic->sp = ci->fp;
POPCI();
PUSH(v);
pic_gc_arena_restore(pic, ai);
NEXT;
}
else {
int i;
pic_value rest;
if (ci->argc != proc->u.irep->argc) {
if (! (proc->u.irep->varg && ci->argc >= proc->u.irep->argc)) {
pic->errmsg = "wrong number of arguments";
goto L_RAISE;
}
}
/* prepare rest args */
if (proc->u.irep->varg) {
rest = pic_nil_value();
for (i = 0; i < ci->argc - proc->u.irep->argc; ++i) {
pic_gc_protect(pic, v = POP());
rest = pic_cons(pic, v, rest);
}
PUSH(rest);
}
/* prepare env */
if (proc->u.irep->cv_num == 0) {
ci->env = proc->env;
}
else {
ci->env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV);
ci->env->up = proc->env;
ci->env->valuec = proc->u.irep->cv_num;
ci->env->values = (pic_value *)pic_calloc(pic, ci->env->valuec, sizeof(pic_value));
for (i = 0; i < ci->env->valuec; ++i) {
ci->env->values[i] = ci->fp[proc->u.irep->cv_tbl[i]];
}
}
pc = proc->u.irep->code;
pic_gc_arena_restore(pic, ai);
JUMP;
}
}
CASE(OP_TAILCALL) {
int argc;
pic_value *argv;
argc = c.u.i;
argv = pic->sp - argc;
for (i = 0; i < argc; ++i) {
pic->ci->fp[i] = argv[i];
}
pic->sp = pic->ci->fp + argc;
pc = POPCI()->pc;
/* c is not changed */
goto L_CALL;
}
CASE(OP_RET) {
pic_value v;
pic_callinfo *ci;
if (pic->errmsg) {
L_RAISE:
goto L_STOP;
}
else {
v = POP();
ci = POPCI();
pc = ci->pc;
pic->sp = ci->fp;
PUSH(v);
}
NEXT;
}
CASE(OP_LAMBDA) {
struct pic_proc *proc;
proc = pic_proc_new(pic, pic->irep[c.u.i], pic->ci->env);
PUSH(pic_obj_value(proc));
pic_gc_arena_restore(pic, ai);
NEXT;
}
CASE(OP_CONS) {
pic_value a, b;
pic_gc_protect(pic, b = POP());
pic_gc_protect(pic, a = POP());
PUSH(pic_cons(pic, a, b));
pic_gc_arena_restore(pic, ai);
NEXT;
}
CASE(OP_CAR) {
pic_value p;
p = POP();
PUSH(pic_car(pic, p));
NEXT;
}
CASE(OP_CDR) {
pic_value p;
p = POP();
PUSH(pic_cdr(pic, p));
NEXT;
}
CASE(OP_NILP) {
pic_value p;
p = POP();
PUSH(pic_bool_value(pic_nil_p(p)));
NEXT;
}
#define DEFINE_ARITH_OP(opcode, op) \
CASE(opcode) { \
pic_value a, b; \
b = POP(); \
a = POP(); \
if (pic_int_p(a) && pic_int_p(b)) { \
double f = (double)pic_int(a) op (double)pic_int(b); \
if (INT_MIN <= f && f <= INT_MAX) { \
PUSH(pic_int_value((int)f)); \
} \
else { \
PUSH(pic_float_value(f)); \
} \
} \
else if (pic_float_p(a) && pic_float_p(b)) { \
PUSH(pic_float_value(pic_float(a) op pic_float(b))); \
} \
else if (pic_int_p(a) && pic_float_p(b)) { \
PUSH(pic_float_value(pic_int(a) op pic_float(b))); \
} \
else if (pic_float_p(a) && pic_int_p(b)) { \
PUSH(pic_float_value(pic_float(a) op pic_int(b))); \
} \
else { \
pic->errmsg = #op " got non-number operands"; \
goto L_RAISE; \
} \
NEXT; \
}
DEFINE_ARITH_OP(OP_ADD, +);
DEFINE_ARITH_OP(OP_SUB, -);
DEFINE_ARITH_OP(OP_MUL, *);
/* special care for (int / int) division */
CASE(OP_DIV) {
pic_value a, b;
b = POP();
a = POP();
if (pic_int_p(a) && pic_int_p(b)) {
PUSH(pic_float_value((double)pic_int(a) / pic_int(b)));
}
else if (pic_float_p(a) && pic_float_p(b)) {
PUSH(pic_float_value(pic_float(a) / pic_float(b)));
}
else if (pic_int_p(a) && pic_float_p(b)) {
PUSH(pic_float_value(pic_int(a) / pic_float(b)));
}
else if (pic_float_p(a) && pic_int_p(b)) {
PUSH(pic_float_value(pic_float(a) / pic_int(b)));
}
else {
pic->errmsg = "/ got non-number operands";
goto L_RAISE;
}
NEXT;
}
#define DEFINE_COMP_OP(opcode, op) \
CASE(opcode) { \
pic_value a, b; \
b = POP(); \
a = POP(); \
if (pic_int_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \
} \
else if (pic_float_p(a) && pic_float_p(b)) { \
PUSH(pic_bool_value(pic_float(a) op pic_float(b))); \
} \
else if (pic_int_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_int(a) op pic_float(b))); \
} \
else if (pic_float_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \
} \
else { \
pic->errmsg = #op " got non-number operands"; \
goto L_RAISE; \
} \
NEXT; \
}
DEFINE_COMP_OP(OP_EQ, ==);
DEFINE_COMP_OP(OP_LT, <);
DEFINE_COMP_OP(OP_LE, <=);
CASE(OP_STOP) {
pic_value val;
L_STOP:
val = POP();
pic->jmp = NULL;
if (pic->errmsg) {
return pic_undef_value();
}
#if VM_DEBUG
puts("**VM END STATE**");
printf("stbase\t= %p\nsp\t= %p\n", pic->stbase, pic->sp);
printf("cibase\t= %p\nci\t= %p\n", pic->cibase, pic->ci);
if (pic->stbase < pic->sp) {
pic_value *sp;
printf("* stack trace:");
for (sp = pic->stbase; pic->sp != sp; ++sp) {
pic_debug(pic, *sp);
puts("");
}
}
if (pic->stbase > pic->sp) {
puts("*** stack underflow!");
}
#endif
pic_gc_protect(pic, val);
return val;
}
} VM_LOOP_END;
}
