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 <[email protected]> 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 <[email protected]> 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 <[email protected]> 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? #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))) + + (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
