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 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); } }
pic_value pic_proc_cv_ref(pic_state *pic, struct pic_proc *proc, size_t i) { if (proc->env == NULL) { pic_error(pic, "no closed env"); } return proc->env->values[i]; }
pic_value pic_global_ref(pic_state *pic, pic_value sym) { if (! pic_dict_has(pic, pic->globals, sym)) { pic_error(pic, "undefined variable", 1, sym); } return pic_dict_ref(pic, pic->globals, sym); }
void pic_proc_cv_set(pic_state *pic, struct pic_proc *proc, size_t i, pic_value v) { if (proc->env == NULL) { pic_error(pic, "no closed env"); } proc->env->values[i] = v; }
static pic_value raise(pic_state *pic) { pic_get_args(pic, ""); pic_call(pic, pic_closure_ref(pic, 0), 1, pic_closure_ref(pic, 1)); pic_error(pic, "handler returned", 2, pic_closure_ref(pic, 0), pic_closure_ref(pic, 1)); }
struct pic_proc * pic_get_proc(pic_state *pic) { pic_value v = GET_OPERAND(pic,0); if (! pic_proc_p(v)) { pic_error(pic, "fatal error"); } return pic_proc_ptr(v); }
static pic_value pic_error_error(pic_state *pic) { const char *str; int argc; pic_value *argv; pic_get_args(pic, "z*", &str, &argc, &argv); pic_error(pic, str, pic_list_by_array(pic, argc, argv)); }
void pic_weak_del(pic_state *pic, pic_value weak, pic_value key) { khash_t(weak) *h = &pic_weak_ptr(pic, weak)->hash; int it; it = kh_get(weak, h, pic_obj_ptr(key)); if (it == kh_end(h)) { pic_error(pic, "element not found for given key", 1, key); } kh_del(weak, h, it); }
static pic_value pic_blob_make_bytevector(pic_state *pic) { pic_value blob; int k, b = 0; pic_get_args(pic, "i|i", &k, &b); if (b < 0 || b > 255) pic_error(pic, "byte out of range", 0); if (k < 0) { pic_error(pic, "make-bytevector: negative length given", 1, pic_int_value(pic, k)); } blob = pic_blob_value(pic, 0, k); memset(pic_blob(pic, blob, NULL), (unsigned char)b, k); return blob; }
pic_value pic_cdr(pic_state *pic, pic_value obj) { struct pic_pair *pair; if (! pic_pair_p(obj)) { pic_error(pic, "pair required"); } pair = pic_pair_ptr(obj); return pair->cdr; }
static pic_value pic_vec_vector_ref(pic_state *pic) { struct pic_vector *v; int k; pic_get_args(pic, "vi", &v, &k); if (k < 0 || v->len <= (size_t)k) { pic_error(pic, "vector-ref: index out of range"); } return v->data[k]; }
static pic_value pic_symbol_symbol_to_string(pic_state *pic) { pic_value v; pic_get_args(pic, "o", &v); if (! pic_sym_p(v)) { pic_error(pic, "symbol->string: expected symbol"); } return pic_obj_value(pic_str_new_cstr(pic, pic_symbol_name(pic, pic_sym(v)))); }
static pic_value pic_symbol_string_to_symbol(pic_state *pic) { pic_value v; pic_get_args(pic, "o", &v); if (! pic_str_p(v)) { pic_error(pic, "string->symbol: expected string"); } return pic_symbol_value(pic_intern_cstr(pic, pic_str_cstr(pic_str_ptr(v)))); }
static pic_value pic_pair_set_cdr(pic_state *pic) { pic_value v,w; pic_get_args(pic, "oo", &v, &w); if (! pic_pair_p(v)) pic_error(pic, "pair expected"); pic_pair_ptr(v)->cdr = w; return pic_true_value(); }
static pic_value pic_char_integer_to_char(pic_state *pic) { int i; pic_get_args(pic, "i", &i); if (i < 0 || i > 127) { pic_error(pic, "integer->char: integer out of char range", 1, pic_int_value(pic, i)); } return pic_char_value(pic, (char)i); }
static pic_value pic_vec_vector_set(pic_state *pic) { struct pic_vector *v; int k; pic_value o; pic_get_args(pic, "vio", &v, &k, &o); if (k < 0 || v->len <= (size_t)k) { pic_error(pic, "vector-set!: index out of range"); } v->data[k] = o; return pic_none_value(); }
void pic_proc_cv_init(pic_state *pic, struct pic_proc *proc, size_t cv_size) { struct pic_env *env; if (proc->env != NULL) { pic_error(pic, "env slot already in use"); } env = (struct pic_env *)pic_obj_alloc(pic, sizeof(struct pic_env), PIC_TT_ENV); env->valuec = cv_size; env->values = (pic_value *)pic_calloc(pic, cv_size, sizeof(pic_value)); env->up = NULL; proc->env = env; }
static pic_value pic_proc_apply(pic_state *pic) { struct pic_proc *proc; pic_value *args; size_t argc; pic_get_args(pic, "l*", &proc, &argc, &args); if (argc == 0) { pic_error(pic, "apply: wrong number of arguments"); } return pic_apply(pic, proc, pic_list_from_array(pic, argc, args)); }
void pic_errorf(pic_state *pic, const char *fmt, ...) { va_list ap; pic_value err_line, irrs; const char *msg; va_start(ap, fmt); err_line = pic_xvformat(pic, fmt, ap); va_end(ap); msg = pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line))); irrs = pic_cdr(pic, err_line); pic_error(pic, msg, irrs); }
static pic_value pic_blob_bytevector_u8_set(pic_state *pic) { unsigned char *buf; int len, k, v; pic_get_args(pic, "bii", &buf, &len, &k, &v); if (v < 0 || v > 255) pic_error(pic, "byte out of range", 0); VALID_INDEX(pic, len, k); buf[k] = (unsigned char)v; return pic_undef_value(pic); }
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 pic_value pic_load_load(pic_state *pic) { pic_value envid, port; char *fn; FILE *fp; pic_get_args(pic, "z|o", &fn, &envid); fp = fopen(fn, "r"); if (fp == NULL) { pic_error(pic, "load: could not open file", 1, pic_cstr_value(pic, fn)); } port = pic_fopen(pic, fp, "r"); pic_load(pic, port); pic_fclose(pic, port); return pic_undef_value(pic); }
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; }
void pic_errorf(pic_state *pic, const char *msg, size_t n, ...) { UNUSED(n); pic_error(pic, msg); }
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; } }