/** * See Copyright Notice in picrin.h */ #include "picrin.h" #include "picrin/extra.h" #include "picrin/private/object.h" struct writer_control { int mode; int op; int cnt; pic_value shared; /* is object shared? (yes if >0) */ pic_value labels; /* object -> int */ }; #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(pic_state *pic, struct writer_control *p, int mode, int op) { p->mode = mode; p->op = op; p->cnt = 0; p->shared = pic_make_weak(pic); p->labels = pic_make_weak(pic); } static void traverse(pic_state *pic, pic_value obj, struct writer_control *p) { pic_value shared = p->shared; if (p->op == OP_WRITE_SIMPLE) { return; } switch (pic_type(pic, obj)) { case PIC_TYPE_PAIR: case PIC_TYPE_VECTOR: case PIC_TYPE_DICT: { if (! pic_weak_has(pic, shared, obj)) { /* first time */ pic_weak_set(pic, shared, obj, pic_int_value(pic, 0)); if (pic_pair_p(pic, obj)) { /* pair */ traverse(pic, pic_car(pic, obj), p); traverse(pic, pic_cdr(pic, obj), p); } else if (pic_vec_p(pic, obj)) { /* vector */ int i, len = pic_vec_len(pic, obj); for (i = 0; i < len; ++i) { traverse(pic, pic_vec_ref(pic, obj, i), p); } } else { /* dictionary */ int it = 0; pic_value val; while (pic_dict_next(pic, obj, &it, NULL, &val)) { traverse(pic, val, p); } } if (p->op == OP_WRITE) { if (pic_int(pic, pic_weak_ref(pic, shared, obj)) == 0) { pic_weak_del(pic, shared, obj); } } } else { /* second time */ pic_weak_set(pic, shared, obj, pic_int_value(pic, 1)); } break; } default: break; } } static bool is_shared_object(pic_state *pic, pic_value obj, struct writer_control *p) { pic_value shared = p->shared; if (! pic_obj_p(pic, obj)) { return false; } if (! pic_weak_has(pic, shared, obj)) { return false; } return pic_int(pic, pic_weak_ref(pic, shared, obj)) > 0; } 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, pic_value ch, xFILE *file, struct writer_control *p) { char c = pic_char(pic, ch); if (p->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, struct writer_control *p) { int i; const char *cstr = pic_str(pic, str); if (p->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, pic_value flo, xFILE *file) { double f = pic_float(pic, flo); 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(pic_state *, pic_value, xFILE *, struct writer_control *); static void write_pair_help(pic_state *pic, pic_value pair, xFILE *file, struct writer_control *p) { pic_value cdr = pic_cdr(pic, pair); write_core(pic, pic_car(pic, pair), file, p); if (pic_nil_p(pic, cdr)) { return; } else if (pic_pair_p(pic, cdr) && ! is_shared_object(pic, cdr, p)) { xfprintf(pic, file, " "); write_pair_help(pic, cdr, file, p); } else { xfprintf(pic, file, " . "); write_core(pic, cdr, file, p); } } #define EQ(sym, lit) (strcmp(pic_str(pic, pic_sym_name(pic, sym)), lit) == 0) static void write_pair(pic_state *pic, pic_value pair, xFILE *file, 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")) { xfprintf(pic, file, "'"); write_core(pic, pic_cadr(pic, pair), file, p); return; } else if (EQ(tag, "unquote")) { xfprintf(pic, file, ","); write_core(pic, pic_cadr(pic, pair), file, p); return; } else if (EQ(tag, "unquote-splicing")) { xfprintf(pic, file, ",@"); write_core(pic, pic_cadr(pic, pair), file, p); return; } else if (EQ(tag, "quasiquote")) { xfprintf(pic, file, "`"); write_core(pic, pic_cadr(pic, pair), file, p); return; } else if (EQ(tag, "syntax-quote")) { xfprintf(pic, file, "#'"); write_core(pic, pic_cadr(pic, pair), file, p); return; } else if (EQ(tag, "syntax-unquote")) { xfprintf(pic, file, "#,"); write_core(pic, pic_cadr(pic, pair), file, p); return; } else if (EQ(tag, "syntax-unquote-splicing")) { xfprintf(pic, file, "#,@"); write_core(pic, pic_cadr(pic, pair), file, p); return; } else if (EQ(tag, "syntax-quasiquote")) { xfprintf(pic, file, "#`"); write_core(pic, pic_cadr(pic, pair), file, p); return; } } xfprintf(pic, file, "("); write_pair_help(pic, pair, file, p); xfprintf(pic, file, ")"); } static void write_vec(pic_state *pic, pic_value vec, xFILE *file, struct writer_control *p) { int i, len = pic_vec_len(pic, vec); xfprintf(pic, file, "#("); for (i = 0; i < len; ++i) { write_core(pic, pic_vec_ref(pic, vec, i), file, p); if (i + 1 < len) { xfprintf(pic, file, " "); } } xfprintf(pic, file, ")"); } static void write_dict(pic_state *pic, pic_value dict, xFILE *file, struct writer_control *p) { 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(pic, val, file, p); } xfprintf(pic, file, ")"); } static void write_core(pic_state *pic, pic_value obj, xFILE *file, struct writer_control *p) { pic_value labels = p->labels; int i; /* shared objects */ if (is_shared_object(pic, obj, p)) { if (pic_weak_has(pic, labels, obj)) { xfprintf(pic, file, "#%d#", pic_int(pic, pic_weak_ref(pic, labels, obj))); return; } i = p->cnt++; xfprintf(pic, file, "#%d=", i); pic_weak_set(pic, labels, obj, pic_int_value(pic, i)); } 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_SYMBOL: xfprintf(pic, file, "%s", pic_str(pic, pic_sym_name(pic, obj))); break; case PIC_TYPE_FLOAT: write_float(pic, obj, file); break; case PIC_TYPE_BLOB: write_blob(pic, obj, file); break; case PIC_TYPE_CHAR: write_char(pic, obj, file, p); break; case PIC_TYPE_STRING: write_str(pic, obj, file, p); break; case PIC_TYPE_PAIR: write_pair(pic, obj, file, p); break; case PIC_TYPE_VECTOR: write_vec(pic, obj, file, p); break; case PIC_TYPE_DICT: write_dict(pic, obj, file, p); 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 (is_shared_object(pic, obj, p)) { pic_weak_del(pic, labels, obj); } } } static void write(pic_state *pic, pic_value obj, xFILE *file, int mode, int op) { struct writer_control p; writer_control_init(pic, &p, mode, op); traverse(pic, obj, &p); write_core(pic, obj, file, &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); }