mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-03 08:10:31 +02:00
Code Activity

Fix compilation errors when reading arrays at the repl

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

42
libguile/arrays.c
View file

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

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

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