diff --git a/extlib/benz/write.c b/extlib/benz/write.c index 8eb08fd8..a7da49e6 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -4,38 +4,6 @@ #include "picrin.h" -static bool -is_tagged(pic_state *pic, pic_sym *tag, pic_value pair) -{ - return pic_pair_p(pic_cdr(pic, pair)) - && pic_nil_p(pic_cddr(pic, pair)) - && pic_eq_p(pic_car(pic, pair), pic_obj_value(tag)); -} - -static bool -is_quote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sQUOTE, pair); -} - -static bool -is_unquote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sUNQUOTE, pair); -} - -static bool -is_unquote_splicing(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sUNQUOTE_SPLICING, pair); -} - -static bool -is_quasiquote(pic_state *pic, pic_value pair) -{ - return is_tagged(pic, pic->sQUASIQUOTE, pair); -} - KHASH_DECLARE(l, void *, int) KHASH_DECLARE(v, void *, int) KHASH_DEFINE2(l, void *, int, 1, kh_ptr_hash_func, kh_ptr_hash_equal) @@ -45,6 +13,7 @@ struct writer_control { pic_state *pic; xFILE *file; int mode; + int op; khash_t(l) labels; /* object -> int */ khash_t(v) visited; /* object -> int */ int cnt; @@ -53,12 +22,17 @@ struct writer_control { #define WRITE_MODE 1 #define DISPLAY_MODE 2 +#define OP_WRITE 1 +#define OP_WRITE_SHARED 2 +#define OP_WRITE_SIMPLE 3 + static void -writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode) +writer_control_init(struct writer_control *p, pic_state *pic, xFILE *file, int mode, int op) { p->pic = pic; p->file = file; p->mode = mode; + p->op = op; p->cnt = 0; kh_init(l, &p->labels); kh_init(v, &p->visited); @@ -73,49 +47,78 @@ writer_control_destroy(struct writer_control *p) } static void -traverse_shared(struct writer_control *p, pic_value obj) +write_blob(pic_state *pic, pic_blob *blob, xFILE *file) { - pic_state *pic = p->pic; - khash_t(l) *h = &p->labels; - khiter_t it; size_t i; - int ret; - switch (pic_type(obj)) { - case PIC_TT_PAIR: - case PIC_TT_VECTOR: - it = kh_put(l, h, pic_obj_ptr(obj), &ret); - if (ret != 0) { - kh_val(h, it) = -1; - } - else if (kh_val(h, it) == -1) { - kh_val(h, it) = p->cnt++; - break; - } - else { - break; + xfprintf(pic, file, "#u8("); + for (i = 0; i < blob->len; ++i) { + xfprintf(pic, file, "%d", blob->data[i]); + if (i + 1 < blob->len) { + xfprintf(pic, file, " "); } + } + xfprintf(pic, file, ")"); +} - if (pic_pair_p(obj)) { - traverse_shared(p, pic_car(p->pic, obj)); - traverse_shared(p, pic_cdr(p->pic, obj)); - } - else { - for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { - traverse_shared(p, pic_vec_ptr(obj)->data[i]); - } - } - break; - default: - /* pass */ - break; +static void +write_char(pic_state *pic, char c, xFILE *file, int mode) +{ + if (mode == DISPLAY_MODE) { + xfputc(pic, c, file); + return; + } + switch (c) { + default: xfprintf(pic, file, "#\\%c", c); break; + case '\a': xfprintf(pic, file, "#\\alarm"); break; + case '\b': xfprintf(pic, file, "#\\backspace"); break; + case 0x7f: xfprintf(pic, file, "#\\delete"); break; + case 0x1b: xfprintf(pic, file, "#\\escape"); break; + case '\n': xfprintf(pic, file, "#\\newline"); break; + case '\r': xfprintf(pic, file, "#\\return"); break; + case ' ': xfprintf(pic, file, "#\\space"); break; + case '\t': xfprintf(pic, file, "#\\tab"); break; } } +static void +write_str(pic_state *pic, pic_str *str, xFILE *file, int mode) +{ + size_t i; + const char *cstr = pic_str_cstr(pic, str); + + if (mode == DISPLAY_MODE) { + xfprintf(pic, file, "%s", pic_str_cstr(pic, str)); + return; + } + xfprintf(pic, file, "\""); + for (i = 0; i < pic_str_len(str); ++i) { + if (cstr[i] == '"' || cstr[i] == '\\') { + xfputc(pic, '\\', file); + } + xfputc(pic, cstr[i], file); + } + xfprintf(pic, file, "\""); +} + +#if PIC_ENABLE_FLOAT +static void +write_float(pic_state *pic, double f, xFILE *file) +{ + if (isnan(f)) { + xfprintf(pic, file, signbit(f) ? "-nan.0" : "+nan.0"); + } else if (isinf(f)) { + xfprintf(pic, file, signbit(f) ? "-inf.0" : "+inf.0"); + } else { + xfprintf(pic, file, "%f", f); + } +} +#endif + static void write_core(struct writer_control *p, pic_value); static void -write_pair(struct writer_control *p, struct pic_pair *pair) +write_pair_help(struct writer_control *p, struct pic_pair *pair) { pic_state *pic = p->pic; khash_t(l) *lh = &p->labels; @@ -145,7 +148,14 @@ write_pair(struct writer_control *p, struct pic_pair *pair) xfprintf(pic, p->file, " "); } - write_pair(p, pic_pair_ptr(pair->cdr)); + write_pair_help(p, pic_pair_ptr(pair->cdr)); + + if (p->op == OP_WRITE) { + if ((it = kh_get(l, lh, pic_ptr(pair->cdr))) != kh_end(lh) && kh_val(lh, it) != -1) { + it = kh_get(v, vh, pic_ptr(pair->cdr)); + kh_del(v, vh, it); + } + } return; } else { @@ -155,17 +165,91 @@ write_pair(struct writer_control *p, struct pic_pair *pair) } static void -write_str(pic_state *pic, struct pic_string *str, xFILE *file) +write_pair(struct writer_control *p, struct pic_pair *pair) { - size_t i; - const char *cstr = pic_str_cstr(pic, str); + pic_state *pic = p->pic; + xFILE *file = p->file; + pic_sym *tag; - for (i = 0; i < pic_str_len(str); ++i) { - if (cstr[i] == '"' || cstr[i] == '\\') { - xfputc(pic, '\\', file); + 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; } - xfputc(pic, cstr[i], file); } + xfprintf(pic, file, "("); + write_pair_help(p, pair); + xfprintf(pic, file, ")"); +} + +static void +write_vec(struct writer_control *p, pic_vec *vec) +{ + pic_state *pic = p->pic; + xFILE *file = p->file; + size_t i; + + xfprintf(pic, file, "#("); + for (i = 0; i < vec->len; ++i) { + write_core(p, vec->data[i]); + if (i + 1 < vec->len) { + xfprintf(pic, file, " "); + } + } + xfprintf(pic, file, ")"); +} + +static void +write_dict(struct writer_control *p, struct pic_dict *dict) +{ + pic_state *pic = p->pic; + xFILE *file = p->file; + pic_sym *sym; + khiter_t it; + + xfprintf(pic, file, "#.(dictionary"); + pic_dict_for_each (sym, dict, it) { + xfprintf(pic, file, " '%s ", pic_symbol_name(pic, sym)); + write_core(p, pic_dict_ref(pic, dict, sym)); + } + xfprintf(pic, file, ")"); } static void @@ -175,13 +259,8 @@ write_core(struct writer_control *p, pic_value obj) khash_t(l) *lh = &p->labels; khash_t(v) *vh = &p->visited; xFILE *file = p->file; - size_t i; - pic_sym *sym; khiter_t it; int ret; -#if PIC_ENABLE_FLOAT - double f; -#endif /* shared objects */ if (pic_vtype(obj) == PIC_VTYPE_HEAP && ((it = kh_get(l, lh, pic_ptr(obj))) != kh_end(lh)) && kh_val(lh, it) != -1) { @@ -201,175 +280,120 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(pic, file, "()"); break; case PIC_TT_BOOL: - if (pic_true_p(obj)) - xfprintf(pic, file, "#t"); - else - xfprintf(pic, file, "#f"); + xfprintf(pic, file, pic_true_p(obj) ? "#t" : "#f"); break; - case PIC_TT_PAIR: - if (is_quote(pic, obj)) { - xfprintf(pic, file, "'"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_unquote(pic, obj)) { - xfprintf(pic, file, ","); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_unquote_splicing(pic, obj)) { - xfprintf(pic, file, ",@"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - else if (is_quasiquote(pic, obj)) { - xfprintf(pic, file, "`"); - write_core(p, pic_list_ref(pic, obj, 1)); - break; - } - xfprintf(pic, file, "("); - write_pair(p, pic_pair_ptr(obj)); - xfprintf(pic, file, ")"); - break; - case PIC_TT_SYMBOL: - xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); - break; - case PIC_TT_CHAR: - if (p->mode == DISPLAY_MODE) { - xfputc(pic, pic_char(obj), file); - break; - } - switch (pic_char(obj)) { - default: xfprintf(pic, file, "#\\%c", pic_char(obj)); break; - case '\a': xfprintf(pic, file, "#\\alarm"); break; - case '\b': xfprintf(pic, file, "#\\backspace"); break; - case 0x7f: xfprintf(pic, file, "#\\delete"); break; - case 0x1b: xfprintf(pic, file, "#\\escape"); break; - case '\n': xfprintf(pic, file, "#\\newline"); break; - case '\r': xfprintf(pic, file, "#\\return"); break; - case ' ': xfprintf(pic, file, "#\\space"); break; - case '\t': xfprintf(pic, file, "#\\tab"); break; - } - break; -#if PIC_ENABLE_FLOAT - case PIC_TT_FLOAT: - f = pic_float(obj); - if (isnan(f)) { - xfprintf(pic, file, signbit(f) ? "-nan.0" : "+nan.0"); - } else if (isinf(f)) { - xfprintf(pic, file, signbit(f) ? "-inf.0" : "+inf.0"); - } else { - xfprintf(pic, file, "%f", pic_float(obj)); - } - break; -#endif - case PIC_TT_INT: - xfprintf(pic, file, "%d", pic_int(obj)); + case PIC_TT_ID: + xfprintf(pic, file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); break; case PIC_TT_EOF: xfprintf(pic, file, "#.(eof-object)"); break; - case PIC_TT_STRING: - if (p->mode == DISPLAY_MODE) { - xfprintf(pic, file, "%s", pic_str_cstr(pic, pic_str_ptr(obj))); - break; - } - xfprintf(pic, file, "\""); - write_str(pic, pic_str_ptr(obj), file); - xfprintf(pic, file, "\""); + case PIC_TT_INT: + xfprintf(pic, file, "%d", pic_int(obj)); break; - case PIC_TT_VECTOR: - xfprintf(pic, file, "#("); - for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { - write_core(p, pic_vec_ptr(obj)->data[i]); - if (i + 1 < pic_vec_ptr(obj)->len) { - xfprintf(pic, file, " "); - } - } - xfprintf(pic, file, ")"); +#if PIC_ENABLE_FLOAT + case PIC_TT_FLOAT: + write_float(pic, pic_float(obj), file); + break; +#endif + case PIC_TT_SYMBOL: + xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj))); break; case PIC_TT_BLOB: - xfprintf(pic, file, "#u8("); - for (i = 0; i < pic_blob_ptr(obj)->len; ++i) { - xfprintf(pic, file, "%d", pic_blob_ptr(obj)->data[i]); - if (i + 1 < pic_blob_ptr(obj)->len) { - xfprintf(pic, file, " "); - } - } - xfprintf(pic, file, ")"); + write_blob(pic, pic_blob_ptr(obj), file); + break; + case PIC_TT_CHAR: + write_char(pic, pic_char(obj), file, p->mode); + break; + case PIC_TT_STRING: + write_str(pic, pic_str_ptr(obj), file, p->mode); + break; + case PIC_TT_PAIR: + write_pair(p, pic_pair_ptr(obj)); + break; + case PIC_TT_VECTOR: + write_vec(p, pic_vec_ptr(obj)); break; case PIC_TT_DICT: - xfprintf(pic, file, "#.(dictionary"); - pic_dict_for_each (sym, pic_dict_ptr(obj), it) { - xfprintf(pic, file, " '%s ", pic_symbol_name(pic, sym)); - write_core(p, pic_dict_ref(pic, pic_dict_ptr(obj), sym)); - } - xfprintf(pic, file, ")"); - break; - case PIC_TT_ID: - xfprintf(pic, file, "#", pic_symbol_name(pic, pic_var_name(pic, obj))); + write_dict(p, pic_dict_ptr(obj)); break; default: xfprintf(pic, file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); break; } + + if (p->op == OP_WRITE) { + if (pic_obj_p(obj) && ((it = kh_get(l, lh, pic_ptr(obj))) != kh_end(lh)) && kh_val(lh, it) != -1) { + it = kh_get(v, vh, pic_ptr(obj)); + kh_del(v, vh, it); + } + } } static void -write(pic_state *pic, pic_value obj, xFILE *file) +traverse(struct writer_control *p, pic_value obj) +{ + pic_state *pic = p->pic; + + if (p->op == OP_WRITE_SIMPLE) { + return; + } + + switch (pic_type(obj)) { + case PIC_TT_PAIR: + case PIC_TT_VECTOR: { + khash_t(l) *h = &p->labels; + khiter_t it; + int ret; + + it = kh_put(l, h, pic_ptr(obj), &ret); + if (ret != 0) { + /* first time */ + kh_val(h, it) = -1; + + if (pic_pair_p(obj)) { + /* pair */ + traverse(p, pic_car(pic, obj)); + traverse(p, pic_cdr(pic, obj)); + } else { + /* vector */ + size_t i; + for (i = 0; i < pic_vec_ptr(obj)->len; ++i) { + traverse(p, pic_vec_ptr(obj)->data[i]); + } + } + + if (p->op == OP_WRITE) { + it = kh_get(l, h, pic_ptr(obj)); + if (kh_val(h, it) == -1) { + kh_del(l, h, it); + } + } + } else if (kh_val(h, it) == -1) { + /* second time */ + kh_val(h, it) = p->cnt++; + } + break; + } + default: + break; + } +} + +static void +write(pic_state *pic, pic_value obj, xFILE *file, int mode, int op) { struct writer_control p; - writer_control_init(&p, pic, file, WRITE_MODE); + writer_control_init(&p, pic, file, mode, op); - traverse_shared(&p, obj); /* FIXME */ + traverse(&p, obj); write_core(&p, obj); writer_control_destroy(&p); } -static void -write_simple(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, WRITE_MODE); - - /* no traverse here! */ - - write_core(&p, obj); - - writer_control_destroy(&p); -} - -static void -write_shared(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, WRITE_MODE); - - traverse_shared(&p, obj); - - write_core(&p, obj); - - writer_control_destroy(&p); -} - -static void -display(pic_state *pic, pic_value obj, xFILE *file) -{ - struct writer_control p; - - writer_control_init(&p, pic, file, DISPLAY_MODE); - - traverse_shared(&p, obj); /* FIXME */ - - write_core(&p, obj); - - writer_control_destroy(&p); -} pic_value pic_write(pic_state *pic, pic_value obj) @@ -380,7 +404,7 @@ pic_write(pic_state *pic, pic_value obj) pic_value pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) { - write(pic, obj, file); + write(pic, obj, file, WRITE_MODE, OP_WRITE); xfflush(pic, file); return obj; } @@ -394,7 +418,7 @@ pic_display(pic_state *pic, pic_value obj) pic_value pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) { - display(pic, obj, file); + write(pic, obj, file, DISPLAY_MODE, OP_WRITE); xfflush(pic, file); return obj; } @@ -423,7 +447,7 @@ pic_write_write(pic_state *pic) struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write(pic, v, port->file); + write(pic, v, port->file, WRITE_MODE, OP_WRITE); return pic_undef_value(); } @@ -434,7 +458,7 @@ pic_write_write_simple(pic_state *pic) struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write_simple(pic, v, port->file); + write(pic, v, port->file, WRITE_MODE, OP_WRITE_SIMPLE); return pic_undef_value(); } @@ -445,7 +469,7 @@ pic_write_write_shared(pic_state *pic) struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - write_shared(pic, v, port->file); + write(pic, v, port->file, WRITE_MODE, OP_WRITE_SHARED); return pic_undef_value(); } @@ -456,7 +480,7 @@ pic_write_display(pic_state *pic) struct pic_port *port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); - display(pic, v, port->file); + write(pic, v, port->file, DISPLAY_MODE, OP_WRITE); return pic_undef_value(); }