mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
Fix array map functions with empty arguments
* libguile/array-map.c
- scm_ra_matchp: look for empty axes and return new case 5 if so. Use
array handles to remove the SCM_I_ARRAYP / not branch.
- scm_ramapc: Heed case 5.
* test-suite/tests/ramap.test
- test empty arguments for array-copy! and array-for-each. Note those
that failed in 2.0.9.
This commit is contained in:
Daniel Llorens
Andy Wingo
parent
b0d9b0744a
commit
8269f0be18
2 changed files with 101 additions and 85 deletions
|
|
@ -74,108 +74,80 @@ cind (SCM ra, long *ve)
|
|||
|
||||
|
||||
/* Checker for scm_array mapping functions:
|
||||
return values: 4 --> shapes, increments, and bases are the same;
|
||||
return values:
|
||||
5 --> empty axes;
|
||||
4 --> shapes, increments, and bases are the same;
|
||||
3 --> shapes and increments are the same;
|
||||
2 --> shapes are the same;
|
||||
1 --> ras are at least as big as ra0;
|
||||
0 --> no match.
|
||||
*/
|
||||
|
||||
int
|
||||
int
|
||||
scm_ra_matchp (SCM ra0, SCM ras)
|
||||
{
|
||||
SCM ra1;
|
||||
scm_t_array_dim dims;
|
||||
scm_t_array_dim *s0 = &dims;
|
||||
scm_t_array_dim *s1;
|
||||
unsigned long bas0 = 0;
|
||||
int i, ndim = 1;
|
||||
int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
|
||||
int i, exact = 4, empty = 0;
|
||||
scm_t_array_handle h0;
|
||||
|
||||
if (SCM_I_ARRAYP (ra0))
|
||||
scm_array_get_handle (ra0, &h0);
|
||||
for (i = 0; i < h0.ndims; ++i)
|
||||
{
|
||||
ndim = SCM_I_ARRAY_NDIM (ra0);
|
||||
s0 = SCM_I_ARRAY_DIMS (ra0);
|
||||
bas0 = SCM_I_ARRAY_BASE (ra0);
|
||||
empty = empty || (h0.dims[i].lbnd > h0.dims[i].ubnd);
|
||||
}
|
||||
else if (scm_is_array (ra0))
|
||||
{
|
||||
s0->lbnd = 0;
|
||||
s0->inc = 1;
|
||||
s0->ubnd = scm_c_array_length (ra0) - 1;
|
||||
}
|
||||
else
|
||||
return 0;
|
||||
|
||||
while (scm_is_pair (ras))
|
||||
{
|
||||
ra1 = SCM_CAR (ras);
|
||||
scm_t_array_handle h1;
|
||||
|
||||
if (!SCM_I_ARRAYP (ra1))
|
||||
{
|
||||
size_t length;
|
||||
scm_array_get_handle (SCM_CAR (ras), &h1);
|
||||
|
||||
if (1 != ndim)
|
||||
return 0;
|
||||
|
||||
length = scm_c_array_length (ra1);
|
||||
|
||||
switch (exact)
|
||||
{
|
||||
case 4:
|
||||
if (0 != bas0)
|
||||
exact = 3;
|
||||
case 3:
|
||||
if (1 != s0->inc)
|
||||
exact = 2;
|
||||
case 2:
|
||||
if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
|
||||
break;
|
||||
exact = 1;
|
||||
case 1:
|
||||
if (s0->lbnd < 0 || s0->ubnd >= length)
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
else if (ndim == SCM_I_ARRAY_NDIM (ra1))
|
||||
{
|
||||
s1 = SCM_I_ARRAY_DIMS (ra1);
|
||||
if (bas0 != SCM_I_ARRAY_BASE (ra1))
|
||||
exact = 3;
|
||||
for (i = 0; i < ndim; i++)
|
||||
switch (exact)
|
||||
{
|
||||
case 4:
|
||||
case 3:
|
||||
if (s0[i].inc != s1[i].inc)
|
||||
exact = 2;
|
||||
case 2:
|
||||
if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
|
||||
break;
|
||||
exact = 1;
|
||||
default:
|
||||
if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
|
||||
return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
|
||||
}
|
||||
}
|
||||
else
|
||||
return 0;
|
||||
if (h0.ndims != h1.ndims)
|
||||
{
|
||||
scm_array_handle_release (&h0);
|
||||
scm_array_handle_release (&h1);
|
||||
return 0;
|
||||
}
|
||||
if (h0.base != h1.base)
|
||||
exact = min(3, exact);
|
||||
|
||||
for (i = 0; i < h0.ndims; ++i)
|
||||
{
|
||||
empty = empty || (h1.dims[i].lbnd > h1.dims[i].ubnd);
|
||||
switch (exact)
|
||||
{
|
||||
case 4:
|
||||
case 3:
|
||||
if (h0.dims[i].inc != h1.dims[i].inc)
|
||||
exact = 2;
|
||||
case 2:
|
||||
if (h0.dims[i].lbnd == h1.dims[i].lbnd && h0.dims[i].ubnd == h1.dims[i].ubnd)
|
||||
break;
|
||||
exact = 1;
|
||||
default:
|
||||
if (h0.dims[i].lbnd < h1.dims[i].lbnd || h0.dims[i].ubnd > h1.dims[i].ubnd)
|
||||
{
|
||||
scm_array_handle_release (&h0);
|
||||
scm_array_handle_release (&h1);
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
scm_array_handle_release (&h1);
|
||||
ras = SCM_CDR (ras);
|
||||
}
|
||||
|
||||
return exact;
|
||||
scm_array_handle_release (&h0);
|
||||
return empty ? 5 : exact;
|
||||
}
|
||||
|
||||
/* array mapper: apply cproc to each dimension of the given arrays?.
|
||||
/* array mapper: apply cproc to each dimension of the given arrays?.
|
||||
int (*cproc) (); procedure to call on unrolled arrays?
|
||||
cproc (dest, source list) or
|
||||
cproc (dest, data, source list).
|
||||
SCM data; data to give to cproc or unbound.
|
||||
cproc (dest, data, source list).
|
||||
SCM data; data to give to cproc or unbound.
|
||||
SCM ra0; destination array.
|
||||
SCM lra; list of source arrays.
|
||||
const char *what; caller, for error reporting. */
|
||||
int
|
||||
int
|
||||
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
||||
{
|
||||
SCM z;
|
||||
|
|
@ -320,6 +292,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
|||
}
|
||||
while (k >= 0);
|
||||
|
||||
case 5:
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,6 +19,9 @@
|
|||
(define-module (test-suite test-ramap)
|
||||
#:use-module (test-suite lib))
|
||||
|
||||
(define exception:shape-mismatch
|
||||
(cons 'misc-error ".*shape mismatch.*"))
|
||||
|
||||
(define (array-row a i)
|
||||
(make-shared-array a (lambda (j) (list i j))
|
||||
(cadr (array-dimensions a))))
|
||||
|
|
@ -45,17 +48,21 @@
|
|||
(pass-if "all axes empty"
|
||||
(array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
|
||||
(array-index-map! (make-typed-array 'b #t 0 0) (const #t))
|
||||
(array-index-map! (make-typed-array #t 0 0 0) (const 0)))
|
||||
(array-index-map! (make-typed-array #t 0 0 0) (const 0))
|
||||
#t)
|
||||
|
||||
(pass-if "last axis empty"
|
||||
(array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
|
||||
(array-index-map! (make-typed-array 'b #t 2 0) (const #t))
|
||||
(array-index-map! (make-typed-array #t 0 2 0) (const 0)))
|
||||
(array-index-map! (make-typed-array #t 0 2 0) (const 0))
|
||||
#t)
|
||||
|
||||
; the 'f64 cases fail in 2.0.9 with out-of-range.
|
||||
(pass-if "axis empty, other than last"
|
||||
(array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
|
||||
(array-index-map! (make-typed-array 'b #t 0 2) (const #t))
|
||||
(array-index-map! (make-typed-array #t 0 0 2) (const 0)))))
|
||||
(array-index-map! (make-typed-array #t 0 0 2) (const 0))
|
||||
#t)))
|
||||
|
||||
;;;
|
||||
;;; array-copy!
|
||||
|
|
@ -63,11 +70,23 @@
|
|||
|
||||
(with-test-prefix "array-copy!"
|
||||
|
||||
(pass-if "empty arrays"
|
||||
(let* ((b (make-array 0 2 2))
|
||||
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
||||
(array-copy! #2:0:2() c)
|
||||
(array-equal? #2:0:2() c))))
|
||||
(with-test-prefix "empty arrays"
|
||||
|
||||
(pass-if "empty other than last, #t"
|
||||
(let* ((b (make-array 0 2 2))
|
||||
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
||||
(array-copy! #2:0:2() c)
|
||||
(array-equal? #2:0:2() c)))
|
||||
|
||||
(pass-if "empty other than last, 'f64"
|
||||
(let* ((b (make-typed-array 'f64 0 2 2))
|
||||
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
||||
(array-copy! #2:0:2() c)
|
||||
(array-equal? #2f64:0:2() c)))
|
||||
|
||||
;; FIXME add type 'b cases.
|
||||
|
||||
))
|
||||
|
||||
;;;
|
||||
;;; array-map!
|
||||
|
|
@ -318,4 +337,28 @@
|
|||
(l '())
|
||||
(rec (lambda args (set! l (cons args l)))))
|
||||
(array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
|
||||
l))))
|
||||
l)))
|
||||
|
||||
(with-test-prefix "empty arrays"
|
||||
|
||||
(pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
|
||||
(let* ((a (list))
|
||||
(b (make-array 0 2 2))
|
||||
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
||||
(array-for-each (lambda (c) (set! a (cons c a))) c)
|
||||
(equal? a '())))
|
||||
|
||||
(pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
|
||||
(let* ((a (list))
|
||||
(b (make-typed-array 'f64 0 2 2))
|
||||
(c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
|
||||
(array-for-each (lambda (c) (set! a (cons c a))) c)
|
||||
(equal? a '())))
|
||||
|
||||
;; FIXME add type 'b cases.
|
||||
|
||||
(pass-if-exception "empty arrays shape check" exception:shape-mismatch
|
||||
(let* ((a (list))
|
||||
(b (make-typed-array 'f64 0 0 2))
|
||||
(c (make-typed-array 'f64 0 2 0)))
|
||||
(array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue