mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Refactor array-contents

Browse source 
* 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.
This commit is contained in:
Daniel Llorens 2013-04-20 01:27:42 +02:00 • committed by Andy Wingo
parent dd60e9348e
commit c545f7164a
2 changed files with 85 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

42
libguile/arrays.c
View file

@ -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

65
test-suite/tests/arrays.test
View file

@ -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
;;;