static pic_value
pic_vec_vector_to_string(pic_state *pic)
{
pic_vec *vec;
char *buf;
int n, start, end, i;
pic_str *str;
n = pic_get_args(pic, "v|ii", &vec, &start, &end);
switch (n) {
case 1:
start = 0;
case 2:
end = vec->len;
}
if (end < start) {
pic_errorf(pic, "vector->string: end index must not be less than start index");
}
buf = pic_malloc(pic, end - start);
for (i = start; i < end; ++i) {
pic_assert_type(pic, vec->data[i], char);
buf[i - start] = pic_char(vec->data[i]);
}
str = pic_make_str(pic, buf, end - start);
pic_free(pic, buf);
return pic_obj_value(str);
}
static pic_value
pic_str_list_to_string(pic_state *pic)
{
pic_str *str;
pic_value list, e, it;
int i;
char *buf;
pic_get_args(pic, "o", &list);
if (pic_length(pic, list) == 0) {
return pic_obj_value(pic_make_str(pic, NULL, 0));
}
buf = pic_malloc(pic, pic_length(pic, list));
pic_try {
i = 0;
pic_for_each (e, list, it) {
pic_assert_type(pic, e, char);
buf[i++] = pic_char(e);
}
str = pic_make_str(pic, buf, i);
}
static pic_value
pic_str_string_map(pic_state *pic)
{
struct pic_proc *proc;
pic_value *argv, vals, val;
int argc, i, len, j;
pic_str *str;
char *buf;
pic_get_args(pic, "l*", &proc, &argc, &argv);
if (argc == 0) {
pic_errorf(pic, "string-map: one or more strings expected, but got zero");
} else {
pic_assert_type(pic, argv[0], str);
len = pic_str_len(pic_str_ptr(argv[0]));
}
for (i = 1; i < argc; ++i) {
pic_assert_type(pic, argv[i], str);
len = len < pic_str_len(pic_str_ptr(argv[i]))
? len
: pic_str_len(pic_str_ptr(argv[i]));
}
buf = pic_malloc(pic, len);
pic_try {
for (i = 0; i < len; ++i) {
vals = pic_nil_value();
for (j = 0; j < argc; ++j) {
pic_push(pic, pic_char_value(pic_str_ref(pic, pic_str_ptr(argv[j]), i)), vals);
}
val = pic_apply_list(pic, proc, vals);
pic_assert_type(pic, val, char);
buf[i] = pic_char(val);
}
str = pic_make_str(pic, buf, len);
}
pic_catch {
pic_free(pic, buf);
pic_raise(pic, pic->err);
}
pic_free(pic, buf);
return pic_obj_value(str);
}
static void
write_char(pic_state *pic, pic_value ch, pic_value port, struct writer_control *p)
{
char c = pic_char(pic, ch);
if (p->mode == DISPLAY_MODE) {
pic_fputc(pic, c, port);
return;
}
switch (c) {
default: pic_fprintf(pic, port, "#\\%c", c); break;
case '\a': pic_fprintf(pic, port, "#\\alarm"); break;
case '\b': pic_fprintf(pic, port, "#\\backspace"); break;
case 0x7f: pic_fprintf(pic, port, "#\\delete"); break;
case 0x1b: pic_fprintf(pic, port, "#\\escape"); break;
case '\n': pic_fprintf(pic, port, "#\\newline"); break;
case '\r': pic_fprintf(pic, port, "#\\return"); break;
case ' ': pic_fprintf(pic, port, "#\\space"); break;
case '\t': pic_fprintf(pic, port, "#\\tab"); break;
}
}
static pic_value
pic_str_string(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_str *str;
char *buf;
pic_get_args(pic, "*", &argc, &argv);
buf = pic_malloc(pic, argc);
for (i = 0; i < argc; ++i) {
pic_assert_type(pic, argv[i], char);
buf[i] = pic_char(argv[i]);
}
str = pic_make_str(pic, buf, argc);
pic_free(pic, buf);
return pic_obj_value(str);
}
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;
}
}