From c545f7164a80586ac287c551b089101387319e8c Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Sat, 20 Apr 2013 01:27:42 +0200
Subject: [PATCH] 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            | 42 +++++++++++------------
 test-suite/tests/arrays.test | 65 ++++++++++++++++++++++++++++++++++++
 2 files changed, 85 insertions(+), 22 deletions(-)

diff --git a/libguile/arrays.c b/libguile/arrays.c
index 84d0f71fb..413a6f4c1 100644
--- a/libguile/arrays.c
+++ b/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_generalized_vector (ra))
-    return ra;
-
-  if (SCM_I_ARRAYP (ra))
+  if (!scm_is_array (ra))
+    scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+  else 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,
 	    }
 	}
 
-      {
-	SCM v = SCM_I_ARRAY_V (ra);
-	size_t length = scm_c_array_length (v);
-	if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
-	  return v;
-      }
-
-      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_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;
+      v = SCM_I_ARRAY_V (ra);
+      if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra))
+          && SCM_I_ARRAY_DIMS (ra)->inc)
+        return v;
+      else
+        {
+          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) = 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
 
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 1716ec22e..54d936520 100644
--- a/test-suite/tests/arrays.test
+++ b/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
 ;;;
-- 
2.20.1