Merge branch 'saner-write'

This commit is contained in:
Yuichi Nishiwaki 2015-06-25 18:51:31 +09:00
commit 9fc8ccb641
1 changed files with 249 additions and 225 deletions

View File

@ -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, "#<identifier %s>", 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, "#<identifier %s>", 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();
}