summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDaniel Llorens <daniel.llorens@bluewin.ch>2013-04-19 12:57:13 +0200
committerAndy Wingo <wingo@pobox.com>2014-01-27 21:45:18 +0100
commitf1fcf88b1f2c7955bda03b5243b904ba16f79b71 (patch)
tree87649a52d6adc41123f3290ee409ab2e8125e4cf
parente26994b9e9ab075e357d71d4e06fc2a09f7f243b (diff)
downloadguile-f1fcf88b1f2c7955bda03b5243b904ba16f79b71.tar.gz
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.
-rw-r--r--libguile/array-map.c127
-rw-r--r--test-suite/tests/ramap.test61
2 files changed, 102 insertions, 86 deletions
diff --git a/libguile/array-map.c b/libguile/array-map.c
index e2bf7ae96..971df1bfd 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -87,108 +87,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?) */
-
- if (!scm_is_array (ra0))
- return 0;
- else if (!SCM_I_ARRAYP (ra0))
- {
- s0->lbnd = 0;
- s0->inc = 1;
- s0->ubnd = scm_c_array_length (ra0) - 1;
- }
- else
+ int i, exact = 4, empty = 0;
+ scm_t_array_handle h0;
+
+ 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);
}
while (scm_is_pair (ras))
{
- ra1 = SCM_CAR (ras);
-
- if (!SCM_I_ARRAYP (ra1))
- {
- size_t length;
-
- if (1 != ndim)
- return 0;
+ scm_t_array_handle h1;
- length = scm_c_array_length (ra1);
+ scm_array_get_handle (SCM_CAR (ras), &h1);
- 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;
@@ -334,6 +306,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
}
while (k >= 0);
+ case 5:
return 1;
}
}
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index 2ecd43b22..299df9f70 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -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)))))