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;
}
}
