mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

Fix scm_ramapc bugs with 0-inc arrays

Browse source 
* libguile/array-map.c: (scm_ramapc): Cannot flag empty on the product
  inc * dim * dim ... Check every dim.
* test-suite/tests/ramap.test: Tests the 0-inc, non empty case for both
  array-map! and array-copy!.
This commit is contained in:
Daniel Llorens 2013-04-25 18:49:14 +02:00 • committed by Andy Wingo
parent 2bd96d9ecd
commit 3ee4c76453
2 changed files with 35 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

9
libguile/array-map.c
View file

@ -130,18 +130,19 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{ {
ssize_t inc = SCM_I_ARRAY_DIMS (ra0)[k].inc; ssize_t inc = SCM_I_ARRAY_DIMS (ra0)[k].inc;
do { do {
inc *= (UBND (ra0, k) - LBND (ra0, k) + 1); ssize_t dim = (UBND (ra0, k) - LBND (ra0, k) + 1);
empty = empty || (0 == dim);
inc *= dim;
--k; --k;
} while (k >= 0 && inc == SCM_I_ARRAY_DIMS (ra0)[k].inc); } while (k >= 0 && inc == SCM_I_ARRAY_DIMS (ra0)[k].inc);
kroll = k+1; kroll = k+1;
empty = 0 == inc;
} }
else else
kroll = 0; kroll = 0;
/* Check emptiness of not-unrolled axes. */ /* Check emptiness of not-unrolled axes. */
for (; k>=0 && !empty; --k) for (; k>=0; --k)
empty = (0 == (UBND (ra0, k) - LBND (ra0, k) + 1)); empty = empty || (0 == (UBND (ra0, k) - LBND (ra0, k) + 1));
} }
else else
{ {

50
test-suite/tests/ramap.test
View file

@ -112,6 +112,23 @@
(array-copy! a b) (array-copy! a b)
(array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0)))))) (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
(pass-if "rank 0"
(let ((a #0(99))
(b (make-array 0)))
(array-copy! a b)
(equal? b #0(99))))
(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 2" (pass-if "rank 2"
(let ((a #2((1 2) (3 4))) (let ((a #2((1 2) (3 4)))
(b (make-array 0 2 2)) (b (make-array 0 2 2))
@ -136,27 +153,15 @@
(piece (lambda (X w s) (piece (lambda (X w s)
(make-shared-array (make-shared-array
X (lambda (i j) (list i (+ j s))) 3 w)))) X (lambda (i j) (list i (+ j s))) 3 w))))
(array-map! A (piece X 2 0)) (array-copy! A (piece X 2 0))
(array-map! B (piece X 2 2)) (array-copy! B (piece X 2 2))
(array-map! C (piece X 1 4)) (array-copy! C (piece X 1 4))
(and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22)))))) (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
(pass-if "rank 1" (pass-if "null increments, not empty"
(let* ((a #2((1 2) (3 4))) (let ((a (make-array 0 2 2)))
(b (make-shared-array a (lambda (j) (list 1 j)) 2)) (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
(c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2)) (array-equal? #2((1 1) (1 1))))))
(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! ;;; array-map!
@ -276,7 +281,12 @@
(array-map! (piece X 2 0) values A) (array-map! (piece X 2 0) values A)
(array-map! (piece X 2 2) values B) (array-map! (piece X 2 2) values B)
(array-map! (piece X 1 4) values C) (array-map! (piece X 1 4) values C)
(and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))) (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
(pass-if "null increments, not empty"
(let ((a (make-array 0 2 2)))
(array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
(array-equal? a #2((1 1) (1 1))))))
(with-test-prefix "two sources" (with-test-prefix "two sources"