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 1/7] 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 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 2/7] 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 3/7] 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 4/7] 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 5/7] =?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 6/7] =?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 7/7] 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);
 }