For uniform vectors SCM_I_ARRAYP can't be true

This fixes an inconsistency where uniform-vector? of a shared array could
be true but -ref operations failed to account correctly for lbnd.

* libguile/uniform.c
  - scm_is_uniform_vector: SCM_I_ARRAYP disqualifies obj as uniform vector.
  - scm_c_uniform_vector_length: lbnd is known 0, so don't use it.
  - scm_c_uniform_vector_ref: lbnd/base/inc are known to be 0/0/1.
  - scm_c_uniform_vector_set_x!: idem.
  - scm_uniform_vector_writable_elements: check uvec's type.
* test-suite/tests/arrays.test
  - group the exception types at the top.
  - check that uniform-vector functions do not accept general arrays.

2 files changed, 41 insertions, 28 deletions

diff --git a/libguile/uniform.c b/libguile/uniform.c
index 6df7806fd..0be344d94 100644
--- a/libguile/uniform.c
+++ b/libguile/uniform.c
@@ -87,11 +87,10 @@ scm_is_uniform_vector (SCM obj)
   scm_t_array_handle h;
   int ret = 0;
 
-  if (scm_is_array (obj))
+  if (scm_is_array (obj) && !SCM_I_ARRAYP (obj))
     {
       scm_array_get_handle (obj, &h);
-      ret = 1 == scm_array_handle_rank (&h)
-            && SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
+      ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
       scm_array_handle_release (&h);
     }
   return ret;
@@ -107,7 +106,7 @@ scm_c_uniform_vector_length (SCM uvec)
                             "uniform vector");
 
   scm_array_get_handle (uvec, &h);
-  ret = h.dims[0].ubnd - h.dims[0].lbnd + 1;
+  ret = h.dims[0].ubnd + 1;
   scm_array_handle_release (&h);
   return ret;
 }
@@ -184,7 +183,6 @@ scm_c_uniform_vector_ref (SCM v, size_t pos)
     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 
   scm_array_get_handle (v, &h);
-  pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
   ret = h.impl->vref (&h, pos);
   scm_array_handle_release (&h);
   return ret;
@@ -210,7 +208,6 @@ scm_c_uniform_vector_set_x (SCM v, size_t pos, SCM val)
     scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
 
   scm_array_get_handle (v, &h);
-  pos = h.base + h.dims[0].lbnd + pos * h.dims[0].inc;
   h.impl->vset (&h, pos, val);
   scm_array_handle_release (&h);
 }
@@ -251,6 +248,8 @@ scm_uniform_vector_writable_elements (SCM uvec,
 				      size_t *lenp, ssize_t *incp)
 {
   void *ret;
+  if (!scm_is_uniform_vector (uvec))
+    scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
   scm_array_get_handle (uvec, h);
   /* FIXME nonlocal exit */
   ret = scm_array_handle_uniform_writable_elements (h);
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 0da1a1992..8ad97f4b2 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -22,16 +22,22 @@
   #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-4 gnu))
 
-;;;
-;;; array?
-;;;
-
 (define exception:wrong-num-indices
   (cons 'misc-error "^wrong number of indices.*"))
 
 (define exception:length-non-negative
   (cons 'read-error ".*array length must be non-negative.*"))
 
+(define exception:mapping-out-of-range
+  (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array
+
+; see strings.test.
+(define exception:wrong-type-arg
+  (cons #t "Wrong type"))
+
+;;;
+;;; array?
+;;;
 
 (with-test-prefix "sanity"
   ;; At the current time of writing, bignums have a tc7 that is one bit
@@ -210,9 +216,6 @@
 ;;; make-shared-array
 ;;;
 
-(define exception:mapping-out-of-range
-  (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array
-
 (with-test-prefix "make-shared-array"
 
   ;; this failed in guile 1.8.0
@@ -313,10 +316,6 @@
 ;;; transpose-array
 ;;;
 
-; see strings.test.
-(define exception:wrong-type-arg
-  (cons #t "Wrong type"))
-
 (with-test-prefix "transpose-array"
 
   (pass-if-exception "non array argument" exception:wrong-type-arg
@@ -670,21 +669,36 @@
 	  (array-set! a -128 0)
 	  (= -128 (uniform-vector-ref a 0))))))
 
-  (with-test-prefix "shared with rank 1 remain uniform vectors"
+  (with-test-prefix "arrays with lbnd!=0 are not uniform vectors"
+
+    (pass-if "bit"
+      (and (not (uniform-vector? #1b@1(#t #t #t)))
+           (uniform-vector? #1b(#t #t #t))))
+
+    (pass-if "s8"
+      (and (not (uniform-vector? #1s8@1(0 1 2)))
+           (uniform-vector? #1s8(0 1 2)))))
+
+
+  (with-test-prefix "shared with rank 1 do not remain uniform vectors"
 
     (let ((a #f64(1 2 3 4)))
 
-      (pass-if "change offset"
+      (pass-if-exception "change offset -length" exception:wrong-type-arg
         (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
-          (and (uniform-vector? b)
-               (= 3 (uniform-vector-length b))
-               (array-equal? b #f64(2 3 4)))))
-
-      (pass-if "change stride"
-        (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2)))
-          (and (uniform-vector? c)
-               (= 2 (uniform-vector-length c))
-               (array-equal? c #f64(1 3))))))))
+          (= 3 (uniform-vector-length b))))
+
+      (pass-if-exception "change offset -ref" exception:wrong-type-arg
+        (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
+          (= 2 (uniform-vector-ref b 0))))
+
+      (pass-if-exception "change stride -length" exception:wrong-type-arg
+        (let ((b (make-shared-array a (lambda (i) (list (* i 2))) 2)))
+          (= 3 (uniform-vector-length b))))
+
+      (pass-if-exception "change stride -ref" exception:wrong-type-arg
+        (let ((b (make-shared-array a (lambda (i) (list (* i 2))) 2)))
+          (= 2 (uniform-vector-ref b 0)))))))
 
 ;;;
 ;;; syntax