1 ;;;; ramap.test --- test array mapping functions -*- scheme -*-
3 ;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (test-suite test-ramap)
20 #:use-module (test-suite lib))
22 (define exception:shape-mismatch
23 (cons 'misc-error ".*shape mismatch.*"))
25 (define (array-row a i)
26 (make-shared-array a (lambda (j) (list i j))
27 (cadr (array-dimensions a))))
29 (define (array-col a j)
30 (make-shared-array a (lambda (i) (list i j))
31 (car (array-dimensions a))))
37 (with-test-prefix "array-index-map!"
41 (array-index-map! (make-array #f '(1 1))
43 (set! nlst (cons n nlst))))
46 (with-test-prefix "empty arrays"
48 (pass-if "all axes empty"
49 (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
50 (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
51 (array-index-map! (make-typed-array #t 0 0 0) (const 0))
54 (pass-if "last axis empty"
55 (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
56 (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
57 (array-index-map! (make-typed-array #t 0 2 0) (const 0))
60 ; the 'f64 cases fail in 2.0.9 with out-of-range.
61 (pass-if "axis empty, other than last"
62 (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
63 (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
64 (array-index-map! (make-typed-array #t 0 0 2) (const 0))
68 (let ((a (make-array 0 2 2))
69 (b (make-array 0 2 2)))
70 (array-index-map! a (lambda (i j) i))
71 (array-index-map! b (lambda (i j) j))
72 (and (array-equal? a #2((0 0) (1 1)))
73 (array-equal? b #2((0 1) (0 1)))))))
79 (with-test-prefix "array-copy!"
81 (with-test-prefix "empty arrays"
83 (pass-if "empty other than last, #t"
84 (let* ((b (make-array 0 2 2))
85 (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
86 (array-copy! #2:0:2() c)
87 (array-equal? #2:0:2() c)))
89 (pass-if "empty other than last, 'f64"
90 (let* ((b (make-typed-array 'f64 0 2 2))
91 (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
92 (array-copy! #2:0:2() c)
93 (array-equal? #2f64:0:2() c)))
95 ;; FIXME add empty, type 'b cases.
99 ;; note that it is the opposite of array-map!. This is, unfortunately,
100 ;; documented in the manual.
102 (pass-if "matching behavior I"
104 (b (make-array 0 3)))
106 (equal? b #(1 2 0))))
108 (pass-if-exception "matching behavior II" exception:shape-mismatch
110 (b (make-array 0 2)))
114 ;; here both a & b are are unrollable down to the first axis, but the
115 ;; size mismatch limits unrolling to the last axis only.
117 (pass-if "matching behavior III"
118 (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
119 (b (make-array 0 2 3 2)))
121 (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
130 (let* ((a #2((1 2) (3 4)))
131 (b (make-shared-array a (lambda (j) (list 1 j)) 2))
132 (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
134 (e (make-array 0 2)))
137 (and (equal? d #(3 4))
141 (let ((a #2((1 2) (3 4)))
142 (b (make-array 0 2 2))
143 (c (make-array 0 2 2))
144 (d (make-array 0 2 2))
145 (e (make-array 0 2 2)))
147 (array-copy! a (transpose-array c 1 0))
148 (array-copy! (transpose-array a 1 0) d)
149 (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
150 (and (equal? a #2((1 2) (3 4)))
151 (equal? b #2((1 2) (3 4)))
152 (equal? c #2((1 3) (2 4)))
153 (equal? d #2((1 3) (2 4)))
154 (equal? e #2((1 2) (3 4))))))
156 (pass-if "rank 2, discontinuous"
157 (let ((A #2((0 1) (2 3) (4 5)))
158 (B #2((10 11) (12 13) (14 15)))
159 (C #2((20) (21) (22)))
160 (X (make-array 0 3 5))
161 (piece (lambda (X w s)
163 X (lambda (i j) (list i (+ j s))) 3 w))))
164 (array-copy! A (piece X 2 0))
165 (array-copy! B (piece X 2 2))
166 (array-copy! C (piece X 1 4))
167 (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
169 (pass-if "null increments, not empty"
170 (let ((a (make-array 0 2 2)))
171 (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
172 (array-equal? #2((1 1) (1 1))))))
178 (with-test-prefix "array-map!"
180 (pass-if-exception "no args" exception:wrong-num-args
183 (pass-if-exception "one arg" exception:wrong-num-args
184 (array-map! (make-array #f 5)))
186 (with-test-prefix "no sources"
189 (array-map! (make-array #f 5) (lambda () #f))
192 (pass-if-exception "closure 1" exception:wrong-num-args
193 (array-map! (make-array #f 5) (lambda (x) #f)))
195 (pass-if-exception "closure 2" exception:wrong-num-args
196 (array-map! (make-array #f 5) (lambda (x y) #f)))
198 (pass-if-exception "subr_1" exception:wrong-num-args
199 (array-map! (make-array #f 5) length))
201 (pass-if-exception "subr_2" exception:wrong-num-args
202 (array-map! (make-array #f 5) logtest))
204 (pass-if-exception "subr_2o" exception:wrong-num-args
205 (array-map! (make-array #f 5) number->string))
207 (pass-if-exception "dsubr" exception:wrong-num-args
208 (array-map! (make-array #f 5) sqrt))
211 (let ((a (make-array 'foo 5)))
213 (equal? a (make-array #t 5))))
216 (let ((a (make-array 'foo 5)))
218 (equal? a (make-array 0 5))))
220 ;; in Guile 1.6.4 and earlier this resulted in a segv
222 (array-map! (make-array #f 5) noop)
225 (with-test-prefix "one source"
227 (pass-if-exception "closure 0" exception:wrong-num-args
228 (array-map! (make-array #f 5) (lambda () #f)
232 (let ((a (make-array #f 5)))
233 (array-map! a (lambda (x) 'foo) (make-array #f 5))
234 (equal? a (make-array 'foo 5))))
236 (pass-if-exception "closure 2" exception:wrong-num-args
237 (array-map! (make-array #f 5) (lambda (x y) #f)
241 (let ((a (make-array #f 5)))
242 (array-map! a length (make-array '(x y z) 5))
243 (equal? a (make-array 3 5))))
245 (pass-if-exception "subr_2" exception:wrong-num-args
246 (array-map! (make-array #f 5) logtest
250 (let ((a (make-array #f 5)))
251 (array-map! a number->string (make-array 99 5))
252 (equal? a (make-array "99" 5))))
255 (let ((a (make-array #f 5)))
256 (array-map! a sqrt (make-array 16.0 5))
257 (equal? a (make-array 4.0 5))))
260 (let ((a (make-array 'foo 5)))
261 (array-map! a = (make-array 0 5))
262 (equal? a (make-array #t 5))))
265 (let ((a (make-array 'foo 5)))
266 (array-map! a - (make-array 99 5))
267 (equal? a (make-array -99 5))))
269 ;; in Guile 1.6.5 and 1.6.6 this was an error
271 (let ((a (make-array #f 5)))
272 (array-map! a 1+ (make-array 123 5))
273 (equal? a (make-array 124 5))))
278 (array-map! b values a)
281 (pass-if "rank 2, discontinuous"
282 (let ((A #2((0 1) (2 3) (4 5)))
283 (B #2((10 11) (12 13) (14 15)))
284 (C #2((20) (21) (22)))
285 (X (make-array 0 3 5))
286 (piece (lambda (X w s)
288 X (lambda (i j) (list i (+ j s))) 3 w))))
289 (array-map! (piece X 2 0) values A)
290 (array-map! (piece X 2 2) values B)
291 (array-map! (piece X 1 4) values C)
292 (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
294 (pass-if "null increments, not empty"
295 (let ((a (make-array 0 2 2)))
296 (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
297 (array-equal? a #2((1 1) (1 1))))))
299 (with-test-prefix "two sources"
301 (pass-if-exception "closure 0" exception:wrong-num-args
302 (array-map! (make-array #f 5) (lambda () #f)
303 (make-array #f 5) (make-array #f 5)))
305 (pass-if-exception "closure 1" exception:wrong-num-args
306 (array-map! (make-array #f 5) (lambda (x) #f)
307 (make-array #f 5) (make-array #f 5)))
310 (let ((a (make-array #f 5)))
311 (array-map! a (lambda (x y) 'foo)
312 (make-array #f 5) (make-array #f 5))
313 (equal? a (make-array 'foo 5))))
315 (pass-if-exception "subr_1" exception:wrong-num-args
316 (array-map! (make-array #f 5) length
317 (make-array #f 5) (make-array #f 5)))
320 (let ((a (make-array 'foo 5)))
321 (array-map! a logtest
322 (make-array 999 5) (make-array 999 5))
323 (equal? a (make-array #t 5))))
326 (let ((a (make-array #f 5)))
327 (array-map! a number->string
328 (make-array 32 5) (make-array 16 5))
329 (equal? a (make-array "20" 5))))
331 (pass-if-exception "dsubr" exception:wrong-num-args
332 (let ((a (make-array #f 5)))
334 (make-array 16.0 5) (make-array 16.0 5))
335 (equal? a (make-array 4.0 5))))
338 (let ((a (make-array 'foo 5)))
339 (array-map! a = (make-array 99 5) (make-array 77 5))
340 (equal? a (make-array #f 5))))
343 (let ((a (make-array 'foo 5)))
344 (array-map! a - (make-array 99 5) (make-array 11 5))
345 (equal? a (make-array 88 5))))
348 (let ((a (make-array #f 4)))
349 (array-map! a + #(1 2 3 4) #(5 6 7 8))
350 (equal? a #(6 8 10 12))))
352 (pass-if "noncompact arrays 1"
353 (let ((a #2((0 1) (2 3)))
354 (c (make-array 0 2)))
356 (array-map! c + (array-row a 1) (array-row a 1))
357 (array-equal? c #(4 6)))))
359 (pass-if "noncompact arrays 2"
360 (let ((a #2((0 1) (2 3)))
361 (c (make-array 0 2)))
363 (array-map! c + (array-col a 1) (array-col a 1))
364 (array-equal? c #(2 6)))))
366 (pass-if "noncompact arrays 3"
367 (let ((a #2((0 1) (2 3)))
368 (c (make-array 0 2)))
370 (array-map! c + (array-col a 1) (array-row a 1))
371 (array-equal? c #(3 6)))))
373 (pass-if "noncompact arrays 4"
374 (let ((a #2((0 1) (2 3)))
375 (c (make-array 0 2)))
377 (array-map! c + (array-col a 1) (array-row a 1))
378 (array-equal? c #(3 6)))))
380 (pass-if "offset arrays 1"
381 (let ((a #2@1@-3((0 1) (2 3)))
382 (c (make-array 0 '(1 2) '(-3 -2))))
385 (array-equal? c #2@1@-3((0 2) (4 6)))))))
387 ;; note that array-copy! has the opposite behavior.
389 (pass-if-exception "matching behavior I" exception:shape-mismatch
391 (b (make-array 0 3)))
392 (array-map! b values a)
393 (equal? b #(1 2 0))))
395 (pass-if "matching behavior II"
397 (b (make-array 0 2)))
398 (array-map! b values a)
401 ;; here both a & b are are unrollable down to the first axis, but the
402 ;; size mismatch limits unrolling to the last axis only.
404 (pass-if "matching behavior III"
405 (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
406 (b (make-array 0 2 2 2)))
407 (array-map! b values a)
408 (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
414 (with-test-prefix "array-for-each"
416 (with-test-prefix "1 source"
417 (pass-if-equal "rank 0"
421 (p (lambda (x) (set! l (cons x l)))))
425 (pass-if-equal "noncompact array"
427 (let* ((a #2((0 1) (2 3)))
429 (p (lambda (x) (set! l (cons x l)))))
433 (pass-if-equal "vector"
435 (let* ((a #(0 1 2 3))
437 (p (lambda (x) (set! l (cons x l)))))
441 (pass-if-equal "shared array"
443 (let* ((a #2((0 1) (2 3)))
444 (a' (make-shared-array a
450 (p (lambda (x) (set! l (cons x l)))))
451 (array-for-each p a')
454 (with-test-prefix "3 sources"
455 (pass-if-equal "noncompact arrays 1"
457 (let* ((a #2((0 1) (2 3)))
459 (rec (lambda args (set! l (cons args l)))))
460 (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
463 (pass-if-equal "noncompact arrays 2"
465 (let* ((a #2((0 1) (2 3)))
467 (rec (lambda args (set! l (cons args l)))))
468 (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
471 (pass-if-equal "noncompact arrays 3"
473 (let* ((a #2((0 1) (2 3)))
475 (rec (lambda args (set! l (cons args l)))))
476 (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
479 (pass-if-equal "noncompact arrays 4"
481 (let* ((a #2((0 1) (2 3)))
483 (rec (lambda args (set! l (cons args l)))))
484 (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
487 (with-test-prefix "empty arrays"
489 (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
491 (b (make-array 0 2 2))
492 (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
493 (array-for-each (lambda (c) (set! a (cons c a))) c)
496 (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
498 (b (make-typed-array 'f64 0 2 2))
499 (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
500 (array-for-each (lambda (c) (set! a (cons c a))) c)
503 ;; FIXME add type 'b cases.
505 (pass-if-exception "empty arrays shape check" exception:shape-mismatch
507 (b (make-typed-array 'f64 0 0 2))
508 (c (make-typed-array 'f64 0 2 0)))
509 (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))