From b713626073eba62ef233bcff21812efe64350a25 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Sat, 20 Apr 2013 01:27:42 +0200 Subject: Fix compilation errors when reading arrays at the repl * compile-assembly.scm - vector-fold2: handle rank 1 arrays, since this is called with the result of array-contents which need not be a vector. - dump-constants: fix uses of vector-fold2. Replace vector-length on result of array-contents by array-length. * 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 - tests for array-contents. --- libguile/arrays.c | 42 ++++++++++++++--------------- test-suite/tests/arrays.test | 63 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 83 insertions(+), 22 deletions(-) diff --git a/libguile/arrays.c b/libguile/arrays.c index a743cfe8c..e86a620ae 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -562,15 +562,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; @@ -587,23 +585,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 7b7471543..88ae00a10 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -289,6 +289,69 @@ (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 ;;; -- cgit v1.2.3