From f6003e88812c33e24e7038937e76e1292774ee98 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Fri, 1 Apr 2016 12:46:37 +0200 Subject: Clean up (array-for-each-cell) * libguile/array-map.c (array-for-each-cell, array-for-each-cell-in-order): Moved from libguile/arrays.c. Fix argument names. Complete docstring. * libguile/array-map.h (array-for-each-cell, array-for-each-cell-in-order): Declarations moved from libguile/arrays.h. * test-suite/tests/array-map.test: Renamed from test-suite/tests/ramap.test, fix module name. Add tests for (array-for-each-cell). * test-suite/Makefile.am: Apply rename array-map.test -> ramap.test. * doc/ref/api-compound.texi: Minor documentation fixes. --- doc/ref/api-compound.texi | 34 ++- libguile/array-map.c | 244 ++++++++++++++++++- libguile/array-map.h | 3 + libguile/arrays.c | 228 ----------------- libguile/arrays.h | 2 - test-suite/Makefile.am | 2 +- test-suite/tests/array-map.test | 528 ++++++++++++++++++++++++++++++++++++++++ test-suite/tests/ramap.test | 509 -------------------------------------- 8 files changed, 790 insertions(+), 760 deletions(-) create mode 100644 test-suite/tests/array-map.test delete mode 100644 test-suite/tests/ramap.test diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 34a832fa1..ef4869cc1 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1795,14 +1795,12 @@ of @var{idxlist} is shorter than @math{n}, then return the shared For example: -@example @lisp (array-from #2((a b) (c d)) 0) @result{} #(a b) (array-from #2((a b) (c d)) 1) @result{} #(c d) (array-from #2((a b) (c d)) 1 1) @result{} d (array-from #2((a b) (c d))) @result{} #2((a b) (c d)) @end lisp -@end example @code{(apply array-from array indices)} is equivalent to @@ -1827,7 +1825,6 @@ write into. Compare: -@example @lisp (array-from #2((a b) (c d)) 1 1) @result{} d (array-from* #2((a b) (c d)) 1) @result{} #0(d) @@ -1836,7 +1833,6 @@ Compare: a @result{} #2((a a) (a b)). (array-fill! (array-from a 1 1) 'b) @result{} error: not an array @end lisp -@end example @code{(apply array-from* array indices)} is equivalent to @@ -1863,12 +1859,19 @@ This function returns the modified @var{array}. For example: -@example @lisp (array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b)) (array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y)) @end lisp -@end example + +Note that @code{array-amend!} will expect elements, not arrays, when the +destination has rank 0. One can work around this using +@code{array-from*} instead. + +@lisp +(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b))) +(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b)) +@end lisp @code{(apply array-amend! array x indices)} is equivalent to @@ -1886,10 +1889,10 @@ The name `amend' comes from the J language. @deffn {Scheme Procedure} array-for-each-cell frame-rank op x @dots{} @deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist) -Each @var{x} must be an array of rank @math{n_x} ≥ @var{frame-rank}, and +Each @var{x} must be an array of rank ≥ @var{frame-rank}, and the first @var{frame-rank} dimensions of each @var{x} must all be the same. @var{array-for-each-cell} calls @var{op} with each set of -(@math{n_x} - @var{frame-rank})-cells from @var{x}, in unspecified order. +(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order. @var{array-for-each-cell} allows you to loop over cells of any rank without having to carry an index list or construct slices manually. The @@ -1898,26 +1901,20 @@ to write to them. This function returns an unspecified value. -For example: +For example, to sort the rows of rank-2 array @code{a}: -@example -Sort the rows of rank-2 array @code{a}: @lisp (array-for-each-cell 1 (lambda (x) (sort! x <)) a) @end lisp -@end example -@example -Let @code{a} be a rank-2 array where each row is a 2-vector @math{x, -y}. Compute the norms of these vectors and store them in rank-1 array -@code{b}: +As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}. +Let's compute the arguments of these vectors and store them in rank-1 array @code{b}. @lisp (array-for-each-cell 1 (lambda (a b) - (array-set! b (hypot (array-ref a 0) (array-ref a 1)))) + (array-set! b (atan (array-ref a 1) (array-ref a 0)))) a b) @end lisp -@end example @code{(apply array-for-each-cell frame-rank op x)} is functionally equivalent to @@ -1933,7 +1930,6 @@ equivalent to (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x))))) @end lisp -The name `amend' comes from the J language. @end deffn diff --git a/libguile/array-map.c b/libguile/array-map.c index f07fd0060..0bbc095d5 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -42,6 +42,8 @@ #include "libguile/validate.h" #include "libguile/array-map.h" + +#include /* The WHAT argument for `scm_gc_malloc ()' et al. */ @@ -624,7 +626,8 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, return SCM_BOOL_T; while (!scm_is_null (rest)) - { if (scm_is_false (scm_array_equal_p (ra0, ra1))) + { + if (scm_is_false (scm_array_equal_p (ra0, ra1))) return SCM_BOOL_F; ra0 = ra1; ra1 = scm_car (rest); @@ -635,6 +638,244 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, #undef FUNC_NAME +// Copy array descriptor with different base. +SCM +scm_i_array_rebase (SCM a, size_t base) +{ + size_t ndim = SCM_I_ARRAY_NDIM (a); + SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3); + SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a)); +// FIXME do check base + SCM_I_ARRAY_SET_BASE (b, base); + memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim); + return b; +} + +SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, + (SCM frame_rank, SCM op, SCM args), + "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n" + "of the arrays @var{args}, in unspecified order. The first\n" + "@var{frame_rank} dimensions of each @var{arg} must match.\n" + "Rank-0 cells are passed as rank-0 arrays.\n\n" + "The value returned is unspecified.\n\n" + "For example:\n" + "@lisp\n" + ";; Sort the rows of rank-2 array A.\n\n" + "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n" + "\n" + ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n" + ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n" + ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n" + "(array-for-each-cell 1 \n" + " (lambda (xy angle)\n" + " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n" + " xys angles)\n" + "@end lisp") +#define FUNC_NAME s_scm_array_for_each_cell +{ + int const N = scm_ilength (args); + int const frank = scm_to_int (frame_rank); + + // wish C had better stack support + + size_t stack_size = 0; + stack_size += N*sizeof (scm_t_array_handle); + stack_size += N*sizeof (SCM); + stack_size += N*sizeof (scm_t_array_dim *); + stack_size += N*sizeof (int); + stack_size += frank*sizeof (ssize_t); + + stack_size += N*sizeof (SCM); + stack_size += N*sizeof (SCM *); + stack_size += frank*sizeof (ssize_t); + stack_size += frank*sizeof (int); + + stack_size += N*sizeof (size_t); + char * stack = scm_gc_malloc_pointerless (stack_size, "stack"); + +#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \ + type * name = (void *)stack; \ + stack += count*sizeof (type); + + char * stack0 = stack; + AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah); + AFIC_ALLOC_ADVANCE (stack, N, SCM, args_); + AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as); + AFIC_ALLOC_ADVANCE (stack, N, int, rank); + AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s); + + AFIC_ALLOC_ADVANCE (stack, N, SCM, ai); + AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs); + AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i); + AFIC_ALLOC_ADVANCE (stack, frank, int, order); + + AFIC_ALLOC_ADVANCE(stack, N, size_t, base); + assert((stack0+stack_size==stack) && "internal error"); +#undef AFIC_ALLOC_ADVANCE + + for (int n=0; scm_is_pair(args); args=scm_cdr(args), ++n) + { + args_[n] = scm_car(args); + scm_array_get_handle(args_[n], ah+n); + as[n] = scm_array_handle_dims(ah+n); + rank[n] = scm_array_handle_rank(ah+n); + } + // checks. + char const * msg = NULL; + if (frank<0) + { + msg = "bad frame rank"; + } else + { + for (int n=0; n!=N; ++n) { + if (rank[n] #include #include -#include #include "verify.h" @@ -568,233 +567,6 @@ SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1, #undef ARRAY_FROM_GET_O -// Copy array descriptor with different base. -SCM -scm_i_array_rebase (SCM a, size_t base) -{ - size_t ndim = SCM_I_ARRAY_NDIM(a); - SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3); - SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a)); -// FIXME do check base - SCM_I_ARRAY_SET_BASE (b, base); - memcpy(SCM_I_ARRAY_DIMS(b), SCM_I_ARRAY_DIMS(a), sizeof(scm_t_array_dim)*ndim); - return b; -} - -SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, - (SCM frank_, SCM op, SCM a_), - "Apply op to each of the rank (-frank) cells of the arguments,\n" - "in unspecified order. The first frank dimensions of the\n" - "arguments must match. Rank-0 cells are passed as such.\n\n" - "The value returned is unspecified.\n\n" - "For example:\n" - "@lisp\n" - "@end lisp") -#define FUNC_NAME s_scm_array_for_each_cell -{ - int const N = scm_ilength (a_); - int const frank = scm_to_int (frank_); - - // wish C had better stack support - - size_t stack_size = 0; - stack_size += N*sizeof (scm_t_array_handle); - stack_size += N*sizeof (SCM); - stack_size += N*sizeof (scm_t_array_dim *); - stack_size += N*sizeof (int); - stack_size += frank*sizeof (ssize_t); - - stack_size += N*sizeof (SCM); - stack_size += N*sizeof (SCM *); - stack_size += frank*sizeof (ssize_t); - stack_size += frank*sizeof (int); - - stack_size += N*sizeof(size_t); - char * stack = scm_gc_malloc_pointerless (stack_size, "stack"); - -#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \ - type * name = (void *)stack; \ - stack += count*sizeof(type); - - char * stack0 = stack; - AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah); - AFIC_ALLOC_ADVANCE (stack, N, SCM, a); - AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as); - AFIC_ALLOC_ADVANCE (stack, N, int, rank); - AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s); - - AFIC_ALLOC_ADVANCE (stack, N, SCM, ai); - AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs); - AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i); - AFIC_ALLOC_ADVANCE (stack, frank, int, order); - - AFIC_ALLOC_ADVANCE(stack, N, size_t, base); - assert((stack0+stack_size==stack) && "internal error"); -#undef AFIC_ALLOC_ADVANCE - - for (int n=0; scm_is_pair(a_); a_=scm_cdr(a_), ++n) - { - a[n] = scm_car(a_); - scm_array_get_handle(a[n], ah+n); - as[n] = scm_array_handle_dims(ah+n); - rank[n] = scm_array_handle_rank(ah+n); - } - // checks. - char const * msg = NULL; - if (frank<0) - { - msg = "bad frame rank"; - } else - { - for (int n=0; n!=N; ++n) { - if (rank[n]string)) + + (pass-if-exception "dsubr" exception:wrong-num-args + (array-map! (make-array #f 5) sqrt)) + + (pass-if "rpsubr" + (let ((a (make-array 'foo 5))) + (array-map! a =) + (equal? a (make-array #t 5)))) + + (pass-if "asubr" + (let ((a (make-array 'foo 5))) + (array-map! a +) + (equal? a (make-array 0 5)))) + + ;; in Guile 1.6.4 and earlier this resulted in a segv + (pass-if "noop" + (array-map! (make-array #f 5) noop) + #t)) + + (with-test-prefix "one source" + + (pass-if-exception "closure 0" exception:wrong-num-args + (array-map! (make-array #f 5) (lambda () #f) + (make-array #f 5))) + + (pass-if "closure 1" + (let ((a (make-array #f 5))) + (array-map! a (lambda (x) 'foo) (make-array #f 5)) + (equal? a (make-array 'foo 5)))) + + (pass-if-exception "closure 2" exception:wrong-num-args + (array-map! (make-array #f 5) (lambda (x y) #f) + (make-array #f 5))) + + (pass-if "subr_1" + (let ((a (make-array #f 5))) + (array-map! a length (make-array '(x y z) 5)) + (equal? a (make-array 3 5)))) + + (pass-if-exception "subr_2" exception:wrong-num-args + (array-map! (make-array #f 5) logtest + (make-array 999 5))) + + (pass-if "subr_2o" + (let ((a (make-array #f 5))) + (array-map! a number->string (make-array 99 5)) + (equal? a (make-array "99" 5)))) + + (pass-if "dsubr" + (let ((a (make-array #f 5))) + (array-map! a sqrt (make-array 16.0 5)) + (equal? a (make-array 4.0 5)))) + + (pass-if "rpsubr" + (let ((a (make-array 'foo 5))) + (array-map! a = (make-array 0 5)) + (equal? a (make-array #t 5)))) + + (pass-if "asubr" + (let ((a (make-array 'foo 5))) + (array-map! a - (make-array 99 5)) + (equal? a (make-array -99 5)))) + + ;; in Guile 1.6.5 and 1.6.6 this was an error + (pass-if "1+" + (let ((a (make-array #f 5))) + (array-map! a 1+ (make-array 123 5)) + (equal? a (make-array 124 5)))) + + (pass-if "rank 0" + (let ((a #0(99)) + (b (make-array 0))) + (array-map! b values a) + (equal? b #0(99)))) + + (pass-if "rank 2, discontinuous" + (let ((A #2((0 1) (2 3) (4 5))) + (B #2((10 11) (12 13) (14 15))) + (C #2((20) (21) (22))) + (X (make-array 0 3 5)) + (piece (lambda (X w s) + (make-shared-array + X (lambda (i j) (list i (+ j s))) 3 w)))) + (array-map! (piece X 2 0) values A) + (array-map! (piece X 2 2) values B) + (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)))))) + + (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" + + (pass-if-exception "closure 0" exception:wrong-num-args + (array-map! (make-array #f 5) (lambda () #f) + (make-array #f 5) (make-array #f 5))) + + (pass-if-exception "closure 1" exception:wrong-num-args + (array-map! (make-array #f 5) (lambda (x) #f) + (make-array #f 5) (make-array #f 5))) + + (pass-if "closure 2" + (let ((a (make-array #f 5))) + (array-map! a (lambda (x y) 'foo) + (make-array #f 5) (make-array #f 5)) + (equal? a (make-array 'foo 5)))) + + (pass-if-exception "subr_1" exception:wrong-num-args + (array-map! (make-array #f 5) length + (make-array #f 5) (make-array #f 5))) + + (pass-if "subr_2" + (let ((a (make-array 'foo 5))) + (array-map! a logtest + (make-array 999 5) (make-array 999 5)) + (equal? a (make-array #t 5)))) + + (pass-if "subr_2o" + (let ((a (make-array #f 5))) + (array-map! a number->string + (make-array 32 5) (make-array 16 5)) + (equal? a (make-array "20" 5)))) + + (pass-if-exception "dsubr" exception:wrong-num-args + (let ((a (make-array #f 5))) + (array-map! a sqrt + (make-array 16.0 5) (make-array 16.0 5)) + (equal? a (make-array 4.0 5)))) + + (pass-if "rpsubr" + (let ((a (make-array 'foo 5))) + (array-map! a = (make-array 99 5) (make-array 77 5)) + (equal? a (make-array #f 5)))) + + (pass-if "asubr" + (let ((a (make-array 'foo 5))) + (array-map! a - (make-array 99 5) (make-array 11 5)) + (equal? a (make-array 88 5)))) + + (pass-if "+" + (let ((a (make-array #f 4))) + (array-map! a + #(1 2 3 4) #(5 6 7 8)) + (equal? a #(6 8 10 12)))) + + (pass-if "noncompact arrays 1" + (let ((a #2((0 1) (2 3))) + (c (make-array 0 2))) + (begin + (array-map! c + (array-row a 1) (array-row a 1)) + (array-equal? c #(4 6))))) + + (pass-if "noncompact arrays 2" + (let ((a #2((0 1) (2 3))) + (c (make-array 0 2))) + (begin + (array-map! c + (array-col a 1) (array-col a 1)) + (array-equal? c #(2 6))))) + + (pass-if "noncompact arrays 3" + (let ((a #2((0 1) (2 3))) + (c (make-array 0 2))) + (begin + (array-map! c + (array-col a 1) (array-row a 1)) + (array-equal? c #(3 6))))) + + (pass-if "noncompact arrays 4" + (let ((a #2((0 1) (2 3))) + (c (make-array 0 2))) + (begin + (array-map! c + (array-col a 1) (array-row a 1)) + (array-equal? c #(3 6))))) + + (pass-if "offset arrays 1" + (let ((a #2@1@-3((0 1) (2 3))) + (c (make-array 0 '(1 2) '(-3 -2)))) + (begin + (array-map! c + a a) + (array-equal? c #2@1@-3((0 2) (4 6))))))) + + ;; note that array-copy! has the opposite behavior. + + (pass-if-exception "matching behavior I" exception:shape-mismatch + (let ((a #(1 2)) + (b (make-array 0 3))) + (array-map! b values a) + (equal? b #(1 2 0)))) + + (pass-if "matching behavior II" + (let ((a #(1 2 3)) + (b (make-array 0 2))) + (array-map! b values a) + (equal? b #(1 2)))) + + ;; here both a & b are are unrollable down to the first axis, but the + ;; size mismatch limits unrolling to the last axis only. + + (pass-if "matching behavior III" + (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12)))) + (b (make-array 0 2 2 2))) + (array-map! b values a) + (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10))))))) + +;;; +;;; array-for-each +;;; + +(with-test-prefix "array-for-each" + + (with-test-prefix "1 source" + (pass-if-equal "rank 0" + '(99) + (let* ((a #0(99)) + (l '()) + (p (lambda (x) (set! l (cons x l))))) + (array-for-each p a) + l)) + + (pass-if-equal "noncompact array" + '(3 2 1 0) + (let* ((a #2((0 1) (2 3))) + (l '()) + (p (lambda (x) (set! l (cons x l))))) + (array-for-each p a) + l)) + + (pass-if-equal "vector" + '(3 2 1 0) + (let* ((a #(0 1 2 3)) + (l '()) + (p (lambda (x) (set! l (cons x l))))) + (array-for-each p a) + l)) + + (pass-if-equal "shared array" + '(3 2 1 0) + (let* ((a #2((0 1) (2 3))) + (a' (make-shared-array a + (lambda (x) + (list (quotient x 4) + (modulo x 4))) + 4)) + (l '()) + (p (lambda (x) (set! l (cons x l))))) + (array-for-each p a') + l))) + + (with-test-prefix "3 sources" + (pass-if-equal "noncompact arrays 1" + '((3 1 3) (2 0 2)) + (let* ((a #2((0 1) (2 3))) + (l '()) + (rec (lambda args (set! l (cons args l))))) + (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1)) + l)) + + (pass-if-equal "noncompact arrays 2" + '((3 3 3) (2 2 1)) + (let* ((a #2((0 1) (2 3))) + (l '()) + (rec (lambda args (set! l (cons args l))))) + (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1)) + l)) + + (pass-if-equal "noncompact arrays 3" + '((3 3 3) (2 1 1)) + (let* ((a #2((0 1) (2 3))) + (l '()) + (rec (lambda args (set! l (cons args l))))) + (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1)) + l)) + + (pass-if-equal "noncompact arrays 4" + '((3 2 3) (1 0 2)) + (let* ((a #2((0 1) (2 3))) + (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))) + + (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))))) + +;;; +;;; array-for-each-cell +;;; + +(with-test-prefix "array-for-each-cell" + + (pass-if-equal "1 argument frame rank 1" + #2((1 3 9) (2 7 8)) + (let* ((a (list->array 2 '((9 1 3) (7 8 2))))) + (array-for-each-cell 1 (lambda (a) (sort! a <)) a) + a)) + + (pass-if-equal "2 arguments frame rank 1" + #f64(8 -1) + (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8)))) + (y (f64vector 99 99))) + (array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x) + y))) diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test deleted file mode 100644 index d8241ef17..000000000 --- a/test-suite/tests/ramap.test +++ /dev/null @@ -1,509 +0,0 @@ -;;;; ramap.test --- test array mapping functions -*- scheme -*- -;;;; -;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(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)))) - -(define (array-col a j) - (make-shared-array a (lambda (i) (list i j)) - (car (array-dimensions a)))) - -;;; -;;; array-index-map! -;;; - -(with-test-prefix "array-index-map!" - - (pass-if "basic test" - (let ((nlst '())) - (array-index-map! (make-array #f '(1 1)) - (lambda (n) - (set! nlst (cons n nlst)))) - (equal? nlst '(1)))) - - (with-test-prefix "empty arrays" - - (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)) - #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)) - #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)) - #t)) - - (pass-if "rank 2" - (let ((a (make-array 0 2 2)) - (b (make-array 0 2 2))) - (array-index-map! a (lambda (i j) i)) - (array-index-map! b (lambda (i j) j)) - (and (array-equal? a #2((0 0) (1 1))) - (array-equal? b #2((0 1) (0 1))))))) - -;;; -;;; array-copy! -;;; - -(with-test-prefix "array-copy!" - - (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 empty, type 'b cases. - - ) - - ;; note that it is the opposite of array-map!. This is, unfortunately, - ;; documented in the manual. - - (pass-if "matching behavior I" - (let ((a #(1 2)) - (b (make-array 0 3))) - (array-copy! a b) - (equal? b #(1 2 0)))) - - (pass-if-exception "matching behavior II" exception:shape-mismatch - (let ((a #(1 2 3)) - (b (make-array 0 2))) - (array-copy! a b) - (equal? b #(1 2)))) - - ;; here both a & b are are unrollable down to the first axis, but the - ;; size mismatch limits unrolling to the last axis only. - - (pass-if "matching behavior III" - (let ((a #3(((1 2) (3 4)) ((5 6) (7 8)))) - (b (make-array 0 2 3 2))) - (array-copy! a b) - (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" - (let ((a #2((1 2) (3 4))) - (b (make-array 0 2 2)) - (c (make-array 0 2 2)) - (d (make-array 0 2 2)) - (e (make-array 0 2 2))) - (array-copy! a b) - (array-copy! a (transpose-array c 1 0)) - (array-copy! (transpose-array a 1 0) d) - (array-copy! (transpose-array a 1 0) (transpose-array e 1 0)) - (and (equal? a #2((1 2) (3 4))) - (equal? b #2((1 2) (3 4))) - (equal? c #2((1 3) (2 4))) - (equal? d #2((1 3) (2 4))) - (equal? e #2((1 2) (3 4)))))) - - (pass-if "rank 2, discontinuous" - (let ((A #2((0 1) (2 3) (4 5))) - (B #2((10 11) (12 13) (14 15))) - (C #2((20) (21) (22))) - (X (make-array 0 3 5)) - (piece (lambda (X w s) - (make-shared-array - X (lambda (i j) (list i (+ j s))) 3 w)))) - (array-copy! A (piece X 2 0)) - (array-copy! B (piece X 2 2)) - (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)))))) - - (pass-if "null increments, not empty" - (let ((a (make-array 0 2 2))) - (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a) - (array-equal? #2((1 1) (1 1)))))) - -;;; -;;; array-map! -;;; - -(with-test-prefix "array-map!" - - (pass-if-exception "no args" exception:wrong-num-args - (array-map!)) - - (pass-if-exception "one arg" exception:wrong-num-args - (array-map! (make-array #f 5))) - - (with-test-prefix "no sources" - - (pass-if "closure 0" - (array-map! (make-array #f 5) (lambda () #f)) - #t) - - (pass-if-exception "closure 1" exception:wrong-num-args - (array-map! (make-array #f 5) (lambda (x) #f))) - - (pass-if-exception "closure 2" exception:wrong-num-args - (array-map! (make-array #f 5) (lambda (x y) #f))) - - (pass-if-exception "subr_1" exception:wrong-num-args - (array-map! (make-array #f 5) length)) - - (pass-if-exception "subr_2" exception:wrong-num-args - (array-map! (make-array #f 5) logtest)) - - (pass-if-exception "subr_2o" exception:wrong-num-args - (array-map! (make-array #f 5) number->string)) - - (pass-if-exception "dsubr" exception:wrong-num-args - (array-map! (make-array #f 5) sqrt)) - - (pass-if "rpsubr" - (let ((a (make-array 'foo 5))) - (array-map! a =) - (equal? a (make-array #t 5)))) - - (pass-if "asubr" - (let ((a (make-array 'foo 5))) - (array-map! a +) - (equal? a (make-array 0 5)))) - - ;; in Guile 1.6.4 and earlier this resulted in a segv - (pass-if "noop" - (array-map! (make-array #f 5) noop) - #t)) - - (with-test-prefix "one source" - - (pass-if-exception "closure 0" exception:wrong-num-args - (array-map! (make-array #f 5) (lambda () #f) - (make-array #f 5))) - - (pass-if "closure 1" - (let ((a (make-array #f 5))) - (array-map! a (lambda (x) 'foo) (make-array #f 5)) - (equal? a (make-array 'foo 5)))) - - (pass-if-exception "closure 2" exception:wrong-num-args - (array-map! (make-array #f 5) (lambda (x y) #f) - (make-array #f 5))) - - (pass-if "subr_1" - (let ((a (make-array #f 5))) - (array-map! a length (make-array '(x y z) 5)) - (equal? a (make-array 3 5)))) - - (pass-if-exception "subr_2" exception:wrong-num-args - (array-map! (make-array #f 5) logtest - (make-array 999 5))) - - (pass-if "subr_2o" - (let ((a (make-array #f 5))) - (array-map! a number->string (make-array 99 5)) - (equal? a (make-array "99" 5)))) - - (pass-if "dsubr" - (let ((a (make-array #f 5))) - (array-map! a sqrt (make-array 16.0 5)) - (equal? a (make-array 4.0 5)))) - - (pass-if "rpsubr" - (let ((a (make-array 'foo 5))) - (array-map! a = (make-array 0 5)) - (equal? a (make-array #t 5)))) - - (pass-if "asubr" - (let ((a (make-array 'foo 5))) - (array-map! a - (make-array 99 5)) - (equal? a (make-array -99 5)))) - - ;; in Guile 1.6.5 and 1.6.6 this was an error - (pass-if "1+" - (let ((a (make-array #f 5))) - (array-map! a 1+ (make-array 123 5)) - (equal? a (make-array 124 5)))) - - (pass-if "rank 0" - (let ((a #0(99)) - (b (make-array 0))) - (array-map! b values a) - (equal? b #0(99)))) - - (pass-if "rank 2, discontinuous" - (let ((A #2((0 1) (2 3) (4 5))) - (B #2((10 11) (12 13) (14 15))) - (C #2((20) (21) (22))) - (X (make-array 0 3 5)) - (piece (lambda (X w s) - (make-shared-array - X (lambda (i j) (list i (+ j s))) 3 w)))) - (array-map! (piece X 2 0) values A) - (array-map! (piece X 2 2) values B) - (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)))))) - - (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" - - (pass-if-exception "closure 0" exception:wrong-num-args - (array-map! (make-array #f 5) (lambda () #f) - (make-array #f 5) (make-array #f 5))) - - (pass-if-exception "closure 1" exception:wrong-num-args - (array-map! (make-array #f 5) (lambda (x) #f) - (make-array #f 5) (make-array #f 5))) - - (pass-if "closure 2" - (let ((a (make-array #f 5))) - (array-map! a (lambda (x y) 'foo) - (make-array #f 5) (make-array #f 5)) - (equal? a (make-array 'foo 5)))) - - (pass-if-exception "subr_1" exception:wrong-num-args - (array-map! (make-array #f 5) length - (make-array #f 5) (make-array #f 5))) - - (pass-if "subr_2" - (let ((a (make-array 'foo 5))) - (array-map! a logtest - (make-array 999 5) (make-array 999 5)) - (equal? a (make-array #t 5)))) - - (pass-if "subr_2o" - (let ((a (make-array #f 5))) - (array-map! a number->string - (make-array 32 5) (make-array 16 5)) - (equal? a (make-array "20" 5)))) - - (pass-if-exception "dsubr" exception:wrong-num-args - (let ((a (make-array #f 5))) - (array-map! a sqrt - (make-array 16.0 5) (make-array 16.0 5)) - (equal? a (make-array 4.0 5)))) - - (pass-if "rpsubr" - (let ((a (make-array 'foo 5))) - (array-map! a = (make-array 99 5) (make-array 77 5)) - (equal? a (make-array #f 5)))) - - (pass-if "asubr" - (let ((a (make-array 'foo 5))) - (array-map! a - (make-array 99 5) (make-array 11 5)) - (equal? a (make-array 88 5)))) - - (pass-if "+" - (let ((a (make-array #f 4))) - (array-map! a + #(1 2 3 4) #(5 6 7 8)) - (equal? a #(6 8 10 12)))) - - (pass-if "noncompact arrays 1" - (let ((a #2((0 1) (2 3))) - (c (make-array 0 2))) - (begin - (array-map! c + (array-row a 1) (array-row a 1)) - (array-equal? c #(4 6))))) - - (pass-if "noncompact arrays 2" - (let ((a #2((0 1) (2 3))) - (c (make-array 0 2))) - (begin - (array-map! c + (array-col a 1) (array-col a 1)) - (array-equal? c #(2 6))))) - - (pass-if "noncompact arrays 3" - (let ((a #2((0 1) (2 3))) - (c (make-array 0 2))) - (begin - (array-map! c + (array-col a 1) (array-row a 1)) - (array-equal? c #(3 6))))) - - (pass-if "noncompact arrays 4" - (let ((a #2((0 1) (2 3))) - (c (make-array 0 2))) - (begin - (array-map! c + (array-col a 1) (array-row a 1)) - (array-equal? c #(3 6))))) - - (pass-if "offset arrays 1" - (let ((a #2@1@-3((0 1) (2 3))) - (c (make-array 0 '(1 2) '(-3 -2)))) - (begin - (array-map! c + a a) - (array-equal? c #2@1@-3((0 2) (4 6))))))) - - ;; note that array-copy! has the opposite behavior. - - (pass-if-exception "matching behavior I" exception:shape-mismatch - (let ((a #(1 2)) - (b (make-array 0 3))) - (array-map! b values a) - (equal? b #(1 2 0)))) - - (pass-if "matching behavior II" - (let ((a #(1 2 3)) - (b (make-array 0 2))) - (array-map! b values a) - (equal? b #(1 2)))) - - ;; here both a & b are are unrollable down to the first axis, but the - ;; size mismatch limits unrolling to the last axis only. - - (pass-if "matching behavior III" - (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12)))) - (b (make-array 0 2 2 2))) - (array-map! b values a) - (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10))))))) - -;;; -;;; array-for-each -;;; - -(with-test-prefix "array-for-each" - - (with-test-prefix "1 source" - (pass-if-equal "rank 0" - '(99) - (let* ((a #0(99)) - (l '()) - (p (lambda (x) (set! l (cons x l))))) - (array-for-each p a) - l)) - - (pass-if-equal "noncompact array" - '(3 2 1 0) - (let* ((a #2((0 1) (2 3))) - (l '()) - (p (lambda (x) (set! l (cons x l))))) - (array-for-each p a) - l)) - - (pass-if-equal "vector" - '(3 2 1 0) - (let* ((a #(0 1 2 3)) - (l '()) - (p (lambda (x) (set! l (cons x l))))) - (array-for-each p a) - l)) - - (pass-if-equal "shared array" - '(3 2 1 0) - (let* ((a #2((0 1) (2 3))) - (a' (make-shared-array a - (lambda (x) - (list (quotient x 4) - (modulo x 4))) - 4)) - (l '()) - (p (lambda (x) (set! l (cons x l))))) - (array-for-each p a') - l))) - - (with-test-prefix "3 sources" - (pass-if-equal "noncompact arrays 1" - '((3 1 3) (2 0 2)) - (let* ((a #2((0 1) (2 3))) - (l '()) - (rec (lambda args (set! l (cons args l))))) - (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1)) - l)) - - (pass-if-equal "noncompact arrays 2" - '((3 3 3) (2 2 1)) - (let* ((a #2((0 1) (2 3))) - (l '()) - (rec (lambda args (set! l (cons args l))))) - (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1)) - l)) - - (pass-if-equal "noncompact arrays 3" - '((3 3 3) (2 1 1)) - (let* ((a #2((0 1) (2 3))) - (l '()) - (rec (lambda args (set! l (cons args l))))) - (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1)) - l)) - - (pass-if-equal "noncompact arrays 4" - '((3 2 3) (1 0 2)) - (let* ((a #2((0 1) (2 3))) - (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))) - - (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))))) -- cgit v1.2.3