diff options
author | Daniel Llorens <daniel.llorens@bluewin.ch> | 2013-04-19 12:57:13 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-01-27 21:45:18 +0100 |
commit | f1fcf88b1f2c7955bda03b5243b904ba16f79b71 (patch) | |
tree | 87649a52d6adc41123f3290ee409ab2e8125e4cf | |
parent | e26994b9e9ab075e357d71d4e06fc2a09f7f243b (diff) | |
download | guile-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.c | 127 | ||||
-rw-r--r-- | test-suite/tests/ramap.test | 61 |
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))))) |