Merge branch 'list-vector-in-c'

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)

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)
@@ -605,34 +589,6 @@
       s
       (fold f (f (car xs) s) (cdr xs))))
 
-;;; 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))
-
-(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)
-  (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)
@@ -653,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)
@@ -714,52 +657,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))
-
-(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)))
+  (list->vector objs))
 
 (define (vector-append . vs)
   (define (vector-append-2-inv w v)
@@ -769,24 +667,13 @@
       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)))
 
 (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)
 

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);
 }

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)
 {
@@ -620,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)
 {
@@ -780,8 +834,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);
@@ -797,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);

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);
 }

src/vector.c

@@ -119,6 +119,125 @@ 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_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)
+{
+  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 +246,9 @@ 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, "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);
 }