Commit | Line | Data |
---|---|---|
66e9b24d KR |
1 | ;;;; ramap.test --- test array mapping functions -*- scheme -*- |
2 | ;;;; | |
0d7f3a6d | 3 | ;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc. |
66e9b24d KR |
4 | ;;;; |
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 | |
53befeb7 | 8 | ;;;; version 3 of the License, or (at your option) any later version. |
66e9b24d KR |
9 | ;;;; |
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. | |
14 | ;;;; | |
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 | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
66e9b24d KR |
18 | |
19 | (define-module (test-suite test-ramap) | |
20 | #:use-module (test-suite lib)) | |
21 | ||
848431b6 DL |
22 | (define (array-row a i) |
23 | (make-shared-array a (lambda (j) (list i j)) | |
24 | (cadr (array-dimensions a)))) | |
25 | ||
26 | (define (array-col a j) | |
27 | (make-shared-array a (lambda (i) (list i j)) | |
28 | (car (array-dimensions a)))) | |
29 | ||
ab2a10e0 KR |
30 | ;;; |
31 | ;;; array-index-map! | |
32 | ;;; | |
33 | ||
34 | (with-test-prefix "array-index-map!" | |
35 | ||
36 | (pass-if (let ((nlst '())) | |
7e7e3b7f DL |
37 | (array-index-map! (make-array #f '(1 1)) |
38 | (lambda (n) | |
39 | (set! nlst (cons n nlst)))) | |
40 | (equal? nlst '(1))))) | |
41 | ||
42 | ;;; | |
43 | ;;; array-copy! | |
44 | ;;; | |
45 | ||
46 | (with-test-prefix "array-copy!" | |
47 | ||
48 | (pass-if "empty arrays" | |
49 | (let* ((b (make-array 0 2 2)) | |
50 | (c (make-shared-array b (lambda (i j) (list i j)) 0 2))) | |
51 | (array-copy! #2:0:2() c) | |
52 | (array-equal? #2:0:2() c)))) | |
ab2a10e0 | 53 | |
66e9b24d KR |
54 | ;;; |
55 | ;;; array-map! | |
56 | ;;; | |
57 | ||
58 | (with-test-prefix "array-map!" | |
59 | ||
60 | (pass-if-exception "no args" exception:wrong-num-args | |
61 | (array-map!)) | |
62 | ||
917abf70 | 63 | (pass-if-exception "one arg" exception:wrong-num-args |
66e9b24d KR |
64 | (array-map! (make-array #f 5))) |
65 | ||
917abf70 | 66 | (with-test-prefix "no sources" |
66e9b24d | 67 | |
917abf70 KR |
68 | (pass-if "closure 0" |
69 | (array-map! (make-array #f 5) (lambda () #f)) | |
70 | #t) | |
66e9b24d | 71 | |
917abf70 KR |
72 | (pass-if-exception "closure 1" exception:wrong-num-args |
73 | (array-map! (make-array #f 5) (lambda (x) #f))) | |
74 | ||
75 | (pass-if-exception "closure 2" exception:wrong-num-args | |
76 | (array-map! (make-array #f 5) (lambda (x y) #f))) | |
77 | ||
78 | (pass-if-exception "subr_1" exception:wrong-num-args | |
79 | (array-map! (make-array #f 5) length)) | |
80 | ||
81 | (pass-if-exception "subr_2" exception:wrong-num-args | |
82 | (array-map! (make-array #f 5) logtest)) | |
83 | ||
84 | (pass-if-exception "subr_2o" exception:wrong-num-args | |
85 | (array-map! (make-array #f 5) number->string)) | |
86 | ||
87 | (pass-if-exception "dsubr" exception:wrong-num-args | |
ad79736c | 88 | (array-map! (make-array #f 5) sqrt)) |
917abf70 KR |
89 | |
90 | (pass-if "rpsubr" | |
91 | (let ((a (make-array 'foo 5))) | |
92 | (array-map! a =) | |
93 | (equal? a (make-array #t 5)))) | |
94 | ||
95 | (pass-if "asubr" | |
96 | (let ((a (make-array 'foo 5))) | |
97 | (array-map! a +) | |
98 | (equal? a (make-array 0 5)))) | |
99 | ||
100 | ;; in Guile 1.6.4 and earlier this resulted in a segv | |
101 | (pass-if "noop" | |
102 | (array-map! (make-array #f 5) noop) | |
103 | #t)) | |
104 | ||
105 | (with-test-prefix "one source" | |
106 | ||
107 | (pass-if-exception "closure 0" exception:wrong-num-args | |
108 | (array-map! (make-array #f 5) (lambda () #f) | |
7e7e3b7f | 109 | (make-array #f 5))) |
917abf70 KR |
110 | |
111 | (pass-if "closure 1" | |
112 | (let ((a (make-array #f 5))) | |
113 | (array-map! a (lambda (x) 'foo) (make-array #f 5)) | |
114 | (equal? a (make-array 'foo 5)))) | |
115 | ||
116 | (pass-if-exception "closure 2" exception:wrong-num-args | |
117 | (array-map! (make-array #f 5) (lambda (x y) #f) | |
7e7e3b7f | 118 | (make-array #f 5))) |
917abf70 KR |
119 | |
120 | (pass-if "subr_1" | |
121 | (let ((a (make-array #f 5))) | |
7e7e3b7f DL |
122 | (array-map! a length (make-array '(x y z) 5)) |
123 | (equal? a (make-array 3 5)))) | |
917abf70 KR |
124 | |
125 | (pass-if-exception "subr_2" exception:wrong-num-args | |
126 | (array-map! (make-array #f 5) logtest | |
7e7e3b7f | 127 | (make-array 999 5))) |
917abf70 KR |
128 | |
129 | (pass-if "subr_2o" | |
130 | (let ((a (make-array #f 5))) | |
131 | (array-map! a number->string (make-array 99 5)) | |
132 | (equal? a (make-array "99" 5)))) | |
133 | ||
134 | (pass-if "dsubr" | |
135 | (let ((a (make-array #f 5))) | |
ad79736c | 136 | (array-map! a sqrt (make-array 16.0 5)) |
917abf70 KR |
137 | (equal? a (make-array 4.0 5)))) |
138 | ||
139 | (pass-if "rpsubr" | |
140 | (let ((a (make-array 'foo 5))) | |
141 | (array-map! a = (make-array 0 5)) | |
142 | (equal? a (make-array #t 5)))) | |
143 | ||
144 | (pass-if "asubr" | |
145 | (let ((a (make-array 'foo 5))) | |
146 | (array-map! a - (make-array 99 5)) | |
147 | (equal? a (make-array -99 5)))) | |
148 | ||
149 | ;; in Guile 1.6.5 and 1.6.6 this was an error | |
150 | (pass-if "1+" | |
151 | (let ((a (make-array #f 5))) | |
152 | (array-map! a 1+ (make-array 123 5)) | |
153 | (equal? a (make-array 124 5))))) | |
154 | ||
155 | (with-test-prefix "two sources" | |
156 | ||
157 | (pass-if-exception "closure 0" exception:wrong-num-args | |
158 | (array-map! (make-array #f 5) (lambda () #f) | |
7e7e3b7f | 159 | (make-array #f 5) (make-array #f 5))) |
917abf70 KR |
160 | |
161 | (pass-if-exception "closure 1" exception:wrong-num-args | |
162 | (array-map! (make-array #f 5) (lambda (x) #f) | |
7e7e3b7f | 163 | (make-array #f 5) (make-array #f 5))) |
917abf70 KR |
164 | |
165 | (pass-if "closure 2" | |
166 | (let ((a (make-array #f 5))) | |
7e7e3b7f DL |
167 | (array-map! a (lambda (x y) 'foo) |
168 | (make-array #f 5) (make-array #f 5)) | |
169 | (equal? a (make-array 'foo 5)))) | |
917abf70 | 170 | |
df338a22 | 171 | (pass-if-exception "subr_1" exception:wrong-num-args |
917abf70 KR |
172 | (array-map! (make-array #f 5) length |
173 | (make-array #f 5) (make-array #f 5))) | |
174 | ||
175 | (pass-if "subr_2" | |
176 | (let ((a (make-array 'foo 5))) | |
177 | (array-map! a logtest | |
178 | (make-array 999 5) (make-array 999 5)) | |
179 | (equal? a (make-array #t 5)))) | |
180 | ||
181 | (pass-if "subr_2o" | |
182 | (let ((a (make-array #f 5))) | |
183 | (array-map! a number->string | |
184 | (make-array 32 5) (make-array 16 5)) | |
185 | (equal? a (make-array "20" 5)))) | |
186 | ||
ad79736c | 187 | (pass-if-exception "dsubr" exception:wrong-num-args |
917abf70 | 188 | (let ((a (make-array #f 5))) |
ad79736c | 189 | (array-map! a sqrt |
917abf70 KR |
190 | (make-array 16.0 5) (make-array 16.0 5)) |
191 | (equal? a (make-array 4.0 5)))) | |
192 | ||
193 | (pass-if "rpsubr" | |
194 | (let ((a (make-array 'foo 5))) | |
195 | (array-map! a = (make-array 99 5) (make-array 77 5)) | |
196 | (equal? a (make-array #f 5)))) | |
197 | ||
198 | (pass-if "asubr" | |
199 | (let ((a (make-array 'foo 5))) | |
200 | (array-map! a - (make-array 99 5) (make-array 11 5)) | |
201 | (equal? a (make-array 88 5)))) | |
202 | ||
203 | (pass-if "+" | |
204 | (let ((a (make-array #f 4))) | |
205 | (array-map! a + #(1 2 3 4) #(5 6 7 8)) | |
848431b6 | 206 | (equal? a #(6 8 10 12)))) |
7e7e3b7f | 207 | |
848431b6 DL |
208 | (pass-if "noncompact arrays 1" |
209 | (let ((a #2((0 1) (2 3))) | |
7e7e3b7f | 210 | (c (make-array 0 2))) |
848431b6 DL |
211 | (begin |
212 | (array-map! c + (array-row a 1) (array-row a 1)) | |
213 | (array-equal? c #(4 6))))) | |
7e7e3b7f | 214 | |
848431b6 DL |
215 | (pass-if "noncompact arrays 2" |
216 | (let ((a #2((0 1) (2 3))) | |
7e7e3b7f | 217 | (c (make-array 0 2))) |
848431b6 DL |
218 | (begin |
219 | (array-map! c + (array-col a 1) (array-col a 1)) | |
220 | (array-equal? c #(2 6))))) | |
7e7e3b7f | 221 | |
848431b6 DL |
222 | (pass-if "noncompact arrays 3" |
223 | (let ((a #2((0 1) (2 3))) | |
7e7e3b7f | 224 | (c (make-array 0 2))) |
848431b6 DL |
225 | (begin |
226 | (array-map! c + (array-col a 1) (array-row a 1)) | |
227 | (array-equal? c #(3 6))))) | |
7e7e3b7f | 228 | |
848431b6 DL |
229 | (pass-if "noncompact arrays 4" |
230 | (let ((a #2((0 1) (2 3))) | |
7e7e3b7f | 231 | (c (make-array 0 2))) |
848431b6 DL |
232 | (begin |
233 | (array-map! c + (array-col a 1) (array-row a 1)) | |
234 | (array-equal? c #(3 6))))))) | |
235 | ||
236 | ;;; | |
237 | ;;; array-for-each | |
238 | ;;; | |
239 | ||
240 | (with-test-prefix "array-for-each" | |
241 | ||
3220b080 LC |
242 | (with-test-prefix "1 source" |
243 | (pass-if-equal "noncompact array" | |
244 | '(3 2 1 0) | |
245 | (let* ((a #2((0 1) (2 3))) | |
246 | (l '()) | |
247 | (p (lambda (x) (set! l (cons x l))))) | |
248 | (array-for-each p a) | |
249 | l)) | |
250 | ||
251 | (pass-if-equal "vector" | |
252 | '(3 2 1 0) | |
253 | (let* ((a #(0 1 2 3)) | |
254 | (l '()) | |
255 | (p (lambda (x) (set! l (cons x l))))) | |
256 | (array-for-each p a) | |
257 | l)) | |
258 | ||
259 | (pass-if-equal "shared array" | |
260 | '(3 2 1 0) | |
261 | (let* ((a #2((0 1) (2 3))) | |
262 | (a' (make-shared-array a | |
263 | (lambda (x) | |
264 | (list (quotient x 4) | |
265 | (modulo x 4))) | |
266 | 4)) | |
267 | (l '()) | |
268 | (p (lambda (x) (set! l (cons x l))))) | |
269 | (array-for-each p a') | |
270 | l))) | |
271 | ||
848431b6 | 272 | (with-test-prefix "3 sources" |
0d7f3a6d LC |
273 | (pass-if-equal "noncompact arrays 1" |
274 | '((3 3 3) (2 2 2)) | |
848431b6 DL |
275 | (let* ((a #2((0 1) (2 3))) |
276 | (l '()) | |
277 | (rec (lambda args (set! l (cons args l))))) | |
278 | (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1)) | |
0d7f3a6d LC |
279 | l)) |
280 | ||
281 | (pass-if-equal "noncompact arrays 2" | |
282 | '((3 3 3) (2 2 1)) | |
848431b6 DL |
283 | (let* ((a #2((0 1) (2 3))) |
284 | (l '()) | |
285 | (rec (lambda args (set! l (cons args l))))) | |
286 | (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1)) | |
0d7f3a6d LC |
287 | l)) |
288 | ||
289 | (pass-if-equal "noncompact arrays 3" | |
290 | '((3 3 3) (2 1 1)) | |
848431b6 DL |
291 | (let* ((a #2((0 1) (2 3))) |
292 | (l '()) | |
293 | (rec (lambda args (set! l (cons args l))))) | |
294 | (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1)) | |
0d7f3a6d LC |
295 | l)) |
296 | ||
297 | (pass-if-equal "noncompact arrays 4" | |
298 | '((3 2 3) (1 0 2)) | |
848431b6 DL |
299 | (let* ((a #2((0 1) (2 3))) |
300 | (l '()) | |
301 | (rec (lambda args (set! l (cons args l))))) | |
302 | (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1)) | |
0d7f3a6d | 303 | l)))) |