[Guile-commits] GNU Guile branch, master, updated. v2.1.0-732-g35f45ed

[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=35f45ed6d0d4d8d73975cb1935faf32f82cb48b8

The branch, master has been updated
       via  35f45ed6d0d4d8d73975cb1935faf32f82cb48b8 (commit)
       via  c545f7164a80586ac287c551b089101387319e8c (commit)
       via  dd60e9348ea6ff1e0e12025621f44dd8e9d5094b (commit)
      from  1ac534e9046d5f060b07ebdb8fa9f7952a674bdb (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 -----------------------------------------------------------------
commit 35f45ed6d0d4d8d73975cb1935faf32f82cb48b8
Author: Daniel Llorens <address@hidden>
Date:   Wed Apr 24 17:13:56 2013 +0200

    Check more cases of array-contents
    
    * libguile/arrays.c: (scm_array_contents): fix comment.
    * test-suite/tests/arrays.test: add cases that depend on correct
      setting of CONTIGUOUS_FLAG.

commit c545f7164a80586ac287c551b089101387319e8c
Author: Daniel Llorens <address@hidden>
Date:   Sat Apr 20 01:27:42 2013 +0200

    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.

commit dd60e9348ea6ff1e0e12025621f44dd8e9d5094b
Author: Daniel Llorens <address@hidden>
Date:   Wed Apr 24 16:34:31 2013 +0200

    Check the documented matching behavior of array-map!/copy!
    
    * test-suite/tests/arrays.test: move array-copy! tests to ramap.test.
    * test-suite/tests/ramap.test: check the dissimilar matching behavior of
      array-copy! and array-map! with arguments of different size.

-----------------------------------------------------------------------

Summary of changes:
 libguile/arrays.c            |   46 ++++++++---------
 test-suite/tests/arrays.test |  114 +++++++++++++++++++++++++++---------------
 test-suite/tests/ramap.test  |   72 ++++++++++++++++++++++++--
 3 files changed, 163 insertions(+), 69 deletions(-)

diff --git a/libguile/arrays.c b/libguile/arrays.c
index 84d0f71..a378585 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -548,8 +548,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
 
 /* attempts to unroll an array into a one-dimensional array.
    returns the unrolled array or #f if it can't be done.  */
-  /* if strict is not SCM_UNDEFINED, return #f if returned array
-                    wouldn't have contiguous elements.  */
+/* if strict is true, return #f if returned array
+   wouldn't have contiguous elements.  */
 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
            (SCM ra, SCM strict),
            "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
@@ -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 eed5031..4ef8360 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -280,6 +280,80 @@
           (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? address@hidden(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? address@hidden(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? address@hidden@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)))
+
+  (pass-if "broadcast 2-rank I"
+    (let* ((a #2((1 2 3) (4 5 6)))
+           (b (make-shared-array a (lambda (i j) (list 0 j)) 2 3)))
+      (not (array-contents b))))
+
+  (pass-if "broadcast 2-rank I"
+    (let* ((a #2((1 2 3) (4 5 6)))
+           (b (make-shared-array a (lambda (i j) (list i 0)) 2 3)))
+      (not (array-contents b)))))
+
+;;;
 ;;; shared-array-root
 ;;;
 
@@ -449,46 +523,6 @@
              (equal? a #2((9 0 0) (0 9 0) (0 0 9))))))))
 
 ;;;
-;;; array-copy!
-;;;
-
-(with-test-prefix "array-copy!"
-
-  (pass-if "rank 2"
-    (let ((a #2((1 2) (3 4)))
-          (b (make-array 0 2 2))
-          (c (make-array 0 2 2))
-          (d (make-array 0 2 2))
-          (e (make-array 0 2 2)))
-      (array-copy! a b)
-      (array-copy! a (transpose-array c 1 0))
-      (array-copy! (transpose-array a 1 0) d)
-      (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
-      (and (equal? a #2((1 2) (3 4)))
-           (equal? b #2((1 2) (3 4)))
-           (equal? c #2((1 3) (2 4)))
-           (equal? d #2((1 3) (2 4)))
-           (equal? e #2((1 2) (3 4))))))
-
-  (pass-if "rank 1"
-    (let* ((a #2((1 2) (3 4)))
-           (b (make-shared-array a (lambda (j) (list 1 j)) 2))
-           (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
-           (d (make-array 0 2))
-           (e (make-array 0 2)))
-      (array-copy! b d)
-      (array-copy! c e)
-      (and (equal? d #(3 4))
-           (equal? e #(4 2)))))
-
-  (pass-if "rank 0"
-    (let ((a #0(99))
-          (b (make-array 0)))
-      (array-copy! a b)
-      (equal? b #0(99)))))
-
-
-;;;
 ;;; array-in-bounds?
 ;;;
 
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index 299df9f..acb0f22 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -84,9 +84,57 @@
         (array-copy! #2:0:2() c)
         (array-equal? #2f64:0:2() c)))
 
-    ;; FIXME add type 'b cases.
-
-    ))
+  ;; FIXME add empty, type 'b cases.
+
+    )
+
+  ;; note that it is the opposite of array-map!. This is, unfortunately,
+  ;; documented in the manual.
+
+  (pass-if "matching behavior I"
+    (let ((a #(1 2))
+          (b (make-array 0 3)))
+      (array-copy! a b)
+      (equal? b #(1 2 0))))
+
+  (pass-if-exception "matching behavior II" exception:shape-mismatch
+    (let ((a #(1 2 3))
+          (b (make-array 0 2)))
+      (array-copy! a b)
+      (equal? b #(1 2))))
+
+  (pass-if "rank 2"
+    (let ((a #2((1 2) (3 4)))
+          (b (make-array 0 2 2))
+          (c (make-array 0 2 2))
+          (d (make-array 0 2 2))
+          (e (make-array 0 2 2)))
+      (array-copy! a b)
+      (array-copy! a (transpose-array c 1 0))
+      (array-copy! (transpose-array a 1 0) d)
+      (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+      (and (equal? a #2((1 2) (3 4)))
+           (equal? b #2((1 2) (3 4)))
+           (equal? c #2((1 3) (2 4)))
+           (equal? d #2((1 3) (2 4)))
+           (equal? e #2((1 2) (3 4))))))
+
+  (pass-if "rank 1"
+    (let* ((a #2((1 2) (3 4)))
+           (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+           (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+           (d (make-array 0 2))
+           (e (make-array 0 2)))
+      (array-copy! b d)
+      (array-copy! c e)
+      (and (equal? d #(3 4))
+           (equal? e #(4 2)))))
+
+  (pass-if "rank 0"
+    (let ((a #0(99))
+          (b (make-array 0)))
+      (array-copy! a b)
+      (equal? b #0(99)))))
 
 ;;;
 ;;; array-map!
@@ -152,7 +200,7 @@
 
     (pass-if-exception "closure 2" exception:wrong-num-args
       (array-map! (make-array #f 5) (lambda (x y) #f)
-            (make-array #f 5)))
+                  (make-array #f 5)))
 
     (pass-if "subr_1"
       (let ((a (make-array #f 5)))
@@ -268,7 +316,21 @@
             (c (make-array 0 2)))
         (begin
           (array-map! c + (array-col a 1) (array-row a 1))
-          (array-equal? c #(3 6)))))))
+          (array-equal? c #(3 6))))))
+
+  ;; note that array-copy! has the opposite behavior.
+
+  (pass-if-exception "matching behavior I" exception:shape-mismatch
+    (let ((a #(1 2))
+          (b (make-array 0 3)))
+      (array-map! b values a)
+      (equal? b #(1 2 0))))
+
+  (pass-if "matching behavior II"
+    (let ((a #(1 2 3))
+          (b (make-array 0 2)))
+      (array-map! b values a)
+      (equal? b #(1 2)))))
 
 ;;;
 ;;; array-for-each


hooks/post-receive
-- 
GNU Guile