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 void
write_dict(pic_state *pic, pic_value dict, pic_value port, struct writer_control *p)
{
pic_value key, val;
int it = 0;
pic_fprintf(pic, port, "#.(dictionary");
while (pic_dict_next(pic, dict, &it, &key, &val)) {
pic_fprintf(pic, port, " '%s ", pic_sym(pic, key));
write_core(pic, val, port, p);
}
pic_fprintf(pic, port, ")");
}
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);
}
}
}
