From 26808c1f51e066438a45053d43174cdef4a80720 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 18 Feb 2014 04:22:58 +0900
Subject: [PATCH] add write function in C level (must not enter into a infinite
 loop)

---
 piclib/built-in.scm |  3 --
 src/write.c         | 68 ++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 67 insertions(+), 4 deletions(-)

diff --git a/piclib/built-in.scm b/piclib/built-in.scm
index d214e34f..2dc448c2 100644
--- a/piclib/built-in.scm
+++ b/piclib/built-in.scm
@@ -733,9 +733,6 @@
 (define-library (scheme write)
   (import (scheme base))
 
-  ;; FIXME
-  (define write write-simple)
-
   (define (display obj . opts)
     (let ((port (if (null? opts) (current-output-port) (car opts))))
       (cond
diff --git a/src/write.c b/src/write.c
index 80143bd8..2e16e9b0 100644
--- a/src/write.c
+++ b/src/write.c
@@ -109,6 +109,46 @@ traverse_shared(struct writer_control *p, pic_value obj)
   }
 }
 
+static void
+traverse_seq(struct writer_control *p, pic_value obj)
+{
+  xh_entry *e;
+  size_t i;
+
+  switch (pic_type(obj)) {
+  case PIC_TT_PAIR:
+  case PIC_TT_VECTOR:
+    e = xh_get(p->labels, pic_obj_ptr(obj));
+    if (e == NULL) {
+      xh_put(p->labels, pic_obj_ptr(obj), -1);
+    }
+    else if (e->val == -1) {
+      xh_put(p->labels, pic_obj_ptr(obj), p->cnt++);
+      break;
+    }
+    else {
+      break;
+    }
+
+    if (pic_pair_p(obj)) {
+      traverse_seq(p, pic_car(p->pic, obj));
+      traverse_seq(p, pic_cdr(p->pic, obj));
+    }
+    else {
+      for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
+        traverse_seq(p, pic_vec_ptr(obj)->data[i]);
+      }
+    }
+
+    xh_del(p->labels, pic_obj_ptr(obj));
+    assert(xh_get(p->labels, pic_obj_ptr(obj)) == NULL);
+    break;
+  default:
+    /* pass */
+    break;
+  }
+}
+
 static void write_core(struct writer_control *p, pic_value);
 
 static void
@@ -313,6 +353,20 @@ write_core(struct writer_control *p, pic_value obj)
   }
 }
 
+static void
+write(pic_state *pic, pic_value obj, XFILE *file)
+{
+  struct writer_control *p;
+
+  p = writer_control_new(pic, file);
+
+  traverse_seq(p, obj);
+
+  write_core(p, obj);
+
+  writer_control_destroy(p);
+}
+
 static void
 write_simple(pic_state *pic, pic_value obj, XFILE *file)
 {
@@ -350,11 +404,22 @@ pic_debug(pic_state *pic, pic_value obj)
 pic_value
 pic_fdebug(pic_state *pic, pic_value obj, XFILE *file)
 {
-  write_shared(pic, obj, file);
+  write(pic, obj, file);
   xfflush(file);
   return obj;
 }
 
+static pic_value
+pic_port_write(pic_state *pic)
+{
+  pic_value v;
+  struct pic_port *port = pic_stdout(pic);
+
+  pic_get_args(pic, "o|p", &v, &port);
+  write(pic, v, port->file);
+  return pic_none_value();
+}
+
 static pic_value
 pic_port_write_simple(pic_state *pic)
 {
@@ -381,6 +446,7 @@ void
 pic_init_write(pic_state *pic)
 {
   pic_deflibrary ("(scheme write)") {
+    pic_defun(pic, "write", pic_port_write);
     pic_defun(pic, "write-simple", pic_port_write_simple);
     pic_defun(pic, "write-shared", pic_port_write_shared);
   }