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_vec_vector_append(pic_state *pic) { pic_value *argv; int argc, i, j, len; pic_vec *vec; pic_get_args(pic, "*", &argc, &argv); len = 0; for (i = 0; i < argc; ++i) { pic_assert_type(pic, argv[i], vec); len += pic_vec_ptr(argv[i])->len; } vec = pic_make_vec(pic, len); len = 0; for (i = 0; i < argc; ++i) { for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) { vec->data[len + j] = pic_vec_ptr(argv[i])->data[j]; } len += pic_vec_ptr(argv[i])->len; } return pic_obj_value(vec); }
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 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; } }
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; }