Refactor array-contents

* libguile/arrays.c (scm_array_contents): Branch cases not on
  scm_is_generalized_vector but on SCM_I_ARRAYP. Thus lbnd!=0, which
  could happen with scm_is_generalized_vector, never appears in the
  output.
* test-suite/tests/arrays.test: Test array-contents.

libguile/arrays.c

@@ -563,15 +563,13 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
 	    "contiguous in memory.")
 #define FUNC_NAME s_scm_array_contents
 {
-  SCM sra;
+  if (!scm_is_array (ra))
-
+    scm_wrong_type_arg_msg (NULL, 0, ra, "array");
-  if (scm_is_generalized_vector (ra))
+  else if (SCM_I_ARRAYP (ra))
-    return ra;
-
-  if (SCM_I_ARRAYP (ra))
     {
+      SCM v;
       size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
-      if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
+      if (!SCM_I_ARRAY_CONTP (ra))
 	return SCM_BOOL_F;
       for (k = 0; k < ndim; k++)
 	len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
@@ -588,23 +586,23 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
 	    }
 	}
 
-      {
+      v = SCM_I_ARRAY_V (ra);
-	SCM v = SCM_I_ARRAY_V (ra);
+      if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra))
-	size_t length = scm_c_array_length (v);
+          && SCM_I_ARRAY_DIMS (ra)->inc)
-	if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
         return v;
-      }
+      else
-
+        {
-      sra = scm_i_make_array (1);
+          SCM sra = scm_i_make_array (1);
           SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
           SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
-      SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
+          SCM_I_ARRAY_V (sra) = v;
           SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
           SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
           return sra;
         }
+    }
   else
-    scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+    return ra;
 }
 #undef FUNC_NAME
 

test-suite/tests/arrays.test

@@ -279,6 +279,71 @@
       (and (eqv? 5 (array-ref s2 1))
 	   (eqv? 8 (array-ref s2 2))))))
 
+;;;
+;;; array-contents
+;;;
+
+(with-test-prefix "array-contents"
+
+  (define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2))
+
+  (pass-if "simple vector"
+    (let* ((a (make-array 0 4)))
+      (eq? a (array-contents a))))
+
+  (pass-if "offset vector"
+    (let* ((a (make-array 0 '(1 4))))
+      (array-copy! #(1 2 3 4) (array-contents a))
+      (array-equal? #1@1(1 2 3 4) a)))
+
+  (pass-if "offset vector, strict"
+    (let* ((a (make-array 0 '(1 4))))
+      (array-copy! #(1 2 3 4) (array-contents a #t))
+      (array-equal? #1@1(1 2 3 4) a)))
+
+  (pass-if "stepped vector"
+    (let* ((a (make-array 0 4)))
+      (array-copy! #(99 66) (array-contents (every-two a)))
+      (array-equal? #(99 0 66 0) a)))
+
+  ;; this failed in 2.0.9.
+  (pass-if "stepped vector, strict"
+    (let* ((a (make-array 0 4)))
+      (not (array-contents (every-two a) #t))))
+
+  (pass-if "plain rank 2 array"
+    (let* ((a (make-array 0 2 2)))
+      (array-copy! #(1 2 3 4) (array-contents a #t))
+      (array-equal? #2((1 2) (3 4)) a)))
+
+  (pass-if "offset rank 2 array"
+    (let* ((a (make-array 0 '(1 2) '(1 2))))
+      (array-copy! #(1 2 3 4) (array-contents a #t))
+      (array-equal? #2@1@1((1 2) (3 4)) a)))
+
+  (pass-if "transposed rank 2 array"
+    (let* ((a (make-array 0 4 4)))
+      (not (array-contents (transpose-array a 1 0) #t))))
+
+  (pass-if "broadcast vector I"
+    (let* ((a (make-array 0 4))
+           (b (make-shared-array a (lambda (i j k) (list k)) 1 1 4)))
+      (array-copy! #(1 2 3 4) (array-contents b #t))
+      (array-equal? #(1 2 3 4) a)))
+
+  (pass-if "broadcast vector II"
+    (let* ((a (make-array 0 4))
+           (b (make-shared-array a (lambda (i j k) (list k)) 2 1 4)))
+      (not (array-contents b))))
+
+  ;; FIXME maybe this should be allowed.
+  #;
+  (pass-if "broadcast vector -> empty"
+    (let* ((a (make-array 0 4))
+           (b (make-shared-array a (lambda (i j k) (list k)) 0 1 4)))
+      (if #f #f)))
+  )
+
 ;;;
 ;;; shared-array-root
 ;;;