static pic_value
pic_blob_bytevector(pic_state *pic)
{
pic_value *argv;
size_t argc, i;
pic_blob *blob;
unsigned char *data;
pic_get_args(pic, "*", &argc, &argv);
blob = pic_make_blob(pic, argc);
data = blob->data;
for (i = 0; i < argc; ++i) {
pic_assert_type(pic, argv[i], int);
if (pic_int(argv[i]) < 0 || pic_int(argv[i]) > 255) {
pic_errorf(pic, "byte out of range");
}
*data++ = (unsigned char)pic_int(argv[i]);
}
return pic_obj_value(blob);
}
static pic_value
pic_blob_bytevector(pic_state *pic)
{
pic_value *argv, blob;
int argc, i;
unsigned char *data;
pic_get_args(pic, "*", &argc, &argv);
blob = pic_blob_value(pic, 0, argc);
data = pic_blob(pic, blob, NULL);
for (i = 0; i < argc; ++i) {
TYPE_CHECK(pic, argv[i], int);
if (pic_int(pic, argv[i]) < 0 || pic_int(pic, argv[i]) > 255) {
pic_error(pic, "byte out of range", 0);
}
*data++ = (unsigned char)pic_int(pic, argv[i]);
}
return blob;
}
static pic_value
cont_call(pic_state *pic)
{
struct pic_proc *self = pic_get_proc(pic);
int argc;
pic_value *argv;
int id;
struct pic_cont *cc, *cont;
pic_get_args(pic, "*", &argc, &argv);
id = pic_int(pic_proc_env_ref(pic, self, "id"));
/* check if continuation is alive */
for (cc = pic->cc; cc != NULL; cc = cc->prev) {
if (cc->id == id) {
break;
}
}
if (cc == NULL) {
pic_errorf(pic, "calling dead escape continuation");
}
cont = pic_data_ptr(pic_proc_env_ref(pic, self, "escape"))->data;
cont->results = pic_list_by_array(pic, argc, argv);
pic_load_point(pic, cont);
PIC_LONGJMP(pic, cont->jmp, 1);
PIC_UNREACHABLE();
}
bool
pic_eqv_p(pic_state *PIC_UNUSED(pic), pic_value x, pic_value y)
{
if (pic_type(pic, x) != pic_type(pic, y))
return false;
switch (pic_type(pic, x)) {
case PIC_TYPE_NIL:
return true;
case PIC_TYPE_TRUE:
case PIC_TYPE_FALSE:
return pic_type(pic, x) == pic_type(pic, y);
case PIC_TYPE_FLOAT:
return pic_float(pic, x) == pic_float(pic, y);
case PIC_TYPE_INT:
return pic_int(pic, x) == pic_int(pic, y);
default:
return pic_obj_ptr(x) == pic_obj_ptr(y);
}
}
static pic_value
pic_blob_list_to_bytevector(pic_state *pic)
{
pic_value blob;
unsigned char *data;
pic_value list, e, it;
pic_get_args(pic, "o", &list);
blob = pic_blob_value(pic, 0, pic_length(pic, list));
data = pic_blob(pic, blob, NULL);
pic_for_each (e, list, it) {
TYPE_CHECK(pic, e, int);
if (pic_int(pic, e) < 0 || pic_int(pic, e) > 255)
pic_error(pic, "byte out of range", 0);
*data++ = (unsigned char)pic_int(pic, e);
}
static bool
is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) {
pic_value shared = p->shared;
if (! pic_obj_p(pic, obj)) {
return false;
}
if (! pic_weak_has(pic, shared, obj)) {
return false;
}
return pic_int(pic, pic_weak_ref(pic, shared, obj)) > 0;
}
static pic_value
pic_blob_list_to_bytevector(pic_state *pic)
{
pic_blob *blob;
unsigned char *data;
pic_value list, e;
pic_get_args(pic, "o", &list);
blob = pic_make_blob(pic, pic_length(pic, list));
data = blob->data;
pic_for_each (e, list) {
pic_assert_type(pic, e, int);
if (pic_int(e) < 0 || pic_int(e) > 255)
pic_errorf(pic, "byte out of range");
*data++ = (unsigned char)pic_int(e);
}
static void
traverse(pic_state *pic, pic_value obj, struct writer_control *p)
{
pic_value shared = p->shared;
if (p->op == OP_WRITE_SIMPLE) {
return;
}
switch (pic_type(pic, obj)) {
case PIC_TYPE_PAIR:
case PIC_TYPE_VECTOR:
case PIC_TYPE_DICT: {
if (! pic_weak_has(pic, shared, obj)) {
/* first time */
pic_weak_set(pic, shared, obj, pic_int_value(pic, 0));
if (pic_pair_p(pic, obj)) {
/* pair */
traverse(pic, pic_car(pic, obj), p);
traverse(pic, pic_cdr(pic, obj), p);
} else if (pic_vec_p(pic, obj)) {
/* vector */
int i, len = pic_vec_len(pic, obj);
for (i = 0; i < len; ++i) {
traverse(pic, pic_vec_ref(pic, obj, i), p);
}
} else {
/* dictionary */
int it = 0;
pic_value val;
while (pic_dict_next(pic, obj, &it, NULL, &val)) {
traverse(pic, val, p);
}
}
if (p->op == OP_WRITE) {
if (pic_int(pic, pic_weak_ref(pic, shared, obj)) == 0) {
pic_weak_del(pic, shared, obj);
}
}
} else {
/* second time */
pic_weak_set(pic, shared, obj, pic_int_value(pic, 1));
}
break;
}
default:
break;
}
}
static pic_value
pic_system_emergency_exit(pic_state *pic)
{
pic_value v;
int argc, status = EXIT_FAILURE;
argc = pic_get_args(pic, "|o", &v);
if (argc == 1) {
switch (pic_type(v)) {
case PIC_TT_FLOAT:
status = (int)pic_float(v);
break;
case PIC_TT_INT:
status = pic_int(v);
break;
default:
break;
}
}
_Exit(status);
}
int
pic_get_args(pic_state *pic, const char *format, ...)
{
char c;
int i = 1, argc = pic->ci->argc;
va_list ap;
bool opt = false;
va_start(ap, format);
while ((c = *format++)) {
switch (c) {
default:
if (argc <= i && ! opt) {
pic_error(pic, "wrong number of arguments");
}
break;
case '|':
break;
case '*':
break;
}
/* in order to run out of all arguments passed to this function
(i.e. do va_arg for each argument), optional argument existence
check is done in every case closure */
if (c == '*')
break;
switch (c) {
case '|':
opt = true;
break;
case 'o': {
pic_value *p;
p = va_arg(ap, pic_value*);
if (i < argc) {
*p = GET_OPERAND(pic,i);
i++;
}
break;
}
case 'f': {
double *f;
f = va_arg(ap, double *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
switch (pic_type(v)) {
case PIC_TT_FLOAT:
*f = pic_float(v);
break;
case PIC_TT_INT:
*f = pic_int(v);
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
}
i++;
}
break;
}
case 'F': {
double *f;
bool *e;
f = va_arg(ap, double *);
e = va_arg(ap, bool *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
switch (pic_type(v)) {
case PIC_TT_FLOAT:
*f = pic_float(v);
*e = false;
break;
case PIC_TT_INT:
*f = pic_int(v);
*e = true;
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
}
i++;
}
break;
}
case 'I': {
int *k;
bool *e;
k = va_arg(ap, int *);
e = va_arg(ap, bool *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
switch (pic_type(v)) {
case PIC_TT_FLOAT:
*k = (int)pic_float(v);
*e = false;
break;
case PIC_TT_INT:
*k = pic_int(v);
*e = true;
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
}
i++;
}
break;
}
case 'i': {
int *k;
k = va_arg(ap, int *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
switch (pic_type(v)) {
case PIC_TT_FLOAT:
*k = (int)pic_float(v);
break;
case PIC_TT_INT:
*k = pic_int(v);
break;
default:
pic_error(pic, "pic_get_args: expected int");
}
i++;
}
break;
}
case 's': {
pic_str **str;
pic_value v;
str = va_arg(ap, pic_str **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_str_p(v)) {
*str = pic_str_ptr(v);
}
else {
pic_error(pic, "pic_get_args: expected string");
}
i++;
}
break;
}
case 'z': {
pic_value str;
const char **cstr;
cstr = va_arg(ap, const char **);
if (i < argc) {
str = GET_OPERAND(pic,i);
if (! pic_str_p(str)) {
pic_error(pic, "pic_get_args: expected string");
}
*cstr = pic_str_cstr(pic_str_ptr(str));
i++;
}
break;
}
case 'm': {
pic_sym *m;
pic_value v;
m = va_arg(ap, pic_sym *);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_sym_p(v)) {
*m = pic_sym(v);
}
else {
pic_error(pic, "pic_get_args: expected symbol");
}
i++;
}
break;
}
case 'v': {
struct pic_vector **vec;
pic_value v;
vec = va_arg(ap, struct pic_vector **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_vec_p(v)) {
*vec = pic_vec_ptr(v);
}
else {
pic_error(pic, "pic_get_args: expected vector");
}
i++;
}
break;
}
case 'b': {
struct pic_blob **b;
pic_value v;
b = va_arg(ap, struct pic_blob **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_blob_p(v)) {
*b = pic_blob_ptr(v);
}
else {
pic_error(pic, "pic_get_args: expected bytevector");
}
i++;
}
break;
}
case 'c': {
char *c;
pic_value v;
c = va_arg(ap, char *);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_char_p(v)) {
*c = pic_char(v);
}
else {
pic_error(pic, "pic_get_args: expected char");
}
i++;
}
break;
}
case 'l': {
struct pic_proc **l;
pic_value v;
l = va_arg(ap, struct pic_proc **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_proc_p(v)) {
*l = pic_proc_ptr(v);
}
else {
pic_error(pic, "pic_get_args, expected procedure");
}
i++;
}
break;
}
case 'p': {
struct pic_port **p;
pic_value v;
p = va_arg(ap, struct pic_port **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_port_p(v)) {
*p = pic_port_ptr(v);
}
else {
pic_error(pic, "pic_get_args, expected port");
}
i++;
}
break;
}
default:
pic_error(pic, "pic_get_args: invalid argument specifier given");
}
}
if ('*' == c) {
size_t *n;
pic_value **argv;
n = va_arg(ap, size_t *);
argv = va_arg(ap, pic_value **);
if (i <= argc) {
*n = argc - i;
*argv = &GET_OPERAND(pic, i);
i = argc;
}
}
static void
write_core(pic_state *pic, pic_value obj, pic_value port, struct writer_control *p)
{
pic_value labels = p->labels;
int i;
/* shared objects */
if (is_shared_object(pic, obj, p)) {
if (pic_weak_has(pic, labels, obj)) {
pic_fprintf(pic, port, "#%d#", pic_int(pic, pic_weak_ref(pic, labels, obj)));
return;
}
i = p->cnt++;
pic_fprintf(pic, port, "#%d=", i);
pic_weak_set(pic, labels, obj, pic_int_value(pic, i));
}
switch (pic_type(pic, obj)) {
case PIC_TYPE_UNDEF:
pic_fprintf(pic, port, "#undefined");
break;
case PIC_TYPE_NIL:
pic_fprintf(pic, port, "()");
break;
case PIC_TYPE_TRUE:
pic_fprintf(pic, port, "#t");
break;
case PIC_TYPE_FALSE:
pic_fprintf(pic, port, "#f");
break;
case PIC_TYPE_ID:
pic_fprintf(pic, port, "#<identifier %s>", pic_str(pic, pic_id_name(pic, obj)));
break;
case PIC_TYPE_EOF:
pic_fprintf(pic, port, "#.(eof-object)");
break;
case PIC_TYPE_INT:
pic_fprintf(pic, port, "%d", pic_int(pic, obj));
break;
case PIC_TYPE_SYMBOL:
pic_fprintf(pic, port, "%s", pic_sym(pic, obj));
break;
case PIC_TYPE_FLOAT:
write_float(pic, obj, port);
break;
case PIC_TYPE_BLOB:
write_blob(pic, obj, port);
break;
case PIC_TYPE_CHAR:
write_char(pic, obj, port, p);
break;
case PIC_TYPE_STRING:
write_str(pic, obj, port, p);
break;
case PIC_TYPE_PAIR:
write_pair(pic, obj, port, p);
break;
case PIC_TYPE_VECTOR:
write_vec(pic, obj, port, p);
break;
case PIC_TYPE_DICT:
write_dict(pic, obj, port, p);
break;
default:
pic_fprintf(pic, port, "#<%s %p>", pic_typename(pic, pic_type(pic, obj)), pic_obj_ptr(obj));
break;
}
if (p->op == OP_WRITE) {
if (is_shared_object(pic, obj, p)) {
pic_weak_del(pic, labels, obj);
}
}
}
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;
}
int
pic_get_args(pic_state *pic, const char *format, ...)
{
char c;
int i = 1, argc = pic->ci->argc;
va_list ap;
bool opt = false;
va_start(ap, format);
while ((c = *format++)) {
switch (c) {
default:
if (argc <= i && ! opt) {
pic_error(pic, "wrong number of arguments");
}
break;
case '|':
break;
}
/* in order to run out of all arguments passed to this function
(i.e. do va_arg for each argument), optional argument existence
check is done in every case closure */
switch (c) {
case '|':
opt = true;
break;
case 'o':
{
pic_value *p;
p = va_arg(ap, pic_value*);
if (i < argc) {
*p = GET_OPERAND(pic,i);
i++;
}
}
break;
case 'f':
{
double *f;
f = va_arg(ap, double *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
switch (pic_type(v)) {
case PIC_TT_FLOAT:
*f = pic_float(v);
break;
case PIC_TT_INT:
*f = pic_int(v);
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
}
i++;
}
}
break;
case 'F':
{
double *f;
bool *e;
f = va_arg(ap, double *);
e = va_arg(ap, bool *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
switch (pic_type(v)) {
case PIC_TT_FLOAT:
*f = pic_float(v);
*e = false;
break;
case PIC_TT_INT:
*f = pic_int(v);
*e = true;
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
}
i++;
}
}
break;
case 'I':
{
int *k;
bool *e;
k = va_arg(ap, int *);
e = va_arg(ap, bool *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
switch (pic_type(v)) {
case PIC_TT_FLOAT:
*k = (int)pic_float(v);
*e = false;
break;
case PIC_TT_INT:
*k = pic_int(v);
*e = true;
break;
default:
pic_error(pic, "pic_get_args: expected float or int");
}
i++;
}
}
break;
case 'i':
{
int *k;
k = va_arg(ap, int *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
switch (pic_type(v)) {
case PIC_TT_FLOAT:
*k = (int)pic_float(v);
break;
case PIC_TT_INT:
*k = pic_int(v);
break;
default:
pic_error(pic, "pic_get_args: expected int");
}
i++;
}
}
break;
case 's':
{
pic_value str;
char **cstr;
size_t *len;
cstr = va_arg(ap, char **);
len = va_arg(ap, size_t *);
if (i < argc) {
str = GET_OPERAND(pic,i);
if (! pic_str_p(str)) {
pic_error(pic, "pic_get_args: expected string");
}
*cstr = pic_str_ptr(str)->str;
*len = pic_str_ptr(str)->len;
i++;
}
}
break;
case 'v':
{
struct pic_vector **vec;
pic_value v;
vec = va_arg(ap, struct pic_vector **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_vec_p(v)) {
*vec = pic_vec_ptr(v);
}
else {
pic_error(pic, "pic_get_args: expected vector");
}
i++;
}
}
break;
case 'b':
{
struct pic_blob **b;
pic_value v;
b = va_arg(ap, struct pic_blob **);
if (i < argc) {
v = GET_OPERAND(pic,i);
if (pic_blob_p(v)) {
*b = pic_blob_ptr(v);
}
else {
pic_error(pic, "pic_get_args: expected bytevector");
}
i++;
}
}
break;
default:
{
pic_error(pic, "pic_get_args: invalid argument specifier given");
}
}
}
if (argc > i) {
pic_error(pic, "wrong number of arguments");
}
va_end(ap);
return i;
}