Merge branch 'saner-write'

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)) {
+  xfprintf(pic, file, "#u8(");
-  case PIC_TT_PAIR:
+  for (i = 0; i < blob->len; ++i) {
-  case PIC_TT_VECTOR:
+    xfprintf(pic, file, "%d", blob->data[i]);
-    it = kh_put(l, h, pic_obj_ptr(obj), &ret);
+    if (i + 1 < blob->len) {
-    if (ret != 0) {
+      xfprintf(pic, file, " ");
-      kh_val(h, it) = -1;
     }
-    else if (kh_val(h, it) == -1) {
-      kh_val(h, it) = p->cnt++;
-      break;
-    }
-    else {
-      break;
   }
+  xfprintf(pic, file, ")");
+}
 
-    if (pic_pair_p(obj)) {
+static void
-      traverse_shared(p, pic_car(p->pic, obj));
+write_char(pic_state *pic, char c, xFILE *file, int mode)
-      traverse_shared(p, pic_cdr(p->pic, obj));
+{
+  if (mode == DISPLAY_MODE) {
+    xfputc(pic, c, file);
+    return;
   }
-    else {
+  switch (c) {
-      for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
+  default: xfprintf(pic, file, "#\\%c", c); break;
-        traverse_shared(p, pic_vec_ptr(obj)->data[i]);
+  case '\a': xfprintf(pic, file, "#\\alarm"); break;
-      }
+  case '\b': xfprintf(pic, file, "#\\backspace"); break;
-    }
+  case 0x7f: xfprintf(pic, file, "#\\delete"); break;
-    break;
+  case 0x1b: xfprintf(pic, file, "#\\escape"); break;
-  default:
+  case '\n': xfprintf(pic, file, "#\\newline"); break;
-    /* pass */
+  case '\r': xfprintf(pic, file, "#\\return"); break;
-    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;
+  pic_state *pic = p->pic;
-  const char *cstr = pic_str_cstr(pic, str);
+  xFILE *file = p->file;
+  pic_sym *tag;
 
-  for (i = 0; i < pic_str_len(str); ++i) {
+  if (pic_pair_p(pair->cdr) && pic_nil_p(pic_cdr(pic, pair->cdr)) && pic_sym_p(pair->car)) {
-    if (cstr[i] == '"' || cstr[i] == '\\') {
+    tag = pic_sym_ptr(pair->car);
-      xfputc(pic, '\\', file);
+    if (tag == pic->sQUOTE) {
+      xfprintf(pic, file, "'");
+      write_core(p, pic_car(pic, pair->cdr));
+      return;
     }
-    xfputc(pic, cstr[i], file);
+    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_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, pic_true_p(obj) ? "#t" : "#f");
-      xfprintf(pic, file, "#t");
-    else
-      xfprintf(pic, file, "#f");
     break;
-  case PIC_TT_PAIR:
+  case PIC_TT_ID:
-    if (is_quote(pic, obj)) {
+    xfprintf(pic, file, "#<identifier %s>", pic_symbol_name(pic, pic_var_name(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));
     break;
   case PIC_TT_EOF:
     xfprintf(pic, file, "#.(eof-object)");
     break;
-  case PIC_TT_STRING:
+  case PIC_TT_INT:
-    if (p->mode == DISPLAY_MODE) {
+    xfprintf(pic, file, "%d", pic_int(obj));
-      xfprintf(pic, file, "%s", pic_str_cstr(pic, pic_str_ptr(obj)));
     break;
-    }
+#if PIC_ENABLE_FLOAT
-    xfprintf(pic, file, "\"");
+  case PIC_TT_FLOAT:
-    write_str(pic, pic_str_ptr(obj), file);
+    write_float(pic, pic_float(obj), file);
-    xfprintf(pic, file, "\"");
     break;
-  case PIC_TT_VECTOR:
+#endif
-    xfprintf(pic, file, "#(");
+  case PIC_TT_SYMBOL:
-    for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
+    xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj)));
-      write_core(p, pic_vec_ptr(obj)->data[i]);
-      if (i + 1 < pic_vec_ptr(obj)->len) {
-	xfprintf(pic, file, " ");
-      }
-    }
-    xfprintf(pic, file, ")");
     break;
   case PIC_TT_BLOB:
-    xfprintf(pic, file, "#u8(");
+    write_blob(pic, pic_blob_ptr(obj), file);
-    for (i = 0; i < pic_blob_ptr(obj)->len; ++i) {
+    break;
-      xfprintf(pic, file, "%d", pic_blob_ptr(obj)->data[i]);
+  case PIC_TT_CHAR:
-      if (i + 1 < pic_blob_ptr(obj)->len) {
+    write_char(pic, pic_char(obj), file, p->mode);
-	xfprintf(pic, file, " ");
+    break;
-      }
+  case PIC_TT_STRING:
-    }
+    write_str(pic, pic_str_ptr(obj), file, p->mode);
-    xfprintf(pic, file, ")");
+    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");
+    write_dict(p, pic_dict_ptr(obj));
-    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)));
     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();
 }