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);
}
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
reg_get(pic_state *pic, struct pic_reg *reg, void *key)
{
if (! pic_reg_has(pic, reg, key)) {
return pic_false_value();
}
return pic_cons(pic, pic_obj_value(key), pic_reg_ref(pic, reg, key));
}
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;
}
static pic_value
pic_error_with_exception_handler(pic_state *pic)
{
pic_value handler, thunk;
pic_value stack, exc = pic_ref(pic, "picrin.base", "current-exception-handlers");
pic_get_args(pic, "ll", &handler, &thunk);
stack = pic_call(pic, exc, 0);
return pic_dynamic_bind(pic, exc, pic_cons(pic, handler, stack), thunk);
}
pic_value
pic_list3(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list2(pic, obj2, obj3));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list7(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5, pic_value obj6, pic_value obj7)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list6(pic, obj2, obj3, obj4, obj5, obj6, obj7));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
pic_value
pic_list5(pic_state *pic, pic_value obj1, pic_value obj2, pic_value obj3, pic_value obj4, pic_value obj5)
{
int ai = pic_gc_arena_preserve(pic);
pic_value val;
val = pic_cons(pic, obj1, pic_list4(pic, obj2, obj3, obj4, obj5));
pic_gc_arena_restore(pic, ai);
pic_gc_protect(pic, val);
return val;
}
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);
}
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;
}
static pic_value
pic_dict_dictionary_ref(pic_state *pic)
{
struct pic_dict *dict;
pic_sym *key;
pic_get_args(pic, "dm", &dict, &key);
if (! pic_dict_has(pic, dict, key)) {
return pic_false_value();
}
return pic_cons(pic, pic_obj_value(key), pic_dict_ref(pic, dict, key));
}
pic_value
pic_xvformat(pic_state *pic, const char *fmt, va_list ap)
{
struct pic_port *port;
pic_value irrs;
port = pic_open_output_string(pic);
irrs = pic_xvfformat(pic, port->file, fmt, ap);
irrs = pic_cons(pic, pic_obj_value(pic_get_output_string(pic, port)), irrs);
pic_close_port(pic, port);
return irrs;
}
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);
}
pic_value
pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
{
struct cont *cont;
pic_value handler;
pic_value var, old_val, new_val;
pic_value in, out;
struct checkpoint *here;
/* call/cc */
cont = pic_alloca_cont(pic);
pic_save_point(pic, cont, jmp);
handler = pic_lambda(pic, native_exception_handler, 1, pic_make_cont(pic, cont));
/* with-exception-handler */
var = pic_ref(pic, "picrin.base", "current-exception-handlers");
old_val = pic_call(pic, var, 0);
new_val = pic_cons(pic, handler, old_val);
in = pic_lambda(pic, dynamic_set, 2, var, new_val);
out = pic_lambda(pic, dynamic_set, 2, var, old_val);
/* dynamic-wind */
pic_call(pic, in, 0); /* enter */
here = pic->cp;
pic->cp = (struct checkpoint *)pic_obj_alloc(pic, sizeof(struct checkpoint), PIC_TYPE_CP);
pic->cp->prev = here;
pic->cp->depth = here->depth + 1;
pic->cp->in = pic_proc_ptr(pic, in);
pic->cp->out = pic_proc_ptr(pic, out);
return pic_cons(pic, pic_obj_value(here), out);
}
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);
}
static pic_value
pic_proc_apply(pic_state *pic)
{
struct pic_proc *proc;
pic_value *args;
size_t argc;
pic_value arg_list;
pic_get_args(pic, "l*", &proc, &argc, &args);
if (argc == 0) {
pic_errorf(pic, "apply: wrong number of arguments");
}
arg_list = args[--argc];
while (argc--) {
arg_list = pic_cons(pic, args[argc], arg_list);
}
return pic_apply_trampoline(pic, proc, arg_list);
}
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;
}
pic_value
pic_list1(pic_state *pic, pic_value obj1)
{
return pic_cons(pic, obj1, 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_value
pic_acons(pic_state *pic, pic_value key, pic_value val, pic_value assoc)
{
return pic_cons(pic, pic_cons(pic, key, val), assoc);
}
