From 1e4bc0411214f1013b8873872b8c832eaf80915c Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 21 Jul 2014 22:51:33 +0900
Subject: [PATCH 01/16] rewrite list<->vector converters in c

---
 piclib/picrin/macro.scm | 18 -----------------
 piclib/prelude.scm      | 41 ++------------------------------------
 src/vector.c            | 44 +++++++++++++++++++++++++++++++++++++++++
 3 files changed, 46 insertions(+), 57 deletions(-)

diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm
index 2f9fe7e0..5682d8ca 100644
--- a/piclib/picrin/macro.scm
+++ b/piclib/picrin/macro.scm
@@ -6,24 +6,6 @@
 
   ;; assumes no derived expressions are provided yet
 
-  (define (list->vector list)
-    (define vector (make-vector (length list)))
-    (define (go list i)
-      (if (null? list)
-          vector
-          (begin
-            (vector-set! vector i (car list))
-            (go (cdr list) (+ i 1)))))
-    (go list 0))
-
-  (define (vector->list vector)
-    (define (go i)
-      (if (= i (vector-length vector))
-          '()
-          (cons (vector-ref vector i)
-                (go (+ i 1)))))
-    (go 0))
-
   (define (walk proc expr)
     "walk on symbols"
     (if (null? expr)
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 7049c2f0..2f5f9dae 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -91,22 +91,6 @@
                        (r 'it)
                        (cons (r 'or) (cdr exprs))))))))))
 
-  (define (list->vector list)
-    (let ((vector (make-vector (length list))))
-      (let loop ((list list) (i 0))
-        (if (null? list)
-            vector
-            (begin
-              (vector-set! vector i (car list))
-              (loop (cdr list) (+ i 1)))))))
-
-  (define (vector->list vector)
-    (let ((length (vector-length vector)))
-      (let loop ((list '()) (i 0))
-        (if (= i length)
-            (reverse list)
-            (loop (cons (vector-ref vector i) list) (+ i 1))))))
-
   (define-syntax quasiquote
     (ir-macro-transformer
      (lambda (form inject compare)
@@ -714,27 +698,7 @@
 ;;; 6.8. Vector
 
 (define (vector . objs)
-  (let ((len (length objs)))
-    (let ((v (make-vector len)))
-      (do ((i 0 (+ i 1))
-	   (l objs (cdr l)))
-	  ((= i len)
-	   v)
-	(vector-set! v i (car l))))))
-
-(define (vector->list vector . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (vector-length vector))))
-    (do ((i start (+ i 1))
-	 (res '()))
-	((= i end)
-	 (reverse res))
-      (set! res (cons (vector-ref vector i) res)))))
-
-(define (list->vector list)
-  (apply vector list))
+  (list->vector objs))
 
 (define (vector-copy! to at from . opts)
   (let* ((start (if (pair? opts) (car opts) 0))
@@ -785,8 +749,7 @@
 (define (string->vector . args)
   (list->vector (apply string->list args)))
 
-(export vector vector->list list->vector
-        vector-copy! vector-copy
+(export vector vector-copy! vector-copy
         vector-append vector-fill!
         vector->string string->vector)
 
diff --git a/src/vector.c b/src/vector.c
index 917f0878..1315753f 100644
--- a/src/vector.c
+++ b/src/vector.c
@@ -119,6 +119,48 @@ pic_vec_vector_set(pic_state *pic)
   return pic_none_value();
 }
 
+static pic_value
+pic_vec_list_to_vector(pic_state *pic)
+{
+  struct pic_vector *vec;
+  pic_value list, e, *data;
+
+  pic_get_args(pic, "o", &list);
+
+  vec = pic_vec_new(pic, pic_length(pic, list));
+
+  data = vec->data;
+
+  pic_for_each (e, list) {
+    *data++ = e;
+  }
+  return pic_obj_value(vec);
+}
+
+static pic_value
+pic_vec_vector_to_list(pic_state *pic)
+{
+  struct pic_vector *vec;
+  pic_value list;
+  int n, start, end, i;
+
+  n = pic_get_args(pic, "v|ii", &vec, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = vec->len;
+  }
+
+  list = pic_nil_value();
+
+  for (i = start; i < end; ++i) {
+    pic_push(pic, vec->data[i], list);
+  }
+  return pic_reverse(pic, list);
+}
+
 void
 pic_init_vector(pic_state *pic)
 {
@@ -127,4 +169,6 @@ pic_init_vector(pic_state *pic)
   pic_defun(pic, "vector-length", pic_vec_vector_length);
   pic_defun(pic, "vector-ref", pic_vec_vector_ref);
   pic_defun(pic, "vector-set!", pic_vec_vector_set);
+  pic_defun(pic, "list->vector", pic_vec_list_to_vector);
+  pic_defun(pic, "vector->list", pic_vec_vector_to_list);
 }

From 341e4048eb434f375cd311f4b6cc284cad79997c Mon Sep 17 00:00:00 2001
From: "Sunrim KIM (keen)" <3han5chou7@gmail.com>
Date: Mon, 21 Jul 2014 22:56:53 +0900
Subject: [PATCH 02/16] fix a bug of `test-values` and unlock the test cases
 that use `test-values`

---
 piclib/picrin/test.scm |  4 +---
 t/r7rs-tests.scm       | 18 +++++++++---------
 2 files changed, 10 insertions(+), 12 deletions(-)

diff --git a/piclib/picrin/test.scm b/piclib/picrin/test.scm
index f786ba58..1e938e11 100644
--- a/piclib/picrin/test.scm
+++ b/piclib/picrin/test.scm
@@ -69,9 +69,7 @@
   (define-syntax test-values
     (syntax-rules ()
       ((_ expect expr)
-       (test-values #f expect expr))
-      ((_ name expect expr)
-       (test name (call-with-values (lambda () expect) (lambda results results))
+       (test (call-with-values (lambda () expect) (lambda results results))
              (call-with-values (lambda () expr) (lambda results results))))))
 
 
diff --git a/t/r7rs-tests.scm b/t/r7rs-tests.scm
index 1cf0cb0a..c02b0c9d 100644
--- a/t/r7rs-tests.scm
+++ b/t/r7rs-tests.scm
@@ -763,15 +763,15 @@
 (test 7 (abs -7))
 (test 7 (abs 7))
 
-;; (test-values (values 2 1) (floor/ 5 2))
-;; (test-values (values -3 1) (floor/ -5 2))
-;; (test-values (values -3 -1) (floor/ 5 -2))
-;; (test-values (values 2 -1) (floor/ -5 -2))
-;; (test-values (values 2 1) (truncate/ 5 2))
-;; (test-values (values -2 -1) (truncate/ -5 2))
-;; (test-values (values -2 1) (truncate/ 5 -2))
-;; (test-values (values 2 -1) (truncate/ -5 -2))
-;; (test-values (values 2.0 -1.0) (truncate/ -5.0 -2))
+(test-values (values 2 1) (floor/ 5 2))
+(test-values (values -3 1) (floor/ -5 2))
+(test-values (values -3 -1) (floor/ 5 -2))
+(test-values (values 2 -1) (floor/ -5 -2))
+(test-values (values 2 1) (truncate/ 5 2))
+(test-values (values -2 -1) (truncate/ -5 2))
+(test-values (values -2 1) (truncate/ 5 -2))
+(test-values (values 2 -1) (truncate/ -5 -2))
+(test-values (values 2.0 -1.0) (truncate/ -5.0 -2))
 
 (test 1 (modulo 13 4))
 (test 1 (remainder 13 4))

From b834553c34f739daffa03dc616b3119995cd1f53 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 08:58:48 +0900
Subject: [PATCH 03/16] rewrite vector-copy in c

---
 piclib/prelude.scm | 25 ---------------------
 src/vector.c       | 56 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 56 insertions(+), 25 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 2f5f9dae..9c2b568f 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -700,31 +700,6 @@
 (define (vector . objs)
   (list->vector objs))
 
-(define (vector-copy! to at from . opts)
-  (let* ((start (if (pair? opts) (car opts) 0))
-         (end (if (>= (length opts) 2)
-                  (cadr opts)
-                  (vector-length from)))
-         (vs #f))
-    (if (eq? from to)
-        (begin
-          (set! vs (make-vector (- end start)))
-          (vector-copy! vs 0 from start end)
-          (vector-copy! to at vs))
-        (do ((i at (+ i 1))
-             (j start (+ j 1)))
-            ((= j end))
-          (vector-set! to i (vector-ref from j))))))
-
-(define (vector-copy v . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (vector-length v))))
-    (let ((res (make-vector (- end start))))
-      (vector-copy! res 0 v start end)
-      res)))
-
 (define (vector-append . vs)
   (define (vector-append-2-inv w v)
     (let ((res (make-vector (+ (vector-length v) (vector-length w)))))
diff --git a/src/vector.c b/src/vector.c
index 1315753f..af9264d1 100644
--- a/src/vector.c
+++ b/src/vector.c
@@ -119,6 +119,60 @@ pic_vec_vector_set(pic_state *pic)
   return pic_none_value();
 }
 
+static pic_value
+pic_vec_vector_copy_i(pic_state *pic)
+{
+  pic_vec *to, *from;
+  int n, at, start, end;
+
+  n = pic_get_args(pic, "viv|ii", &to, &at, &from, &start, &end);
+
+  switch (n) {
+  case 3:
+    start = 0;
+  case 4:
+    end = from->len;
+  }
+
+  if (to == from && (start <= at && at < end)) {
+    /* copy in reversed order */
+    at += end - start;
+    while (start < end) {
+      to->data[--at] = from->data[--end];
+    }
+    return pic_none_value();
+  }
+
+  while (start < end) {
+    to->data[at++] = from->data[start++];
+  }
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_vec_vector_copy(pic_state *pic)
+{
+  pic_vec *vec, *to;
+  int n, start, end, i = 0;
+
+  n = pic_get_args(pic, "v|ii", &vec, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = vec->len;
+  }
+
+  to = pic_vec_new(pic, end - start);
+  while (start < end) {
+    to->data[i++] = vec->data[start++];
+  }
+
+  return pic_obj_value(to);
+}
+
 static pic_value
 pic_vec_list_to_vector(pic_state *pic)
 {
@@ -169,6 +223,8 @@ pic_init_vector(pic_state *pic)
   pic_defun(pic, "vector-length", pic_vec_vector_length);
   pic_defun(pic, "vector-ref", pic_vec_vector_ref);
   pic_defun(pic, "vector-set!", pic_vec_vector_set);
+  pic_defun(pic, "vector-copy!", pic_vec_vector_copy_i);
+  pic_defun(pic, "vector-copy", pic_vec_vector_copy);
   pic_defun(pic, "list->vector", pic_vec_list_to_vector);
   pic_defun(pic, "vector->list", pic_vec_vector_to_list);
 }

From 3caf070043e2f990c56795a2b50a5118e62a5f13 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 09:07:09 +0900
Subject: [PATCH 04/16] rewrite floor/ and truncate/ in c

---
 piclib/prelude.scm |  8 --------
 src/number.c       | 43 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 43 insertions(+), 8 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 9c2b568f..6245f678 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -591,14 +591,6 @@
 
 ;;; 6.2. Numbers
 
-(define (floor/ n m)
-  (values (floor-quotient n m)
-	  (floor-remainder n m)))
-
-(define (truncate/ n m)
-  (values (truncate-quotient n m)
-	  (truncate-remainder n m)))
-
 ; (import (only (scheme inexact) sqrt))
 (import (scheme inexact))
 
diff --git a/src/number.c b/src/number.c
index be3eabce..b7b32aea 100644
--- a/src/number.c
+++ b/src/number.c
@@ -8,6 +8,7 @@
 
 #include "picrin.h"
 #include "picrin/string.h"
+#include "picrin/cont.h"
 
 static int
 gcd(int a, int b)
@@ -381,6 +382,26 @@ pic_number_floor_remainder(pic_state *pic)
   }
 }
 
+static pic_value
+pic_number_floor2(pic_state *pic)
+{
+  int i, j;
+  bool e1, e2;
+  double q, r;
+
+  pic_get_args(pic, "II", &i, &e1, &j, &e2);
+
+  q = floor((double)i/j);
+  r = i - j * q;
+
+  if (e1 && e2) {
+    return pic_values2(pic, pic_int_value(q), pic_int_value(r));
+  }
+  else {
+    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
+  }
+}
+
 static pic_value
 pic_number_trunc_quotient(pic_state *pic)
 {
@@ -414,6 +435,26 @@ pic_number_trunc_remainder(pic_state *pic)
   }
 }
 
+static pic_value
+pic_number_trunc2(pic_state *pic)
+{
+  int i, j;
+  bool e1, e2;
+  double q, r;
+
+  pic_get_args(pic, "II", &i, &e1, &j, &e2);
+
+  q = trunc((double)i/j);
+  r = i - j * q;
+
+  if (e1 && e2) {
+    return pic_values2(pic, pic_int_value(q), pic_int_value(r));
+  }
+  else {
+    return pic_values2(pic, pic_float_value(q), pic_float_value(r));
+  }
+}
+
 static pic_value
 pic_number_gcd(pic_state *pic)
 {
@@ -780,8 +821,10 @@ pic_init_number(pic_state *pic)
   pic_defun(pic, "abs", pic_number_abs);
   pic_defun(pic, "floor-quotient", pic_number_floor_quotient);
   pic_defun(pic, "floor-remainder", pic_number_floor_remainder);
+  pic_defun(pic, "floor/", pic_number_floor2);
   pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient);
   pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder);
+  pic_defun(pic, "truncate/", pic_number_trunc2);
   pic_defun(pic, "modulo", pic_number_floor_remainder);
   pic_defun(pic, "quotient", pic_number_trunc_quotient);
   pic_defun(pic, "remainder", pic_number_trunc_remainder);

From b1ae2c24e595f756d95f9163904bd7919e9f35d5 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 09:07:25 +0900
Subject: [PATCH 05/16] rewrite exact-integer-sqrt in c

---
 piclib/prelude.scm | 12 ------------
 src/number.c       | 14 ++++++++++++++
 2 files changed, 14 insertions(+), 12 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 6245f678..d7a191f5 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -589,18 +589,6 @@
       s
       (fold f (f (car xs) s) (cdr xs))))
 
-;;; 6.2. Numbers
-
-; (import (only (scheme inexact) sqrt))
-(import (scheme inexact))
-
-(define (exact-integer-sqrt k)
-  (let ((n (exact (floor (sqrt k)))))
-    (values n (- k (square n)))))
-
-(export floor/ truncate/
-        exact-integer-sqrt)
-
 ;;; 6.3 Booleans
 
 (define (boolean=? . objs)
diff --git a/src/number.c b/src/number.c
index b7b32aea..8e15860a 100644
--- a/src/number.c
+++ b/src/number.c
@@ -661,6 +661,19 @@ pic_number_atan(pic_state *pic)
   }
 }
 
+static pic_value
+pic_number_exact_integer_sqrt(pic_state *pic)
+{
+  int k, n, m;
+
+  pic_get_args(pic, "i", &k);
+
+  n = sqrt(k);
+  m = k - n * n;
+
+  return pic_values2(pic, pic_int_value(n), pic_int_value(m));
+}
+
 static pic_value
 pic_number_square(pic_state *pic)
 {
@@ -840,6 +853,7 @@ pic_init_number(pic_state *pic)
   pic_defun(pic, "round", pic_number_round);
   pic_gc_arena_restore(pic, ai);
 
+  pic_defun(pic, "exact-integer-sqrt", pic_number_exact_integer_sqrt);
   pic_defun(pic, "square", pic_number_square);
   pic_defun(pic, "expt", pic_number_expt);
   pic_gc_arena_restore(pic, ai);

From 0d59eee27bcc62c3c47aaa8a0ea6e5a4dad289d9 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 09:13:42 +0900
Subject: [PATCH 06/16] =?UTF-8?q?rewrite=20boolean=3D=3F=20in=20c?=

---
 piclib/prelude.scm |  8 --------
 src/bool.c         | 20 ++++++++++++++++++++
 2 files changed, 20 insertions(+), 8 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index d7a191f5..2a9993cc 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -589,14 +589,6 @@
       s
       (fold f (f (car xs) s) (cdr xs))))
 
-;;; 6.3 Booleans
-
-(define (boolean=? . objs)
-  (or (every (lambda (x) (eq? x #t)) objs)
-      (every (lambda (x) (eq? x #f)) objs)))
-
-(export boolean=?)
-
 ;;; 6.4 Pairs and lists
 
 (define (member obj list . opts)
diff --git a/src/bool.c b/src/bool.c
index a985c625..74018c63 100644
--- a/src/bool.c
+++ b/src/bool.c
@@ -169,6 +169,25 @@ pic_bool_boolean_p(pic_state *pic)
   return (pic_true_p(v) || pic_false_p(v)) ? pic_true_value() : pic_false_value();
 }
 
+static pic_value
+pic_bool_boolean_eq_p(pic_state *pic)
+{
+  size_t argc, i;
+  pic_value *argv;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  for (i = 0; i < argc; ++i) {
+    if (! (pic_true_p(argv[i]) || pic_false_p(argv[i]))) {
+      return pic_false_value();
+    }
+    if (! pic_eq_p(argv[i], argv[0])) {
+      return pic_false_value();
+    }
+  }
+  return pic_true_value();
+}
+
 void
 pic_init_bool(pic_state *pic)
 {
@@ -178,4 +197,5 @@ pic_init_bool(pic_state *pic)
 
   pic_defun(pic, "not", pic_bool_not);
   pic_defun(pic, "boolean?", pic_bool_boolean_p);
+  pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);
 }

From 4e895c97d01e4ff98fe68f752c177f71dd1a31bc Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 09:15:16 +0900
Subject: [PATCH 07/16] =?UTF-8?q?rewrite=20symbol=3D=3F=20in=20c?=

---
 piclib/prelude.scm | 13 -------------
 src/symbol.c       | 20 ++++++++++++++++++++
 2 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 2a9993cc..114bcffa 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -609,19 +609,6 @@
 
 (export member assoc)
 
-;;; 6.5. Symbols
-
-(define (symbol=? . objs)
-  (let ((sym (car objs)))
-    (if (symbol? sym)
-	(every (lambda (x)
-		 (and (symbol? x)
-		      (eq? x sym)))
-	       (cdr objs))
-	#f)))
-
-(export symbol=?)
-
 ;;; 6.6 Characters
 
 (define-macro (define-char-transitive-predicate name op)
diff --git a/src/symbol.c b/src/symbol.c
index 863e41f3..1ebbdc3d 100644
--- a/src/symbol.c
+++ b/src/symbol.c
@@ -77,6 +77,25 @@ pic_symbol_symbol_p(pic_state *pic)
   return pic_bool_value(pic_sym_p(v));
 }
 
+static pic_value
+pic_symbol_symbol_eq_p(pic_state *pic)
+{
+  size_t argc, i;
+  pic_value *argv;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  for (i = 0; i < argc; ++i) {
+    if (! pic_sym_p(argv[i])) {
+      return pic_false_value();
+    }
+    if (! pic_eq_p(argv[i], argv[0])) {
+      return pic_false_value();
+    }
+  }
+  return pic_true_value();
+}
+
 static pic_value
 pic_symbol_symbol_to_string(pic_state *pic)
 {
@@ -109,6 +128,7 @@ void
 pic_init_symbol(pic_state *pic)
 {
   pic_defun(pic, "symbol?", pic_symbol_symbol_p);
+  pic_defun(pic, "symbol=?", pic_symbol_symbol_eq_p);
   pic_defun(pic, "symbol->string", pic_symbol_symbol_to_string);
   pic_defun(pic, "string->symbol", pic_symbol_string_to_symbol);
 }

From 09bb977c508333206b0ad6b2f5ef7b79b399c1c2 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 09:24:30 +0900
Subject: [PATCH 08/16] rewrite vector-fill! in c

---
 piclib/prelude.scm | 10 ----------
 src/vector.c       | 24 ++++++++++++++++++++++++
 2 files changed, 24 insertions(+), 10 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 114bcffa..af357cdb 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -667,16 +667,6 @@
       res))
   (fold vector-append-2-inv #() vs))
 
-(define (vector-fill! v fill . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (vector-length v))))
-    (do ((i start (+ i 1)))
-	((= i end)
-	 #f)
-      (vector-set! v i fill))))
-
 (define (vector->string . args)
   (list->string (apply vector->list args)))
 
diff --git a/src/vector.c b/src/vector.c
index af9264d1..8fe9392c 100644
--- a/src/vector.c
+++ b/src/vector.c
@@ -173,6 +173,29 @@ pic_vec_vector_copy(pic_state *pic)
   return pic_obj_value(to);
 }
 
+static pic_value
+pic_vec_vector_fill_i(pic_state *pic)
+{
+  pic_vec *vec;
+  pic_value obj;
+  int n, start, end;
+
+  n = pic_get_args(pic, "vo|ii", &vec, &obj, &start, &end);
+
+  switch (n) {
+  case 2:
+    start = 0;
+  case 3:
+    end = vec->len;
+  }
+
+  while (start < end) {
+    vec->data[start++] = obj;
+  }
+
+  return pic_none_value();
+}
+
 static pic_value
 pic_vec_list_to_vector(pic_state *pic)
 {
@@ -225,6 +248,7 @@ pic_init_vector(pic_state *pic)
   pic_defun(pic, "vector-set!", pic_vec_vector_set);
   pic_defun(pic, "vector-copy!", pic_vec_vector_copy_i);
   pic_defun(pic, "vector-copy", pic_vec_vector_copy);
+  pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i);
   pic_defun(pic, "list->vector", pic_vec_list_to_vector);
   pic_defun(pic, "vector->list", pic_vec_vector_to_list);
 }

From 3f6ec5f8786c7d267fefbf5bb2b3b8e9a0756360 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 13:19:25 +0900
Subject: [PATCH 09/16] implement assoc and member in c

---
 include/picrin/pair.h |  3 ++-
 piclib/prelude.scm    | 20 ----------------
 src/lib.c             |  2 +-
 src/pair.c            | 55 ++++++++++++++++++++++++++++++++++++++++---
 4 files changed, 55 insertions(+), 25 deletions(-)

diff --git a/include/picrin/pair.h b/include/picrin/pair.h
index c7319e25..49de01cc 100644
--- a/include/picrin/pair.h
+++ b/include/picrin/pair.h
@@ -51,10 +51,11 @@ pic_value pic_append(pic_state *, pic_value, pic_value);
 
 pic_value pic_memq(pic_state *, pic_value key, pic_value list);
 pic_value pic_memv(pic_state *, pic_value key, pic_value list);
+pic_value pic_member(pic_state *, pic_value key, pic_value list, struct pic_proc * /* = NULL */);
 
 pic_value pic_assq(pic_state *, pic_value key, pic_value assoc);
 pic_value pic_assv(pic_state *, pic_value key, pic_value assoc);
-pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc);
+pic_value pic_assoc(pic_state *, pic_value key, pic_value assoc, struct pic_proc * /* = NULL */);
 
 pic_value pic_acons(pic_state *, pic_value key, pic_value val, pic_value assoc);
 
diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index af357cdb..6145b9dd 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -589,26 +589,6 @@
       s
       (fold f (f (car xs) s) (cdr xs))))
 
-;;; 6.4 Pairs and lists
-
-(define (member obj list . opts)
-  (let ((compare (if (null? opts) equal? (car opts))))
-    (if (null? list)
-	#f
-	(if (compare obj (car list))
-	    list
-	    (member obj (cdr list) compare)))))
-
-(define (assoc obj list . opts)
-  (let ((compare (if (null? opts) equal? (car opts))))
-    (if (null? list)
-	#f
-	(if (compare obj (caar list))
-	    (car list)
-	    (assoc obj (cdr list) compare)))))
-
-(export member assoc)
-
 ;;; 6.6 Characters
 
 (define-macro (define-char-transitive-predicate name op)
diff --git a/src/lib.c b/src/lib.c
index 5ac5336a..7a197c87 100644
--- a/src/lib.c
+++ b/src/lib.c
@@ -54,7 +54,7 @@ pic_find_library(pic_state *pic, pic_value spec)
 {
   pic_value v;
 
-  v = pic_assoc(pic, spec, pic->lib_tbl);
+  v = pic_assoc(pic, spec, pic->lib_tbl, NULL);
   if (pic_false_p(v)) {
     return NULL;
   }
diff --git a/src/pair.c b/src/pair.c
index 2c80f363..f2960adb 100644
--- a/src/pair.c
+++ b/src/pair.c
@@ -291,6 +291,26 @@ pic_memv(pic_state *pic, pic_value key, pic_value list)
   goto enter;
 }
 
+pic_value
+pic_member(pic_state *pic, pic_value key, pic_value list, struct pic_proc *compar)
+{
+ enter:
+
+  if (pic_nil_p(list))
+    return pic_false_value();
+
+  if (compar == NULL) {
+    if (pic_equal_p(pic, key, pic_car(pic, list)))
+      return list;
+  } else {
+    if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, list))))
+      return list;
+  }
+
+  list = pic_cdr(pic, list);
+  goto enter;
+}
+
 pic_value
 pic_assq(pic_state *pic, pic_value key, pic_value assoc)
 {
@@ -328,7 +348,7 @@ pic_assv(pic_state *pic, pic_value key, pic_value assoc)
 }
 
 pic_value
-pic_assoc(pic_state *pic, pic_value key, pic_value assoc)
+pic_assoc(pic_state *pic, pic_value key, pic_value assoc, struct pic_proc *compar)
 {
   pic_value cell;
 
@@ -338,8 +358,13 @@ pic_assoc(pic_state *pic, pic_value key, pic_value assoc)
     return pic_false_value();
 
   cell = pic_car(pic, assoc);
-  if (pic_equal_p(pic, key, pic_car(pic, cell)))
-    return cell;
+  if (compar == NULL) {
+    if (pic_equal_p(pic, key, pic_car(pic, cell)))
+      return cell;
+  } else {
+    if (pic_test(pic_apply2(pic, compar, key, pic_car(pic, cell))))
+      return cell;
+  }
 
   assoc = pic_cdr(pic, assoc);
   goto enter;
@@ -662,6 +687,17 @@ pic_pair_memv(pic_state *pic)
   return pic_memv(pic, key, list);
 }
 
+static pic_value
+pic_pair_member(pic_state *pic)
+{
+  struct pic_proc *proc = NULL;
+  pic_value key, list;
+
+  pic_get_args(pic, "oo|l", &key, &list, &proc);
+
+  return pic_member(pic, key, list, proc);
+}
+
 static pic_value
 pic_pair_assq(pic_state *pic)
 {
@@ -682,6 +718,17 @@ pic_pair_assv(pic_state *pic)
   return pic_assv(pic, key, list);
 }
 
+static pic_value
+pic_pair_assoc(pic_state *pic)
+{
+  struct pic_proc *proc = NULL;
+  pic_value key, list;
+
+  pic_get_args(pic, "oo|l", &key, &list, &proc);
+
+  return pic_assoc(pic, key, list, proc);
+}
+
 void
 pic_init_pair(pic_state *pic)
 {
@@ -708,6 +755,8 @@ pic_init_pair(pic_state *pic)
   pic_defun(pic, "list-copy", pic_pair_list_copy);
   pic_defun(pic, "memq", pic_pair_memq);
   pic_defun(pic, "memv", pic_pair_memv);
+  pic_defun(pic, "member", pic_pair_member);
   pic_defun(pic, "assq", pic_pair_assq);
   pic_defun(pic, "assv", pic_pair_assv);
+  pic_defun(pic, "assoc", pic_pair_assoc);
 }

From 18b07fc8530401386381e6da60ebdd5bb2fee0b3 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 13:55:21 +0900
Subject: [PATCH 10/16] change blob API

---
 include/picrin/blob.h |  2 +-
 src/blob.c            | 12 ++++++------
 src/port.c            | 28 ++++++++++++++++------------
 src/read.c            |  8 ++++++--
 4 files changed, 29 insertions(+), 21 deletions(-)

diff --git a/include/picrin/blob.h b/include/picrin/blob.h
index 6b52d9e3..f61f588d 100644
--- a/include/picrin/blob.h
+++ b/include/picrin/blob.h
@@ -18,7 +18,7 @@ struct pic_blob {
 #define pic_blob_p(v) (pic_type(v) == PIC_TT_BLOB)
 #define pic_blob_ptr(v) ((struct pic_blob *)pic_ptr(v))
 
-struct pic_blob *pic_blob_new(pic_state *, char *, size_t len);
+struct pic_blob *pic_blob_new(pic_state *, size_t);
 
 #if defined(__cplusplus)
 }
diff --git a/src/blob.c b/src/blob.c
index 384858aa..efb33ff2 100644
--- a/src/blob.c
+++ b/src/blob.c
@@ -25,12 +25,12 @@ pic_strdup(pic_state *pic, const char *s)
 }
 
 struct pic_blob *
-pic_blob_new(pic_state *pic, char *dat, size_t len)
+pic_blob_new(pic_state *pic, size_t len)
 {
   struct pic_blob *bv;
 
   bv = (struct pic_blob *)pic_obj_alloc(pic, sizeof(struct pic_blob), PIC_TT_BLOB);
-  bv->data = pic_strndup(pic, dat, len);
+  bv->data = pic_alloc(pic, len);
   bv->len = len;
   return bv;
 }
@@ -48,20 +48,20 @@ pic_blob_bytevector_p(pic_state *pic)
 static pic_value
 pic_blob_make_bytevector(pic_state *pic)
 {
+  pic_blob *blob;
   int k, b = 0, i;
-  char *dat;
 
   pic_get_args(pic, "i|i", &k, &b);
 
   if (b < 0 || b > 255)
     pic_error(pic, "byte out of range");
 
-  dat = pic_alloc(pic, k);
+  blob = pic_blob_new(pic, k);
   for (i = 0; i < k; ++i) {
-    dat[i] = b;
+    blob->data[i] = b;
   }
 
-  return pic_obj_value(pic_blob_new(pic, dat, k));
+  return pic_obj_value(blob);
 }
 
 static pic_value
diff --git a/src/port.c b/src/port.c
index 8a3534bc..6f9b6673 100644
--- a/src/port.c
+++ b/src/port.c
@@ -354,8 +354,8 @@ static pic_value
 pic_port_get_output_bytevector(pic_state *pic)
 {
   struct pic_port *port = pic_stdout(pic);
+  pic_blob *blob;
   long endpos;
-  char *buf;
 
   pic_get_args(pic, "|p", &port);
 
@@ -367,10 +367,10 @@ pic_port_get_output_bytevector(pic_state *pic)
   xrewind(port->file);
 
   /* copy to buf */
-  buf = (char *)pic_alloc(pic, endpos);
-  xfread(buf, 1, endpos, port->file);
+  blob = pic_blob_new(pic, endpos);
+  xfread(blob->data, 1, endpos, port->file);
 
-  return pic_obj_value(pic_blob_new(pic, buf, endpos));
+  return pic_obj_value(blob);
 }
 
 static pic_value
@@ -524,28 +524,32 @@ pic_port_byte_ready_p(pic_state *pic)
 
 
 static pic_value
-pic_port_read_blob(pic_state *pic){
+pic_port_read_blob(pic_state *pic)
+{
   struct pic_port *port = pic_stdin(pic);
+  pic_blob *blob;
   int k, i;
-  char *buf;
 
   pic_get_args(pic, "i|p", &k,  &port);
 
   assert_port_profile(port, PIC_PORT_IN | PIC_PORT_BINARY, PIC_PORT_OPEN, "read-bytevector");
 
-  buf = pic_calloc(pic, k, sizeof(char));
-  i = xfread(buf, sizeof(char), k, port->file);
+  blob = pic_blob_new(pic, k);
+
+  i = xfread(blob->data, sizeof(char), k, port->file);
   if ( i == 0 ) {
     return pic_eof_object();
   }
   else {
-    pic_realloc(pic, buf, i);
-    return pic_obj_value(pic_blob_new(pic, buf, i));
+    pic_realloc(pic, blob->data, i);
+    blob->len = i;
+    return pic_obj_value(blob);
   }
 }
 
 static pic_value
-pic_port_read_blob_ip(pic_state *pic){
+pic_port_read_blob_ip(pic_state *pic)
+{
   struct pic_port *port;
   struct pic_blob *bv;
   int i, n, start, end, len;
@@ -568,7 +572,7 @@ pic_port_read_blob_ip(pic_state *pic){
   i = xfread(buf, sizeof(char), len, port->file);
   memcpy(bv->data + start, buf, i);
   pic_free(pic, buf);
-  
+
   if ( i == 0) {
     return pic_eof_object();
   }
diff --git a/src/read.c b/src/read.c
index 62467ece..d7726471 100644
--- a/src/read.c
+++ b/src/read.c
@@ -438,7 +438,7 @@ static pic_value
 read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
 {
   int nbits, n;
-  size_t len;
+  size_t len, i;
   char *dat, buf[256];
   pic_blob *blob;
 
@@ -471,7 +471,11 @@ read_unsigned_blob(pic_state *pic, struct pic_port *port, char c)
     c = next(port);
   }
 
-  blob = pic_blob_new(pic, dat, len);
+  blob = pic_blob_new(pic, len);
+  for (i = 0; i < len; ++i) {
+    blob->data[i] = dat[i];
+  }
+
   pic_free(pic, dat);
   return pic_obj_value(blob);
 }

From 5244b2f45dbe1973f8b1b04ff28248377c020ed8 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 13:55:35 +0900
Subject: [PATCH 11/16] rewrite bytevector-copy in c

---
 piclib/prelude.scm | 29 ++----------------------
 src/blob.c         | 56 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 58 insertions(+), 27 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 6145b9dd..e2aa17d5 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -668,31 +668,6 @@
 	   v)
 	(bytevector-u8-set! v i (car l))))))
 
-(define (bytevector-copy! to at from . opts)
-  (let* ((start (if (pair? opts) (car opts) 0))
-         (end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (bytevector-length from)))
-         (vs #f))
-    (if (eq? from to)
-        (begin
-          (set! vs (make-bytevector (- end start)))
-          (bytevector-copy! vs 0 from start end)
-          (bytevector-copy! to at vs))
-        (do ((i at (+ i 1))
-             (j start (+ j 1)))
-            ((= j end))
-          (bytevector-u8-set! to i (bytevector-u8-ref from j))))))
-
-(define (bytevector-copy v . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (bytevector-length v))))
-    (let ((res (make-bytevector (- end start))))
-      (bytevector-copy! res 0 v start end)
-      res)))
-
 (define (bytevector-append . vs)
   (define (bytevector-append-2-inv w v)
     (let ((res (make-bytevector (+ (bytevector-length v) (bytevector-length w)))))
@@ -726,8 +701,8 @@
     (list->bytevector (map char->integer (string->list s start end)))))
 
 (export bytevector
-        bytevector-copy!
-        bytevector-copy
+        bytevector->list
+        list->bytevector
         bytevector-append
         utf8->string
         string->utf8)
diff --git a/src/blob.c b/src/blob.c
index efb33ff2..8355e69b 100644
--- a/src/blob.c
+++ b/src/blob.c
@@ -100,6 +100,60 @@ pic_blob_bytevector_u8_set(pic_state *pic)
   return pic_none_value();
 }
 
+static pic_value
+pic_blob_bytevector_copy_i(pic_state *pic)
+{
+  pic_blob *to, *from;
+  int n, at, start, end;
+
+  n = pic_get_args(pic, "bib|ii", &to, &at, &from, &start, &end);
+
+  switch (n) {
+  case 3:
+    start = 0;
+  case 4:
+    end = from->len;
+  }
+
+  if (to == from && (start <= at && at < end)) {
+    /* copy in reversed order */
+    at += end - start;
+    while (start < end) {
+      to->data[--at] = from->data[--end];
+    }
+    return pic_none_value();
+  }
+
+  while (start < end) {
+    to->data[at++] = from->data[start++];
+  }
+
+  return pic_none_value();
+}
+
+static pic_value
+pic_blob_bytevector_copy(pic_state *pic)
+{
+  pic_blob *from, *to;
+  int n, start, end, i = 0;
+
+  n = pic_get_args(pic, "b|ii", &from, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = from->len;
+  }
+
+  to = pic_blob_new(pic, end - start);
+  while (start < end) {
+    to->data[i++] = from->data[start++];
+  }
+
+  return pic_obj_value(to);
+}
+
 void
 pic_init_blob(pic_state *pic)
 {
@@ -108,4 +162,6 @@ pic_init_blob(pic_state *pic)
   pic_defun(pic, "bytevector-length", pic_blob_bytevector_length);
   pic_defun(pic, "bytevector-u8-ref", pic_blob_bytevector_u8_ref);
   pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set);
+  pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i);
+  pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy);
 }

From 4676550961c10b5aec8761c52154c88153bbd4be Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 14:08:48 +0900
Subject: [PATCH 12/16] rewrite vector-append in c

---
 piclib/prelude.scm | 12 +-----------
 src/vector.c       | 29 +++++++++++++++++++++++++++++
 2 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index e2aa17d5..71e5a11a 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -639,23 +639,13 @@
 (define (vector . objs)
   (list->vector objs))
 
-(define (vector-append . vs)
-  (define (vector-append-2-inv w v)
-    (let ((res (make-vector (+ (vector-length v) (vector-length w)))))
-      (vector-copy! res 0 v)
-      (vector-copy! res (vector-length v) w)
-      res))
-  (fold vector-append-2-inv #() vs))
-
 (define (vector->string . args)
   (list->string (apply vector->list args)))
 
 (define (string->vector . args)
   (list->vector (apply string->list args)))
 
-(export vector vector-copy! vector-copy
-        vector-append vector-fill!
-        vector->string string->vector)
+(export vector vector->string string->vector)
 
 ;;; 6.9 bytevector
 
diff --git a/src/vector.c b/src/vector.c
index 8fe9392c..d57214e7 100644
--- a/src/vector.c
+++ b/src/vector.c
@@ -173,6 +173,34 @@ pic_vec_vector_copy(pic_state *pic)
   return pic_obj_value(to);
 }
 
+static pic_value
+pic_vec_vector_append(pic_state *pic)
+{
+  size_t argc, i, j, len;
+  pic_value *argv;
+  pic_vec *vec;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  len = 0;
+  for (i = 0; i < argc; ++i) {
+    pic_assert_type(pic, argv[i], vec);
+    len += pic_vec_ptr(argv[i])->len;
+  }
+
+  vec = pic_vec_new(pic, len);
+
+  len = 0;
+  for (i = 0; i < argc; ++i) {
+    for (j = 0; j < pic_vec_ptr(argv[i])->len; ++j) {
+      vec->data[len + j] = pic_vec_ptr(argv[i])->data[j];
+    }
+    len += pic_vec_ptr(argv[i])->len;
+  }
+
+  return pic_obj_value(vec);
+}
+
 static pic_value
 pic_vec_vector_fill_i(pic_state *pic)
 {
@@ -248,6 +276,7 @@ pic_init_vector(pic_state *pic)
   pic_defun(pic, "vector-set!", pic_vec_vector_set);
   pic_defun(pic, "vector-copy!", pic_vec_vector_copy_i);
   pic_defun(pic, "vector-copy", pic_vec_vector_copy);
+  pic_defun(pic, "vector-append", pic_vec_vector_append);
   pic_defun(pic, "vector-fill!", pic_vec_vector_fill_i);
   pic_defun(pic, "list->vector", pic_vec_list_to_vector);
   pic_defun(pic, "vector->list", pic_vec_vector_to_list);

From cba4a6ebf5c4887d8312d684f9727deac6f324ca Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 14:08:54 +0900
Subject: [PATCH 13/16] remvoe unused helper function

---
 piclib/prelude.scm | 7 -------
 1 file changed, 7 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 71e5a11a..e8c251bd 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -577,13 +577,6 @@
 
 (export define-record-type)
 
-(define (every pred list)
-  (if (null? list)
-      #t
-      (if (pred (car list))
-	  (every pred (cdr list))
-	  #f)))
-
 (define (fold f s xs)
   (if (null? xs)
       s

From bdd15261b128c12f4165f7e1d257b00ba3a0a2ab Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 14:14:58 +0900
Subject: [PATCH 14/16] rewrite bytevector-append in c

---
 piclib/prelude.scm |  9 ---------
 src/blob.c         | 29 +++++++++++++++++++++++++++++
 2 files changed, 29 insertions(+), 9 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index e8c251bd..9b8a390a 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -651,14 +651,6 @@
 	   v)
 	(bytevector-u8-set! v i (car l))))))
 
-(define (bytevector-append . vs)
-  (define (bytevector-append-2-inv w v)
-    (let ((res (make-bytevector (+ (bytevector-length v) (bytevector-length w)))))
-      (bytevector-copy! res 0 v)
-      (bytevector-copy! res (bytevector-length v) w)
-      res))
-  (fold bytevector-append-2-inv #u8() vs))
-
 (define (bytevector->list v start end)
     (do ((i start (+ i 1))
 	 (res '()))
@@ -686,7 +678,6 @@
 (export bytevector
         bytevector->list
         list->bytevector
-        bytevector-append
         utf8->string
         string->utf8)
 
diff --git a/src/blob.c b/src/blob.c
index 8355e69b..0bb28713 100644
--- a/src/blob.c
+++ b/src/blob.c
@@ -154,6 +154,34 @@ pic_blob_bytevector_copy(pic_state *pic)
   return pic_obj_value(to);
 }
 
+static pic_value
+pic_blob_bytevector_append(pic_state *pic)
+{
+  size_t argc, i, j, len;
+  pic_value *argv;
+  pic_blob *blob;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  len = 0;
+  for (i = 0; i < argc; ++i) {
+    pic_assert_type(pic, argv[i], blob);
+    len += pic_blob_ptr(argv[i])->len;
+  }
+
+  blob = pic_blob_new(pic, len);
+
+  len = 0;
+  for (i = 0; i < argc; ++i) {
+    for (j = 0; j < pic_blob_ptr(argv[i])->len; ++j) {
+      blob->data[len + j] = pic_blob_ptr(argv[i])->data[j];
+    }
+    len += pic_blob_ptr(argv[i])->len;
+  }
+
+  return pic_obj_value(blob);
+}
+
 void
 pic_init_blob(pic_state *pic)
 {
@@ -164,4 +192,5 @@ pic_init_blob(pic_state *pic)
   pic_defun(pic, "bytevector-u8-set!", pic_blob_bytevector_u8_set);
   pic_defun(pic, "bytevector-copy!", pic_blob_bytevector_copy_i);
   pic_defun(pic, "bytevector-copy", pic_blob_bytevector_copy);
+  pic_defun(pic, "bytevector-append", pic_blob_bytevector_append);
 }

From b17a2002f30ac61ab575b19f4ea2a5d4fc471f5a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 14:28:30 +0900
Subject: [PATCH 15/16] refactor dynamic-wind

---
 piclib/prelude.scm |  9 +-------
 src/cont.c         | 56 ++++++++++++++++++++++++++--------------------
 2 files changed, 33 insertions(+), 32 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 9b8a390a..7367d593 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -299,13 +299,6 @@
      (lambda (form r c)
        `(,(r 'let*-values) ,@(cdr form)))))
 
-  (define (vector-map proc vect)
-    (do ((i 0 (+ i 1))
-         (u (make-vector (vector-length vect))))
-        ((= i (vector-length vect))
-         u)
-      (vector-set! u i (proc (vector-ref vect i)))))
-
   (define (walk proc expr)
     (cond
      ((null? expr)
@@ -314,7 +307,7 @@
       (cons (proc (car expr))
             (walk proc (cdr expr))))
      ((vector? expr)
-      (vector-map proc expr))
+      (list->vector (map proc (vector->list expr))))
      (else
       (proc expr))))
 
diff --git a/src/cont.c b/src/cont.c
index de076874..11b5a3f6 100644
--- a/src/cont.c
+++ b/src/cont.c
@@ -210,6 +210,37 @@ walk_to_block(pic_state *pic, pic_block *here, pic_block *there)
   }
 }
 
+static pic_value
+pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, struct pic_proc *out)
+{
+  pic_block *here;
+  pic_value val;
+
+  if (in != NULL) {
+    pic_apply0(pic, in);        /* enter */
+  }
+
+  here = pic->blk;
+  pic->blk = (pic_block *)pic_alloc(pic, sizeof(pic_block));
+  pic->blk->prev = here;
+  pic->blk->depth = here->depth + 1;
+  pic->blk->in = in;
+  pic->blk->out = out;
+  pic->blk->refcnt = 1;
+  PIC_BLK_INCREF(pic, here);
+
+  val = pic_apply0(pic, thunk);
+
+  PIC_BLK_DECREF(pic, pic->blk);
+  pic->blk = here;
+
+  if (out != NULL) {
+    pic_apply0(pic, out);       /* exit */
+  }
+
+  return val;
+}
+
 noreturn static pic_value
 cont_call(pic_state *pic)
 {
@@ -286,33 +317,10 @@ static pic_value
 pic_cont_dynamic_wind(pic_state *pic)
 {
   struct pic_proc *in, *thunk, *out;
-  pic_value v;
 
   pic_get_args(pic, "lll", &in, &thunk, &out);
 
-  /* enter */
-  pic_apply0(pic, in);
-  {
-    pic_block *here;
-
-    here = pic->blk;
-    pic->blk = (pic_block *)pic_alloc(pic, sizeof(pic_block));
-    pic->blk->prev = here;
-    pic->blk->depth = here->depth + 1;
-    pic->blk->in = in;
-    pic->blk->out = out;
-    pic->blk->refcnt = 1;
-    PIC_BLK_INCREF(pic, here);
-
-    v = pic_apply0(pic, thunk);
-
-    PIC_BLK_DECREF(pic, pic->blk);
-    pic->blk = here;
-  }
-  /* exit */
-  pic_apply0(pic, out);
-
-  return v;
+  return pic_dynamic_wind(pic, in, thunk, out);
 }
 
 static pic_value

From 4d108ac2995b88eb386b4cfa48f9a5022a756859 Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 22 Jul 2014 14:34:39 +0900
Subject: [PATCH 16/16] move include syntax to core-syntax library

---
 piclib/prelude.scm | 45 +++++++++++++++++++++++----------------------
 1 file changed, 23 insertions(+), 22 deletions(-)

diff --git a/piclib/prelude.scm b/piclib/prelude.scm
index 7367d593..d31363a2 100644
--- a/piclib/prelude.scm
+++ b/piclib/prelude.scm
@@ -260,12 +260,34 @@
      (lambda (form r c)
        `(,(r 'letrec-syntax) ,@(cdr form)))))
 
+  (import (scheme read) (scheme file))
+
+  (define-syntax include
+    (letrec ((read-file
+              (lambda (filename)
+                (let ((port (open-input-file filename)))
+                  (dynamic-wind
+                      (lambda () #f)
+                      (lambda ()
+                        (let loop ((expr (read port)) (exprs '()))
+                          (if (eof-object? expr)
+                              (reverse exprs)
+                              (loop (read port) (cons expr exprs)))))
+                      (lambda ()
+                        (close-port port)))))))
+      (er-macro-transformer
+       (lambda (form rename compare)
+         (let ((filenames (cdr form)))
+           (let ((exprs (apply append (map read-file filenames))))
+             `(,(rename 'begin) ,@exprs)))))))
+
   (export let let* letrec letrec*
           quasiquote unquote unquote-splicing
           and or
           cond case else =>
           do when unless
           let-syntax letrec-syntax
+          include
           _ ... syntax-error))
 
 (import (picrin core-syntax))
@@ -276,6 +298,7 @@
         cond case else =>
         do when unless
         let-syntax letrec-syntax
+        include
         _ ... syntax-error)
 
 ;;; multiple value
@@ -737,28 +760,6 @@
 
 (export call-with-port)
 
-;;; include syntax
-
-(import (scheme read)
-        (scheme file))
-
-(define (read-many filename)
-  (call-with-port (open-input-file filename)
-    (lambda (port)
-      (let loop ((expr (read port)) (exprs '()))
-        (if (eof-object? expr)
-            (reverse exprs)
-            (loop (read port) (cons expr exprs)))))))
-
-(define-syntax include
-  (er-macro-transformer
-   (lambda (form rename compare)
-     (let ((filenames (cdr form)))
-       (let ((exprs (apply append (map read-many filenames))))
-         `(,(rename 'begin) ,@exprs))))))
-
-(export include)
-
 ;;; syntax-rules
 (define-library (picrin syntax-rules)
   (import (scheme base)