Identify scm_is_vector with scm_is_simple_vector

This patch fixes the bug (vector-ref #1@1(1 2 3) 1) => 2.

* libguile/vectors.c: (scm_is_vector): just as scm_is_simple_vector.
* libguile/filesys.c, libguile/random.c, libguile/stime.c, libguile/trees.c,
  libguile/validate.h: use scm_is_vector instead of scm_is_simple_vector.
* libguile/sort.c
  - scm_restricted_vector_sort_x: use scm_array_handle_writable_elements
    instead of scm_vector_writable_elements, to work with non-vector
    rank-1 array objects.
  - scm_sort_x: check for scm_is_array instead of scm_is_vector. Rank
    check is in restricted_vector_sort_x.
  - scm_sort: ditto.
  - scm_stable_sort_x: like scm_restricted_vector_sort_x.
  - scm_stable_sort: like scm_sort.
* test-suite/tests/arrays.test: fix header.
* test-suite/tests/random.test: new coverage test covering
  random:normal-vector!
* test-suite/Makefile.am: include random.test in make check.

libguile/filesys.c

@@ -694,7 +694,7 @@ fill_select_type (fd_set *set, SCM *ports_ready, SCM list_or_vec, int pos)
 {
   int max_fd = 0;
 
-  if (scm_is_simple_vector (list_or_vec))
+  if (scm_is_vector (list_or_vec))
     {
       int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
       
@@ -755,7 +755,7 @@ retrieve_select_type (fd_set *set, SCM ports_ready, SCM list_or_vec)
 {
   SCM answer_list = ports_ready;
 
-  if (scm_is_simple_vector (list_or_vec))
+  if (scm_is_vector (list_or_vec))
     {
       int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
 
@@ -824,7 +824,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
   SCM write_ports_ready = SCM_EOL;
   int max_fd;
 
-  if (scm_is_simple_vector (reads))
+  if (scm_is_vector (reads))
     {
       read_count = SCM_SIMPLE_VECTOR_LENGTH (reads);
     }
@@ -833,7 +833,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
       read_count = scm_ilength (reads);
       SCM_ASSERT (read_count >= 0, reads, SCM_ARG1, FUNC_NAME);
     }
-  if (scm_is_simple_vector (writes))
+  if (scm_is_vector (writes))
     {
       write_count = SCM_SIMPLE_VECTOR_LENGTH (writes);
     }
@@ -842,7 +842,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0,
       write_count = scm_ilength (writes);
       SCM_ASSERT (write_count >= 0, writes, SCM_ARG2, FUNC_NAME);
     }
-  if (scm_is_simple_vector (excepts))
+  if (scm_is_vector (excepts))
     {
       except_count = SCM_SIMPLE_VECTOR_LENGTH (excepts);
     }

libguile/random.c

@@ -504,7 +504,7 @@ static void
 vector_scale_x (SCM v, double c)
 {
   size_t n;
-  if (scm_is_simple_vector (v))
+  if (scm_is_vector (v))
     {
       n = SCM_SIMPLE_VECTOR_LENGTH (v);
       while (n-- > 0)
@@ -532,7 +532,7 @@ vector_sum_squares (SCM v)
 {
   double x, sum = 0.0;
   size_t n;
-  if (scm_is_simple_vector (v))
+  if (scm_is_vector (v))
     {
       n = SCM_SIMPLE_VECTOR_LENGTH (v);
       while (n-- > 0)
@@ -626,7 +626,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0,
   scm_generalized_vector_get_handle (v, &handle);
   dim = scm_array_handle_dims (&handle);
 
-  if (scm_is_vector (v))
+  if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
     {
       SCM *elts = scm_array_handle_writable_elements (&handle);
       for (i = dim->lbnd; i <= dim->ubnd; i++, elts += dim->inc)

libguile/sort.c

@@ -77,18 +77,25 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
 #define FUNC_NAME s_scm_restricted_vector_sort_x
 {
   size_t vlen, spos, len;
-  ssize_t vinc;
   scm_t_array_handle handle;
+  scm_t_array_dim *dim;
+
   SCM *velts;
 
-  velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
+  if (!scm_is_array (vec) || 1 != scm_c_array_rank (vec))
+      SCM_WRONG_TYPE_ARG (1, vec);
+
+  scm_array_get_handle (vec, &handle);
+  velts = scm_array_handle_writable_elements (&handle);
+  dim = scm_array_handle_dims (&handle);
+  vlen = dim->ubnd - dim->lbnd + 1;
   spos = scm_to_unsigned_integer (startpos, 0, vlen);
   len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
 
-  if (vinc == 1)
+  if (dim->inc == 1)
-    quicksort1 (velts + spos*vinc, len, less);
+    quicksort1 (velts + spos, len, less);
   else
-    quicksort (velts + spos*vinc, len, vinc, less);
+    quicksort (velts + spos*dim->inc, len, dim->inc, less);
 
   scm_array_handle_release (&handle);
 
@@ -377,12 +384,12 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
       SCM_VALIDATE_LIST_COPYLEN (1, items, len);
       return scm_merge_list_step (&items, less, len);
     }
-  else if (scm_is_vector (items))
+  else if (scm_is_array (items))
     {
       scm_restricted_vector_sort_x (items,
 				    less,
 				    scm_from_int (0),
-				    scm_vector_length (items));
+				    scm_array_length (items));
       return items;
     }
   else
@@ -403,7 +410,7 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
 
   if (scm_is_pair (items))
     return scm_sort_x (scm_list_copy (items), less);
-  else if (scm_is_vector (items))
+  else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
     return scm_sort_x (scm_vector_copy (items), less);
   else
     SCM_WRONG_TYPE_ARG (1, items);
@@ -489,28 +496,30 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
       SCM_VALIDATE_LIST_COPYLEN (1, items, len);
       return scm_merge_list_step (&items, less, len);
     }
-  else if (scm_is_vector (items))
+  else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
     {
-      scm_t_array_handle temp_handle, vec_handle;
+      scm_t_array_handle temp_handle, items_handle;
-      SCM temp, *temp_elts, *vec_elts;
+      scm_t_array_dim *dim;
+      SCM temp, *temp_elts, *items_elts;
       size_t len;
-      ssize_t inc;
+
-      
+      scm_array_get_handle (items, &items_handle);
-      vec_elts = scm_vector_writable_elements (items, &vec_handle,
+      items_elts = scm_array_handle_writable_elements (&items_handle);
-					       &len, &inc);
+      dim = scm_array_handle_dims (&items_handle);
+      len = dim->ubnd - dim->lbnd + 1;
       if (len == 0) {
-        scm_array_handle_release (&vec_handle);
+        scm_array_handle_release (&items_handle);
         return items;
       }
-      
-      temp = scm_c_make_vector (len, SCM_UNDEFINED);
-      temp_elts = scm_vector_writable_elements (temp, &temp_handle,
-						NULL, NULL);
 
-      scm_merge_vector_step (vec_elts, temp_elts, less, 0, len-1, inc);
+      temp = scm_c_make_vector (len, SCM_UNDEFINED);
+      scm_array_get_handle (temp, &temp_handle);
+      temp_elts = scm_array_handle_writable_elements (&temp_handle);
+
+      scm_merge_vector_step (items_elts, temp_elts, less, 0, len-1, dim->inc);
 
       scm_array_handle_release (&temp_handle);
-      scm_array_handle_release (&vec_handle);
+      scm_array_handle_release (&items_handle);
 
       return items;
     }
@@ -532,15 +541,13 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
 
   if (scm_is_pair (items))
     return scm_stable_sort_x (scm_list_copy (items), less);
-  else if (scm_is_vector (items))
-    return scm_stable_sort_x (scm_vector_copy (items), less);
   else
-    SCM_WRONG_TYPE_ARG (1, items);
+    return scm_stable_sort_x (scm_vector_copy (items), less);
 }
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0, 
+SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
             (SCM items, SCM less),
 	    "Sort the list @var{items}, using @var{less} for comparing the\n"
 	    "list elements. The sorting is destructive, that means that the\n"

libguile/stime.c

@@ -506,7 +506,7 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
 static void
 bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
 {
-  SCM_ASSERT (scm_is_simple_vector (sbd_time)
+  SCM_ASSERT (scm_is_vector (sbd_time)
 	      && SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
 	      sbd_time, pos, subr);
 

libguile/trees.c

@@ -99,7 +99,7 @@ copy_tree (struct t_trace *const hare,
            unsigned int tortoise_delay)
 #define FUNC_NAME s_scm_copy_tree
 {
-  if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
+  if (!scm_is_pair (hare->obj) && !scm_is_vector (hare->obj))
     {
       return hare->obj;
     }
@@ -128,7 +128,7 @@ copy_tree (struct t_trace *const hare,
           --tortoise_delay;
         }
 
-      if (scm_is_simple_vector (hare->obj))
+      if (scm_is_vector (hare->obj))
         {
           size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
           SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);

libguile/validate.h

@@ -358,12 +358,12 @@
 
 #define SCM_VALIDATE_VECTOR(pos, v) \
   do { \
-    SCM_ASSERT (scm_is_simple_vector (v), v, pos, FUNC_NAME); \
+    SCM_ASSERT (scm_is_vector (v), v, pos, FUNC_NAME); \
   } while (0)
 
 #define SCM_VALIDATE_VECTOR_OR_DVECTOR(pos, v) \
   do { \
-    SCM_ASSERT ((scm_is_simple_vector (v) \
+    SCM_ASSERT ((scm_is_vector (v) \
                 || (scm_is_true (scm_f64vector_p (v)))), \
                 v, pos, FUNC_NAME); \
   } while (0)

libguile/vectors.c

@@ -47,14 +47,7 @@
 int
 scm_is_vector (SCM obj)
 {
-  if (SCM_I_IS_VECTOR (obj))
+  return SCM_I_IS_VECTOR (obj);
-    return 1;
-  if  (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
-    {
-      SCM v = SCM_I_ARRAY_V (obj);
-      return SCM_I_IS_VECTOR (v);
-    }
-  return 0;
 }
 
 int

test-suite/Makefile.am

@@ -111,6 +111,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/r6rs-unicode.test		\
 	    tests/rnrs-libraries.test		\
 	    tests/ramap.test			\
+	    tests/random.test			\
 	    tests/rdelim.test			\
 	    tests/reader.test			\
 	    tests/receive.test			\

test-suite/tests/arrays.test

@@ -1,4 +1,4 @@
-;;;; unif.test --- tests guile's uniform arrays     -*- scheme -*-
+;;;; arrays.test --- tests guile's uniform arrays     -*- scheme -*-
 ;;;;
 ;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 ;;;;

test-suite/tests/random.test

@@ -0,0 +1,55 @@
+;;;; random.test --- tests guile's uniform arrays     -*- scheme -*-
+;;;;
+;;;; Copyright 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-random)
+  #:use-module ((system base compile) #:select (compile))
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-4)
+  #:use-module (srfi srfi-4 gnu))
+
+; see strings.test, arrays.test.
+(define exception:wrong-type-arg
+  (cons #t "Wrong type"))
+
+;;;
+;;; random:normal-vector!
+;;;
+
+(with-test-prefix "random:normal-vector!"
+
+  ;; FIXME need proper function test.
+
+  (pass-if "non uniform"
+    (let ((a (make-vector 4 0))
+          (b (make-vector 4 0))
+          (c (make-shared-array (make-vector 8 0)
+                                (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+      (begin
+        (random:normal-vector! b (random-state-from-platform))
+        (random:normal-vector! c (random-state-from-platform))
+        (and (not (equal? a b)) (not (equal? a c))))))
+
+  (pass-if "uniform (f64)"
+    (let ((a (make-f64vector 4 0))
+          (b (make-f64vector 4 0))
+          (c (make-shared-array (make-f64vector 8 0)
+                                (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+      (begin
+        (random:normal-vector! b (random-state-from-platform))
+        (random:normal-vector! c (random-state-from-platform))
+        (and (not (equal? a b)) (not (equal? a c)))))))