[Guile-commits] GNU Guile branch, master, updated. v2.1.0-643-ga6f8d3d

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a6f8d3ddd833260bed88709f73ab9cb380f7afa0

The branch, master has been updated
       via  a6f8d3ddd833260bed88709f73ab9cb380f7afa0 (commit)
       via  ee2386952149ceb31cb6d32c58be90f1d5c32c30 (commit)
       via  c2cb82f85ad248eaa3d1d1b3b0149dbbb2510bde (commit)
       via  1080ce25bca18ef3a999995ab15664c2a10fd974 (commit)
      from  2bee653acbc4d0978fc5de3d8027865e19fc6ce9 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 libguile/arrays.c            |   27 ++++++++-------
 test-suite/tests/arrays.test |   74 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 88 insertions(+), 13 deletions(-)

diff --git a/libguile/arrays.c b/libguile/arrays.c
index 188dba8..a8b62b2 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -60,21 +60,22 @@
   (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & 
~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
 
 
-SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, 
+SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
            (SCM ra),
            "Return the root vector of a shared array.")
 #define FUNC_NAME s_scm_shared_array_root
 {
-  if (SCM_I_ARRAYP (ra))
+  if (!scm_is_array (ra))
+    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
+  else if (SCM_I_ARRAYP (ra))
     return SCM_I_ARRAY_V (ra);
-  else if (scm_is_generalized_vector (ra))
+  else
     return ra;
-  scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
 }
 #undef FUNC_NAME
 
 
-SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, 
+SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
            (SCM ra),
            "Return the root vector index of the first element in the array.")
 #define FUNC_NAME s_scm_shared_array_offset
@@ -476,20 +477,22 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 
1,
   SCM_VALIDATE_REST_ARGUMENT (args);
   SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
 
-  if (scm_is_generalized_vector (ra))
+  switch (scm_c_array_rank (ra))
     {
+    case 0:
+      if (!scm_is_null (args))
+       SCM_WRONG_NUM_ARGS ();
+      return ra;
+    case 1:
       /* Make sure that we are called with a single zero as
-        arguments. 
+        arguments.
       */
       if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
        SCM_WRONG_NUM_ARGS ();
       SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
       SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
       return ra;
-    }
-
-  if (SCM_I_ARRAYP (ra))
-    {
+    default:
       vargs = scm_vector (args);
       if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
        SCM_WRONG_NUM_ARGS ();
@@ -539,8 +542,6 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
       scm_i_ra_set_contp (res);
       return res;
     }
-
-  scm_wrong_type_arg_msg (NULL, 0, ra, "array");
 }
 #undef FUNC_NAME
 
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 9d86371..600c295 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -574,6 +574,80 @@
           (eqv? 8 (array-ref s2 2))))))
 
 ;;;
+;;; shared-array-root
+;;;
+
+(with-test-prefix "shared-array-root"
+
+  (define amap1 (lambda (i) (list (* 2 i))))
+  (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
+
+  (pass-if "plain vector"
+    (let* ((a (make-vector 4 0))
+           (b (make-shared-array a amap1 2)))
+      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+  (pass-if "plain array rank 2"
+    (let* ((a (make-array 0 4 4))
+           (b (make-shared-array a amap2 2 2)))
+      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+  (pass-if "uniform array rank 2"
+    (let* ((a (make-typed-array 'c64 0 4 4))
+           (b (make-shared-array a amap2 2 2)))
+      (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+  (pass-if "bit array rank 2"
+    (let* ((a (make-typed-array 'b #f 4 4))
+           (b (make-shared-array a amap2 2 2)))
+      (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
+
+;;;
+;;; 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
+    (transpose-array 99))
+
+  (pass-if "rank 0"
+    (let* ((a #0(99))
+           (b (transpose-array a)))
+      (and (array-equal? a b)
+           (eq? (shared-array-root a) (shared-array-root b)))))
+
+  (pass-if "rank 1"
+    (let* ((a #(1 2 3))
+           (b (transpose-array a 0)))
+      (and (array-equal? a b)
+           (eq? (shared-array-root a) (shared-array-root b)))))
+
+  (pass-if "rank 2"
+    (let* ((a #2((1 2 3) (4 5 6)))
+           (b (transpose-array a 1 0))
+           (c (transpose-array a 0 1)))
+      (and (array-equal? b #2((1 4) (2 5) (3 6)))
+           (array-equal? c a)
+           (eq? (shared-array-root a)
+                (shared-array-root b)
+                (shared-array-root c)))))
+
+  ; rank > 2 is needed to check against the inverted axis index logic.
+  (pass-if "rank 3"
+    (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
+                 ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
+           (b (transpose-array a 1 2 0)))
+      (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
+                              ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
+           (eq? (shared-array-root a)
+                (shared-array-root b))))))
+
+;;;
 ;;; uniform-vector
 ;;;
 


hooks/post-receive
-- 
GNU Guile