static pic_value
pic_str_string_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_str_p(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_str_string_append(pic_state *pic)
{
int argc, i;
pic_value *argv;
pic_str *str;
pic_get_args(pic, "*", &argc, &argv);
str = pic_make_str(pic, NULL, 0);
for (i = 0; i < argc; ++i) {
if (! pic_str_p(argv[i])) {
pic_errorf(pic, "type error");
}
str = pic_str_cat(pic, str, pic_str_ptr(argv[i]));
}
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;
}
}
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;
}
