/** * See Copyright Notice in picrin.h */ #include "picrin.h" #include "picrin/extra.h" #include "picrin/private/object.h" KHASH_DECLARE(l, void *, int) KHASH_DECLARE(v, void *, int) KHASH_DEFINE2(l, void *, int, 1, kh_ptr_hash_func, kh_ptr_hash_equal) KHASH_DEFINE2(v, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal) 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; }; #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, 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); } static void writer_control_destroy(struct writer_control *p) { pic_state *pic = p->pic; kh_destroy(l, &p->labels); kh_destroy(v, &p->visited); } static void write_blob(pic_state *pic, pic_value blob, xFILE *file) { const unsigned char *buf; int len, i; buf = pic_blob(pic, blob, &len); xfprintf(pic, file, "#u8("); for (i = 0; i < len; ++i) { xfprintf(pic, file, "%d", buf[i]); if (i + 1 < len) { xfprintf(pic, file, " "); } } xfprintf(pic, file, ")"); } 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_value str, xFILE *file, int mode) { int i; const char *cstr = pic_str(pic, str); if (mode == DISPLAY_MODE) { xfprintf(pic, file, "%s", pic_str(pic, str)); return; } xfprintf(pic, file, "\""); for (i = 0; i < pic_str_len(pic, str); ++i) { if (cstr[i] == '"' || cstr[i] == '\\') { xfputc(pic, '\\', file); } xfputc(pic, cstr[i], file); } xfprintf(pic, file, "\""); } static void write_float(pic_state *pic, double f, xFILE *file) { if (f != f) { xfprintf(pic, file, "+nan.0"); } else if (f == 1.0 / 0.0) { xfprintf(pic, file, "+inf.0"); } else if (f == -1.0 / 0.0) { xfprintf(pic, file, "-inf.0"); } else { xfprintf(pic, file, "%f", f); } } static void write_core(struct writer_control *p, pic_value); static void write_pair_help(struct writer_control *p, pic_value pair) { pic_state *pic = p->pic; khash_t(l) *lh = &p->labels; khash_t(v) *vh = &p->visited; int it; int ret; write_core(p, pic_car(pic, pair)); if (pic_nil_p(pic, pic_cdr(pic, pair))) { return; } else if (pic_pair_p(pic, pic_cdr(pic, pair))) { /* shared objects */ if ((it = kh_get(l, lh, pic_obj_ptr(pic_cdr(pic, pair)))) != kh_end(lh) && kh_val(lh, it) != -1) { xfprintf(pic, p->file, " . "); kh_put(v, vh, pic_obj_ptr(pic_cdr(pic, pair)), &ret); if (ret == 0) { /* if exists */ xfprintf(pic, p->file, "#%d#", kh_val(lh, it)); return; } xfprintf(pic, p->file, "#%d=", kh_val(lh, it)); } else { xfprintf(pic, p->file, " "); } write_pair_help(p, pic_cdr(pic, pair)); if (p->op == OP_WRITE) { if ((it = kh_get(l, lh, pic_obj_ptr(pic_cdr(pic, pair)))) != kh_end(lh) && kh_val(lh, it) != -1) { it = kh_get(v, vh, pic_obj_ptr(pic_cdr(pic, pair))); kh_del(v, vh, it); } } return; } else { xfprintf(pic, p->file, " . "); write_core(p, pic_cdr(pic, pair)); } } #define EQ(sym, lit) (strcmp(pic_str(pic, pic_sym_name(pic, sym)), lit) == 0) static void write_pair(struct writer_control *p, pic_value pair) { pic_state *pic = p->pic; xFILE *file = p->file; 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")) { xfprintf(pic, file, "'"); write_core(p, pic_cadr(pic, pair)); return; } else if (EQ(tag, "unquote")) { xfprintf(pic, file, ","); write_core(p, pic_cadr(pic, pair)); return; } else if (EQ(tag, "unquote-splicing")) { xfprintf(pic, file, ",@"); write_core(p, pic_cadr(pic, pair)); return; } else if (EQ(tag, "quasiquote")) { xfprintf(pic, file, "`"); write_core(p, pic_cadr(pic, pair)); return; } else if (EQ(tag, "syntax-quote")) { xfprintf(pic, file, "#'"); write_core(p, pic_cadr(pic, pair)); return; } else if (EQ(tag, "syntax-unquote")) { xfprintf(pic, file, "#,"); write_core(p, pic_cadr(pic, pair)); return; } else if (EQ(tag, "syntax-unquote-splicing")) { xfprintf(pic, file, "#,@"); write_core(p, pic_cadr(pic, pair)); return; } else if (EQ(tag, "syntax-quasiquote")) { xfprintf(pic, file, "#`"); write_core(p, pic_cadr(pic, pair)); return; } } xfprintf(pic, file, "("); write_pair_help(p, pair); xfprintf(pic, file, ")"); } static void write_vec(struct writer_control *p, pic_value vec) { pic_state *pic = p->pic; xFILE *file = p->file; int i, len = pic_vec_len(pic, vec); xfprintf(pic, file, "#("); for (i = 0; i < len; ++i) { write_core(p, pic_vec_ref(pic, vec, i)); if (i + 1 < len) { xfprintf(pic, file, " "); } } xfprintf(pic, file, ")"); } static void write_dict(struct writer_control *p, pic_value dict) { pic_state *pic = p->pic; xFILE *file = p->file; pic_value key, val; int it = 0; xfprintf(pic, file, "#.(dictionary"); while (pic_dict_next(pic, dict, &it, &key, &val)) { xfprintf(pic, file, " '%s ", pic_str(pic, pic_sym_name(pic, key))); write_core(p, val); } xfprintf(pic, file, ")"); } static void write_core(struct writer_control *p, pic_value obj) { pic_state *pic = p->pic; khash_t(l) *lh = &p->labels; khash_t(v) *vh = &p->visited; xFILE *file = p->file; int it; int ret; /* shared objects */ if (pic_obj_p(pic, obj) && ((it = kh_get(l, lh, pic_obj_ptr(obj))) != kh_end(lh)) && kh_val(lh, it) != -1) { kh_put(v, vh, pic_obj_ptr(obj), &ret); if (ret == 0) { /* if exists */ xfprintf(pic, file, "#%d#", kh_val(lh, it)); return; } xfprintf(pic, file, "#%d=", kh_val(lh, it)); } switch (pic_type(pic, obj)) { case PIC_TYPE_UNDEF: xfprintf(pic, file, "#undefined"); break; case PIC_TYPE_NIL: xfprintf(pic, file, "()"); break; case PIC_TYPE_TRUE: xfprintf(pic, file, "#t"); break; case PIC_TYPE_FALSE: xfprintf(pic, file, "#f"); break; case PIC_TYPE_ID: xfprintf(pic, file, "#", pic_str(pic, pic_id_name(pic, obj))); break; case PIC_TYPE_EOF: xfprintf(pic, file, "#.(eof-object)"); break; case PIC_TYPE_INT: xfprintf(pic, file, "%d", pic_int(pic, obj)); break; case PIC_TYPE_FLOAT: write_float(pic, pic_float(pic, obj), file); break; case PIC_TYPE_SYMBOL: xfprintf(pic, file, "%s", pic_str(pic, pic_sym_name(pic, obj))); break; case PIC_TYPE_BLOB: write_blob(pic, obj, file); break; case PIC_TYPE_CHAR: write_char(pic, pic_char(pic, obj), file, p->mode); break; case PIC_TYPE_STRING: write_str(pic, obj, file, p->mode); break; case PIC_TYPE_PAIR: write_pair(p, obj); break; case PIC_TYPE_VECTOR: write_vec(p, obj); break; case PIC_TYPE_DICT: write_dict(p, obj); break; default: xfprintf(pic, file, "#<%s %p>", pic_typename(pic, pic_type(pic, obj)), pic_obj_ptr(obj)); break; } if (p->op == OP_WRITE) { if (pic_obj_p(pic, obj) && ((it = kh_get(l, lh, pic_obj_ptr(obj))) != kh_end(lh)) && kh_val(lh, it) != -1) { it = kh_get(v, vh, pic_obj_ptr(obj)); kh_del(v, vh, it); } } } static void traverse(struct writer_control *p, pic_value obj) { pic_state *pic = p->pic; if (p->op == OP_WRITE_SIMPLE) { return; } switch (pic_type(pic, obj)) { case PIC_TYPE_PAIR: case PIC_TYPE_VECTOR: case PIC_TYPE_DICT: { khash_t(l) *h = &p->labels; int it; int ret; it = kh_put(l, h, pic_obj_ptr(obj), &ret); if (ret != 0) { /* first time */ kh_val(h, it) = -1; if (pic_pair_p(pic, obj)) { /* pair */ traverse(p, pic_car(pic, obj)); traverse(p, pic_cdr(pic, obj)); } else if (pic_vec_p(pic, obj)) { /* vector */ int i, len = pic_vec_len(pic, obj); for (i = 0; i < len; ++i) { traverse(p, pic_vec_ref(pic, obj, i)); } } else { /* dictionary */ int it = 0; pic_value val; while (pic_dict_next(pic, obj, &it, NULL, &val)) { traverse(p, val); } } if (p->op == OP_WRITE) { it = kh_get(l, h, pic_obj_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, mode, op); traverse(&p, obj); write_core(&p, obj); writer_control_destroy(&p); } pic_value pic_write(pic_state *pic, pic_value obj) { return pic_fwrite(pic, obj, pic_fileno(pic, pic_stdout(pic))); } pic_value pic_fwrite(pic_state *pic, pic_value obj, xFILE *file) { write(pic, obj, file, WRITE_MODE, OP_WRITE); xfflush(pic, file); return obj; } pic_value pic_display(pic_state *pic, pic_value obj) { return pic_fdisplay(pic, obj, pic_fileno(pic, pic_stdout(pic))); } pic_value pic_fdisplay(pic_state *pic, pic_value obj, xFILE *file) { write(pic, obj, file, DISPLAY_MODE, OP_WRITE); xfflush(pic, file); return obj; } void pic_vfprintf(pic_state *pic, pic_value port, const char *fmt, va_list ap) { xFILE *file = pic_fileno(pic, port); pic_value str; str = pic_vstrf_value(pic, fmt, ap); xfprintf(pic, file, "%s", pic_str(pic, str)); xfflush(pic, file); } void pic_fprintf(pic_state *pic, pic_value port, const char *fmt, ...) { va_list ap; va_start(ap, fmt); pic_vfprintf(pic, port, fmt, ap); va_end(ap); } void pic_printf(pic_state *pic, const char *fmt, ...) { va_list ap; va_start(ap, fmt); pic_vfprintf(pic, pic_stdout(pic), fmt, ap); va_end(ap); } static pic_value pic_write_write(pic_state *pic) { pic_value v, port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE); return pic_undef_value(pic); } static pic_value pic_write_write_simple(pic_state *pic) { pic_value v, port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SIMPLE); return pic_undef_value(pic); } static pic_value pic_write_write_shared(pic_state *pic) { pic_value v, port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); write(pic, v, pic_fileno(pic, port), WRITE_MODE, OP_WRITE_SHARED); return pic_undef_value(pic); } static pic_value pic_write_display(pic_state *pic) { pic_value v, port = pic_stdout(pic); pic_get_args(pic, "o|p", &v, &port); write(pic, v, pic_fileno(pic, port), DISPLAY_MODE, OP_WRITE); return pic_undef_value(pic); } void pic_init_write(pic_state *pic) { pic_defun(pic, "write", pic_write_write); pic_defun(pic, "write-simple", pic_write_write_simple); pic_defun(pic, "write-shared", pic_write_write_shared); pic_defun(pic, "display", pic_write_display); }