static pic_value pic_symbol_symbol_p(pic_state *pic) { pic_value v; pic_get_args(pic, "o", &v); return pic_bool_value(pic_sym_p(v)); }
static void write_pair(struct writer_control *p, struct pic_pair *pair) { pic_state *pic = p->pic; xFILE *file = p->file; pic_sym *tag; if (pic_pair_p(pair->cdr) && pic_nil_p(pic_cdr(pic, pair->cdr)) && pic_sym_p(pair->car)) { tag = pic_sym_ptr(pair->car); if (tag == pic->sQUOTE) { xfprintf(pic, file, "'"); write_core(p, pic_car(pic, pair->cdr)); return; } else if (tag == pic->sUNQUOTE) { xfprintf(pic, file, ","); write_core(p, pic_car(pic, pair->cdr)); return; } else if (tag == pic->sUNQUOTE_SPLICING) { xfprintf(pic, file, ",@"); write_core(p, pic_car(pic, pair->cdr)); return; } else if (tag == pic->sQUASIQUOTE) { xfprintf(pic, file, "`"); write_core(p, pic_car(pic, pair->cdr)); return; } else if (tag == pic->sSYNTAX_QUOTE) { xfprintf(pic, file, "#'"); write_core(p, pic_car(pic, pair->cdr)); return; } else if (tag == pic->sSYNTAX_UNQUOTE) { xfprintf(pic, file, "#,"); write_core(p, pic_car(pic, pair->cdr)); return; } else if (tag == pic->sSYNTAX_UNQUOTE_SPLICING) { xfprintf(pic, file, "#,@"); write_core(p, pic_car(pic, pair->cdr)); return; } else if (tag == pic->sSYNTAX_QUASIQUOTE) { xfprintf(pic, file, "#`"); write_core(p, pic_car(pic, pair->cdr)); return; } } xfprintf(pic, file, "("); write_pair_help(p, pair); xfprintf(pic, file, ")"); }
static void write_pair(pic_state *pic, pic_value pair, pic_value port, struct writer_control *p) { pic_value tag; if (pic_pair_p(pic, pic_cdr(pic, pair)) && pic_nil_p(pic, pic_cddr(pic, pair)) && pic_sym_p(pic, pic_car(pic, pair))) { tag = pic_car(pic, pair); if (EQ(tag, "quote")) { pic_fprintf(pic, port, "'"); write_core(pic, pic_cadr(pic, pair), port, p); return; } else if (EQ(tag, "unquote")) { pic_fprintf(pic, port, ","); write_core(pic, pic_cadr(pic, pair), port, p); return; } else if (EQ(tag, "unquote-splicing")) { pic_fprintf(pic, port, ",@"); write_core(pic, pic_cadr(pic, pair), port, p); return; } else if (EQ(tag, "quasiquote")) { pic_fprintf(pic, port, "`"); write_core(pic, pic_cadr(pic, pair), port, p); return; } else if (EQ(tag, "syntax-quote")) { pic_fprintf(pic, port, "#'"); write_core(pic, pic_cadr(pic, pair), port, p); return; } else if (EQ(tag, "syntax-unquote")) { pic_fprintf(pic, port, "#,"); write_core(pic, pic_cadr(pic, pair), port, p); return; } else if (EQ(tag, "syntax-unquote-splicing")) { pic_fprintf(pic, port, "#,@"); write_core(pic, pic_cadr(pic, pair), port, p); return; } else if (EQ(tag, "syntax-quasiquote")) { pic_fprintf(pic, port, "#`"); write_core(pic, pic_cadr(pic, pair), port, p); return; } } pic_fprintf(pic, port, "("); write_pair_help(pic, pair, port, p); pic_fprintf(pic, port, ")"); }
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 import_table(pic_state *pic, pic_value spec, struct pic_dict *imports) { struct pic_lib *lib; struct pic_dict *table; pic_value val, tmp, prefix; pic_sym *sym, *id, *tag; table = pic_make_dict(pic); if (pic_pair_p(spec) && pic_sym_p(pic_car(pic, spec))) { tag = pic_sym_ptr(pic_car(pic, spec)); if (tag == pic->sONLY) { import_table(pic, pic_cadr(pic, spec), table); pic_for_each (val, pic_cddr(pic, spec)) { pic_dict_set(pic, imports, pic_sym_ptr(val), pic_dict_ref(pic, table, pic_sym_ptr(val))); }
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; } }
bool pic_var_p(pic_value obj) { return pic_sym_p(obj) || pic_id_p(obj); }