HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge commit 'a7bbba05838cabe2294f498e7008e1c51db6d664'
[bpt/guile.git] / test-suite / tests / arrays.test
CommitLineData
d7473131 1;;;; arrays.test --- tests guile's uniform arrays -*- scheme -*-
3ffd1ba9 2;;;;
fb7dd001 3;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
3ffd1ba9
AW		 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
8;;;; version 3 of the License, or (at your option) any later version.
69843ac1 9;;;;
3ffd1ba9
AW		 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.
69843ac1 14;;;;
3ffd1ba9
AW		 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
18
e275b8a2
AW		 19(define-module (test-suite test-arrays)
20 #:use-module ((system base compile) #:select (compile))
21 #:use-module (test-suite lib)
22 #:use-module (srfi srfi-4)
23 #:use-module (srfi srfi-4 gnu))
3ffd1ba9 24
e275b8a2
AW		 25;;;
26;;; array?
27;;;
28
29(define exception:wrong-num-indices
30 (cons 'misc-error "^wrong number of indices.*"))
31
32(define exception:length-non-negative
33 (cons 'read-error ".*array length must be non-negative.*"))
34
35
e275b8a2
AW		 36(with-test-prefix "array?"
37
38 (let ((bool (make-typed-array 'b #t '(5 6)))
39 (char (make-typed-array 'a #\a '(5 6)))
40 (byte (make-typed-array 'u8 0 '(5 6)))
41 (short (make-typed-array 's16 0 '(5 6)))
42 (ulong (make-typed-array 'u32 0 '(5 6)))
43 (long (make-typed-array 's32 0 '(5 6)))
44 (longlong (make-typed-array 's64 0 '(5 6)))
45 (float (make-typed-array 'f32 0 '(5 6)))
46 (double (make-typed-array 'f64 0 '(5 6)))
47 (complex (make-typed-array 'c64 0 '(5 6)))
48 (scm (make-typed-array #t 0 '(5 6))))
49
50 (with-test-prefix "is bool"
51 (pass-if (eq? #t (typed-array? bool 'b)))
52 (pass-if (eq? #f (typed-array? char 'b)))
53 (pass-if (eq? #f (typed-array? byte 'b)))
54 (pass-if (eq? #f (typed-array? short 'b)))
55 (pass-if (eq? #f (typed-array? ulong 'b)))
56 (pass-if (eq? #f (typed-array? long 'b)))
57 (pass-if (eq? #f (typed-array? longlong 'b)))
58 (pass-if (eq? #f (typed-array? float 'b)))
59 (pass-if (eq? #f (typed-array? double 'b)))
60 (pass-if (eq? #f (typed-array? complex 'b)))
61 (pass-if (eq? #f (typed-array? scm 'b))))
62
63 (with-test-prefix "is char"
64 (pass-if (eq? #f (typed-array? bool 'a)))
65 (pass-if (eq? #t (typed-array? char 'a)))
66 (pass-if (eq? #f (typed-array? byte 'a)))
67 (pass-if (eq? #f (typed-array? short 'a)))
68 (pass-if (eq? #f (typed-array? ulong 'a)))
69 (pass-if (eq? #f (typed-array? long 'a)))
70 (pass-if (eq? #f (typed-array? longlong 'a)))
71 (pass-if (eq? #f (typed-array? float 'a)))
72 (pass-if (eq? #f (typed-array? double 'a)))
73 (pass-if (eq? #f (typed-array? complex 'a)))
74 (pass-if (eq? #f (typed-array? scm 'a))))
75
76 (with-test-prefix "is byte"
77 (pass-if (eq? #f (typed-array? bool 'u8)))
78 (pass-if (eq? #f (typed-array? char 'u8)))
79 (pass-if (eq? #t (typed-array? byte 'u8)))
80 (pass-if (eq? #f (typed-array? short 'u8)))
81 (pass-if (eq? #f (typed-array? ulong 'u8)))
82 (pass-if (eq? #f (typed-array? long 'u8)))
83 (pass-if (eq? #f (typed-array? longlong 'u8)))
84 (pass-if (eq? #f (typed-array? float 'u8)))
85 (pass-if (eq? #f (typed-array? double 'u8)))
86 (pass-if (eq? #f (typed-array? complex 'u8)))
87 (pass-if (eq? #f (typed-array? scm 'u8))))
88
89 (with-test-prefix "is short"
90 (pass-if (eq? #f (typed-array? bool 's16)))
91 (pass-if (eq? #f (typed-array? char 's16)))
92 (pass-if (eq? #f (typed-array? byte 's16)))
93 (pass-if (eq? #t (typed-array? short 's16)))
94 (pass-if (eq? #f (typed-array? ulong 's16)))
95 (pass-if (eq? #f (typed-array? long 's16)))
96 (pass-if (eq? #f (typed-array? longlong 's16)))
97 (pass-if (eq? #f (typed-array? float 's16)))
98 (pass-if (eq? #f (typed-array? double 's16)))
99 (pass-if (eq? #f (typed-array? complex 's16)))
100 (pass-if (eq? #f (typed-array? scm 's16))))
101
102 (with-test-prefix "is ulong"
103 (pass-if (eq? #f (typed-array? bool 'u32)))
104 (pass-if (eq? #f (typed-array? char 'u32)))
105 (pass-if (eq? #f (typed-array? byte 'u32)))
106 (pass-if (eq? #f (typed-array? short 'u32)))
107 (pass-if (eq? #t (typed-array? ulong 'u32)))
108 (pass-if (eq? #f (typed-array? long 'u32)))
109 (pass-if (eq? #f (typed-array? longlong 'u32)))
110 (pass-if (eq? #f (typed-array? float 'u32)))
111 (pass-if (eq? #f (typed-array? double 'u32)))
112 (pass-if (eq? #f (typed-array? complex 'u32)))
113 (pass-if (eq? #f (typed-array? scm 'u32))))
114
115 (with-test-prefix "is long"
116 (pass-if (eq? #f (typed-array? bool 's32)))
117 (pass-if (eq? #f (typed-array? char 's32)))
118 (pass-if (eq? #f (typed-array? byte 's32)))
119 (pass-if (eq? #f (typed-array? short 's32)))
120 (pass-if (eq? #f (typed-array? ulong 's32)))
121 (pass-if (eq? #t (typed-array? long 's32)))
122 (pass-if (eq? #f (typed-array? longlong 's32)))
123 (pass-if (eq? #f (typed-array? float 's32)))
124 (pass-if (eq? #f (typed-array? double 's32)))
125 (pass-if (eq? #f (typed-array? complex 's32)))
126 (pass-if (eq? #f (typed-array? scm 's32))))
127
128 (with-test-prefix "is long long"
129 (pass-if (eq? #f (typed-array? bool 's64)))
130 (pass-if (eq? #f (typed-array? char 's64)))
131 (pass-if (eq? #f (typed-array? byte 's64)))
132 (pass-if (eq? #f (typed-array? short 's64)))
133 (pass-if (eq? #f (typed-array? ulong 's64)))
134 (pass-if (eq? #f (typed-array? long 's64)))
135 (pass-if (eq? #t (typed-array? longlong 's64)))
136 (pass-if (eq? #f (typed-array? float 's64)))
137 (pass-if (eq? #f (typed-array? double 's64)))
138 (pass-if (eq? #f (typed-array? complex 's64)))
139 (pass-if (eq? #f (typed-array? scm 's64))))
140
141 (with-test-prefix "is float"
142 (pass-if (eq? #f (typed-array? bool 'f32)))
143 (pass-if (eq? #f (typed-array? char 'f32)))
144 (pass-if (eq? #f (typed-array? byte 'f32)))
145 (pass-if (eq? #f (typed-array? short 'f32)))
146 (pass-if (eq? #f (typed-array? ulong 'f32)))
147 (pass-if (eq? #f (typed-array? long 'f32)))
148 (pass-if (eq? #f (typed-array? longlong 'f32)))
149 (pass-if (eq? #t (typed-array? float 'f32)))
150 (pass-if (eq? #f (typed-array? double 'f32)))
151 (pass-if (eq? #f (typed-array? complex 'f32)))
152 (pass-if (eq? #f (typed-array? scm 'f32))))
153
154 (with-test-prefix "is double"
155 (pass-if (eq? #f (typed-array? bool 'f64)))
156 (pass-if (eq? #f (typed-array? char 'f64)))
157 (pass-if (eq? #f (typed-array? byte 'f64)))
158 (pass-if (eq? #f (typed-array? short 'f64)))
159 (pass-if (eq? #f (typed-array? ulong 'f64)))
160 (pass-if (eq? #f (typed-array? long 'f64)))
161 (pass-if (eq? #f (typed-array? longlong 'f64)))
162 (pass-if (eq? #f (typed-array? float 'f64)))
163 (pass-if (eq? #t (typed-array? double 'f64)))
164 (pass-if (eq? #f (typed-array? complex 'f64)))
165 (pass-if (eq? #f (typed-array? scm 'f64))))
166
167 (with-test-prefix "is complex"
168 (pass-if (eq? #f (typed-array? bool 'c64)))
169 (pass-if (eq? #f (typed-array? char 'c64)))
170 (pass-if (eq? #f (typed-array? byte 'c64)))
171 (pass-if (eq? #f (typed-array? short 'c64)))
172 (pass-if (eq? #f (typed-array? ulong 'c64)))
173 (pass-if (eq? #f (typed-array? long 'c64)))
174 (pass-if (eq? #f (typed-array? longlong 'c64)))
175 (pass-if (eq? #f (typed-array? float 'c64)))
176 (pass-if (eq? #f (typed-array? double 'c64)))
177 (pass-if (eq? #t (typed-array? complex 'c64)))
178 (pass-if (eq? #f (typed-array? scm 'c64))))
179
180 (with-test-prefix "is scm"
181 (pass-if (eq? #f (typed-array? bool #t)))
182 (pass-if (eq? #f (typed-array? char #t)))
183 (pass-if (eq? #f (typed-array? byte #t)))
184 (pass-if (eq? #f (typed-array? short #t)))
185 (pass-if (eq? #f (typed-array? ulong #t)))
186 (pass-if (eq? #f (typed-array? long #t)))
187 (pass-if (eq? #f (typed-array? longlong #t)))
188 (pass-if (eq? #f (typed-array? float #t)))
189 (pass-if (eq? #f (typed-array? double #t)))
190 (pass-if (eq? #f (typed-array? complex #t)))
d41d5bf0
DL		 191 (pass-if (eq? #t (typed-array? scm #t))))
192
193 (with-test-prefix "typed-array? returns #f"
194 (pass-if (eq? #f (typed-array? '(1 2 3) 'c64)))
195 (pass-if (eq? #f (typed-array? '(1 2 3) #t)))
196 (pass-if (eq? #f (typed-array? 99 'c64)))
197 (pass-if (eq? #f (typed-array? 99 #t))))))
e275b8a2
AW		 198
199;;;
200;;; array-equal?
201;;;
202
ea342aa6 203(with-test-prefix/c&e "array-equal?"
e275b8a2
AW		 204
205 (pass-if "#s16(...)"
206 (array-equal? #s16(1 2 3) #s16(1 2 3))))
207
69843ac1
DL		 208;;;
209;;; make-shared-array
210;;;
211
212(define exception:mapping-out-of-range
213 (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
214
ea342aa6 215(with-test-prefix/c&e "make-shared-array"
69843ac1
DL		 216
217 ;; this failed in guile 1.8.0
218 (pass-if "vector unchanged"
219 (let* ((a (make-array #f '(0 7)))
220 (s (make-shared-array a list '(0 7))))
221 (array-equal? a s)))
222
223 (pass-if-exception "vector, high too big" exception:mapping-out-of-range
224 (let* ((a (make-array #f '(0 7))))
225 (make-shared-array a list '(0 8))))
226
227 (pass-if-exception "vector, low too big" exception:out-of-range
228 (let* ((a (make-array #f '(0 7))))
229 (make-shared-array a list '(-1 7))))
230
231 (pass-if "truncate columns"
232 (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
233 #2((a b) (d e) (g h))))
234
235 (pass-if "pick one column"
236 (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
237 (lambda (i) (list i 2))
238 '(0 2))
239 #(c f i)))
240
241 (pass-if "diagonal"
242 (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
243 (lambda (i) (list i i))
244 '(0 2))
245 #(a e i)))
246
247 ;; this failed in guile 1.8.0
248 (pass-if "2 dims from 1 dim"
249 (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
250 (lambda (i j) (list (+ (* i 3) j)))
251 4 3)
252 #2((a b c) (d e f) (g h i) (j k l))))
253
254 (pass-if "reverse columns"
255 (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
256 (lambda (i j) (list i (- 2 j)))
257 3 3)
258 #2((c b a) (f e d) (i h g))))
259
260 (pass-if "fixed offset, 0 based becomes 1 based"
261 (let* ((x #2((a b c) (d e f) (g h i)))
262 (y (make-shared-array x
263 (lambda (i j) (list (1- i) (1- j)))
264 '(1 3) '(1 3))))
265 (and (eq? (array-ref x 0 0) 'a)
266 (eq? (array-ref y 1 1) 'a))))
267
268 ;; this failed in guile 1.8.0
269 (pass-if "stride every third element"
270 (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
271 (lambda (i) (list (* i 3)))
272 4)
273 #1(a d g j)))
274
275 (pass-if "shared of shared"
276 (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
277 (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
278 (s2 (make-shared-array s1 list '(1 2))))
279 (and (eqv? 5 (array-ref s2 1))
280 (eqv? 8 (array-ref s2 2))))))
281
c545f716
DL		 282;;;
283;;; array-contents
284;;;
285
ea342aa6 286(define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2))
c545f716 287
ea342aa6 288(with-test-prefix/c&e "array-contents"
c545f716
DL		 289
290 (pass-if "simple vector"
291 (let* ((a (make-array 0 4)))
292 (eq? a (array-contents a))))
293
294 (pass-if "offset vector"
295 (let* ((a (make-array 0 '(1 4))))
296 (array-copy! #(1 2 3 4) (array-contents a))
297 (array-equal? #1@1(1 2 3 4) a)))
298
299 (pass-if "offset vector, strict"
300 (let* ((a (make-array 0 '(1 4))))
301 (array-copy! #(1 2 3 4) (array-contents a #t))
302 (array-equal? #1@1(1 2 3 4) a)))
303
304 (pass-if "stepped vector"
305 (let* ((a (make-array 0 4)))
306 (array-copy! #(99 66) (array-contents (every-two a)))
307 (array-equal? #(99 0 66 0) a)))
308
309 ;; this failed in 2.0.9.
310 (pass-if "stepped vector, strict"
311 (let* ((a (make-array 0 4)))
312 (not (array-contents (every-two a) #t))))
313
314 (pass-if "plain rank 2 array"
315 (let* ((a (make-array 0 2 2)))
316 (array-copy! #(1 2 3 4) (array-contents a #t))
317 (array-equal? #2((1 2) (3 4)) a)))
318
319 (pass-if "offset rank 2 array"
320 (let* ((a (make-array 0 '(1 2) '(1 2))))
321 (array-copy! #(1 2 3 4) (array-contents a #t))
322 (array-equal? #2@1@1((1 2) (3 4)) a)))
323
324 (pass-if "transposed rank 2 array"
325 (let* ((a (make-array 0 4 4)))
326 (not (array-contents (transpose-array a 1 0) #t))))
327
2c1ccb02
DL		 328 ;; This is a consequence of (array-contents? a #t) => #t.
329 (pass-if "empty array"
330 (let ((a (make-typed-array 'f64 2 0 0)))
331 (f64vector? (array-contents a))))
332
c545f716
DL		 333 (pass-if "broadcast vector I"
334 (let* ((a (make-array 0 4))
335 (b (make-shared-array a (lambda (i j k) (list k)) 1 1 4)))
336 (array-copy! #(1 2 3 4) (array-contents b #t))
337 (array-equal? #(1 2 3 4) a)))
338
339 (pass-if "broadcast vector II"
340 (let* ((a (make-array 0 4))
341 (b (make-shared-array a (lambda (i j k) (list k)) 2 1 4)))
342 (not (array-contents b))))
343
344 ;; FIXME maybe this should be allowed.
ea342aa6
DL		 345 ;; (pass-if "broadcast vector -> empty"
346 ;; (let* ((a (make-array 0 4))
347 ;; (b (make-shared-array a (lambda (i j k) (list k)) 0 1 4)))
348 ;; (if #f #f)))
35f45ed6
DL		 349
350 (pass-if "broadcast 2-rank I"
351 (let* ((a #2((1 2 3) (4 5 6)))
352 (b (make-shared-array a (lambda (i j) (list 0 j)) 2 3)))
353 (not (array-contents b))))
354
ea342aa6 355 (pass-if "broadcast 2-rank II"
35f45ed6
DL		 356 (let* ((a #2((1 2 3) (4 5 6)))
357 (b (make-shared-array a (lambda (i j) (list i 0)) 2 3)))
ea342aa6
DL		 358 (not (array-contents b))))
359
360 (pass-if "literal array"
361 (not (not (array-contents #2((1 2 3) (4 5 6)))))))
362
c545f716 363
69843ac1
DL		 364;;;
365;;; shared-array-root
366;;;
367
ea342aa6
DL		 368(define amap1 (lambda (i) (list (* 2 i))))
369(define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
69843ac1 370
ea342aa6 371(with-test-prefix/c&e "shared-array-root"
69843ac1
DL		 372
373 (pass-if "plain vector"
374 (let* ((a (make-vector 4 0))
375 (b (make-shared-array a amap1 2)))
376 (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
377
378 (pass-if "plain array rank 2"
379 (let* ((a (make-array 0 4 4))
380 (b (make-shared-array a amap2 2 2)))
381 (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
382
383 (pass-if "uniform array rank 2"
384 (let* ((a (make-typed-array 'c64 0 4 4))
385 (b (make-shared-array a amap2 2 2)))
386 (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
387
388 (pass-if "bit array rank 2"
389 (let* ((a (make-typed-array 'b #f 4 4))
390 (b (make-shared-array a amap2 2 2)))
391 (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
392
393;;;
394;;; transpose-array
395;;;
396
397; see strings.test.
398(define exception:wrong-type-arg
399 (cons #t "Wrong type"))
400
ea342aa6 401(with-test-prefix/c&e "transpose-array"
69843ac1
DL		 402
403 (pass-if-exception "non array argument" exception:wrong-type-arg
404 (transpose-array 99))
405
406 (pass-if "rank 0"
407 (let* ((a #0(99))
408 (b (transpose-array a)))
409 (and (array-equal? a b)
410 (eq? (shared-array-root a) (shared-array-root b)))))
411
412 (pass-if "rank 1"
413 (let* ((a #(1 2 3))
414 (b (transpose-array a 0)))
415 (and (array-equal? a b)
416 (eq? (shared-array-root a) (shared-array-root b)))))
417
418 (pass-if "rank 2"
419 (let* ((a #2((1 2 3) (4 5 6)))
420 (b (transpose-array a 1 0))
421 (c (transpose-array a 0 1)))
422 (and (array-equal? b #2((1 4) (2 5) (3 6)))
423 (array-equal? c a)
424 (eq? (shared-array-root a)
425 (shared-array-root b)
426 (shared-array-root c)))))
427
428 ; rank > 2 is needed to check against the inverted axis index logic.
429 (pass-if "rank 3"
430 (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
431 ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
432 (b (transpose-array a 1 2 0)))
433 (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
434 ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
435 (eq? (shared-array-root a)
436 (shared-array-root b))))))
437
e48a2f87
AW		 438;;;
439;;; array->list
440;;;
441
ea342aa6
DL		 442(with-test-prefix/c&e "array->list"
443 (pass-if-equal "uniform vector" '(1 2 3) (array->list #s16(1 2 3)))
444 (pass-if-equal "vector" '(1 2 3) (array->list #(1 2 3)))
445 (pass-if-equal "rank 2 array" '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
446 (pass-if-equal "empty vector" '() (array->list #()))
1d4e6ee3
LC		 447
448 (pass-if-equal "http://bugs.gnu.org/12465 - ok"
449 '(3 4)
450 (let* ((a #2((1 2) (3 4)))
451 (b (make-shared-array a (lambda (j) (list 1 j)) 2)))
452 (array->list b)))
453 (pass-if-equal "http://bugs.gnu.org/12465 - bad"
454 '(2 4)
455 (let* ((a #2((1 2) (3 4)))
456 (b (make-shared-array a (lambda (i) (list i 1)) 2)))
457 (array->list b))))
e48a2f87 458
e275b8a2
AW		 459;;;
460;;; array-fill!
461;;;
462
463(with-test-prefix "array-fill!"
464
465 (with-test-prefix "bool"
466 (let ((a (make-bitvector 1 #t)))
467 (pass-if "#f" (array-fill! a #f) #t)
468 (pass-if "#t" (array-fill! a #t) #t)))
469
470 (with-test-prefix "char"
471 (let ((a (make-string 1 #\a)))
472 (pass-if "x" (array-fill! a #\x) #t)))
473
474 (with-test-prefix "byte"
475 (let ((a (make-s8vector 1 0)))
476 (pass-if "0" (array-fill! a 0) #t)
477 (pass-if "127" (array-fill! a 127) #t)
478 (pass-if "-128" (array-fill! a -128) #t)
479 (pass-if-exception "128" exception:out-of-range
480 (array-fill! a 128))
481 (pass-if-exception "-129" exception:out-of-range
482 (array-fill! a -129))
483 (pass-if-exception "symbol" exception:wrong-type-arg
484 (array-fill! a 'symbol))))
485
486 (with-test-prefix "short"
487 (let ((a (make-s16vector 1 0)))
488 (pass-if "0" (array-fill! a 0) #t)
489 (pass-if "123" (array-fill! a 123) #t)
490 (pass-if "-123" (array-fill! a -123) #t)))
491
492 (with-test-prefix "ulong"
493 (let ((a (make-u32vector 1 1)))
494 (pass-if "0" (array-fill! a 0) #t)
495 (pass-if "123" (array-fill! a 123) #t)
496 (pass-if-exception "-123" exception:out-of-range
497 (array-fill! a -123) #t)))
498
499 (with-test-prefix "long"
500 (let ((a (make-s32vector 1 -1)))
501 (pass-if "0" (array-fill! a 0) #t)
502 (pass-if "123" (array-fill! a 123) #t)
503 (pass-if "-123" (array-fill! a -123) #t)))
504
505 (with-test-prefix "float"
506 (let ((a (make-f32vector 1 1.0)))
507 (pass-if "0.0" (array-fill! a 0) #t)
508 (pass-if "123.0" (array-fill! a 123.0) #t)
509 (pass-if "-123.0" (array-fill! a -123.0) #t)
510 (pass-if "0" (array-fill! a 0) #t)
511 (pass-if "123" (array-fill! a 123) #t)
512 (pass-if "-123" (array-fill! a -123) #t)
513 (pass-if "5/8" (array-fill! a 5/8) #t)))
514
515 (with-test-prefix "double"
516 (let ((a (make-f64vector 1 1/3)))
517 (pass-if "0.0" (array-fill! a 0) #t)
518 (pass-if "123.0" (array-fill! a 123.0) #t)
519 (pass-if "-123.0" (array-fill! a -123.0) #t)
520 (pass-if "0" (array-fill! a 0) #t)
521 (pass-if "123" (array-fill! a 123) #t)
522 (pass-if "-123" (array-fill! a -123) #t)
ab1ca179
DL		 523 (pass-if "5/8" (array-fill! a 5/8) #t)))
524
525 (with-test-prefix "noncompact"
526 (let* ((a (make-array 0 3 3))
527 (b (make-shared-array a (lambda (i) (list i i)) 3)))
528 (array-fill! b 9)
529 (pass-if
530 (and (equal? b #(9 9 9))
531 (equal? a #2((9 0 0) (0 9 0) (0 0 9))))))))
e275b8a2
AW		 532
533;;;
534;;; array-in-bounds?
535;;;
536
ea342aa6 537(with-test-prefix/c&e "array-in-bounds?"
e275b8a2
AW		 538
539 (pass-if (let ((a (make-array #f '(425 425))))
540 (eq? #f (array-in-bounds? a 0)))))
541
542;;;
543;;; array-prototype
544;;;
545
546(with-test-prefix "array-type"
547
ea342aa6 548 (with-test-prefix/c&e "on make-foo-vector"
e275b8a2
AW		 549
550 (pass-if "bool"
551 (eq? 'b (array-type (make-bitvector 1))))
552
553 (pass-if "char"
554 (eq? 'a (array-type (make-string 1))))
555
556 (pass-if "byte"
557 (eq? 'u8 (array-type (make-u8vector 1))))
558
559 (pass-if "short"
560 (eq? 's16 (array-type (make-s16vector 1))))
561
562 (pass-if "ulong"
563 (eq? 'u32 (array-type (make-u32vector 1))))
564
565 (pass-if "long"
566 (eq? 's32 (array-type (make-s32vector 1))))
567
568 (pass-if "long long"
569 (eq? 's64 (array-type (make-s64vector 1))))
570
571 (pass-if "float"
572 (eq? 'f32 (array-type (make-f32vector 1))))
573
574 (pass-if "double"
575 (eq? 'f64 (array-type (make-f64vector 1))))
576
577 (pass-if "complex"
578 (eq? 'c64 (array-type (make-c64vector 1))))
579
580 (pass-if "scm"
581 (eq? #t (array-type (make-vector 1)))))
582
583 (with-test-prefix "on make-typed-array"
584
585 (let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64)))
586 (for-each (lambda (type)
587 (pass-if (symbol->string type)
588 (eq? type
69843ac1
DL		 589 (array-type (make-typed-array type
590 *unspecified*
e275b8a2
AW		 591 '(5 6))))))
592 types))))
593
594;;;
595;;; array-set!
596;;;
597
598(with-test-prefix "array-set!"
599
600 (with-test-prefix "bitvector"
601
602 ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set!
603 ;; on a bitvector like the following
604 (let ((a (make-bitvector 1)))
605 (pass-if "one elem set #t"
606 (begin
607 (array-set! a #t 0)
608 (eq? #t (array-ref a 0))))
609 (pass-if "one elem set #f"
610 (begin
611 (array-set! a #f 0)
612 (eq? #f (array-ref a 0))))))
613
614 (with-test-prefix "byte"
615
616 (let ((a (make-s8vector 1)))
617
618 (pass-if "-128"
619 (begin (array-set! a -128 0) #t))
620 (pass-if "0"
621 (begin (array-set! a 0 0) #t))
622 (pass-if "127"
623 (begin (array-set! a 127 0) #t))
624 (pass-if-exception "-129" exception:out-of-range
625 (begin (array-set! a -129 0) #t))
626 (pass-if-exception "128" exception:out-of-range
627 (begin (array-set! a 128 0) #t))))
628
629 (with-test-prefix "short"
630
631 (let ((a (make-s16vector 1)))
632 ;; true if n can be array-set! into a
633 (define (fits? n)
634 (false-if-exception (begin (array-set! a n 0) #t)))
635
636 (with-test-prefix "store/fetch"
637 ;; Check array-ref gives back what was put with array-set!.
638 ;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and
639 ;; would silently truncate to a short.
640
641 (do ((n 1 (1+ (* 2 n)))) ;; n=2^k-1
642 ((not (fits? n)))
643 (array-set! a n 0)
644 (pass-if n
645 (= n (array-ref a 0))))
646
647 (do ((n -1 (* 2 n))) ;; -n=2^k
648 ((not (fits? n)))
649 (array-set! a n 0)
650 (pass-if n
651 (= n (array-ref a 0))))))))
652
653;;;
654;;; array-set!
655;;;
656
657(with-test-prefix "array-set!"
658
659 (with-test-prefix "one dim"
660 (let ((a (make-array #f '(3 5))))
661 (pass-if "start"
662 (array-set! a 'y 3)
663 #t)
664 (pass-if "end"
665 (array-set! a 'y 5)
666 #t)
667 (pass-if-exception "start-1" exception:out-of-range
668 (array-set! a 'y 2))
669 (pass-if-exception "end+1" exception:out-of-range
670 (array-set! a 'y 6))
336c9211 671 (pass-if-exception "two indexes" exception:wrong-num-indices
e275b8a2
AW		 672 (array-set! a 'y 6 7))))
673
674 (with-test-prefix "two dim"
675 (let ((a (make-array #f '(3 5) '(7 9))))
676 (pass-if "start"
677 (array-set! a 'y 3 7)
678 #t)
679 (pass-if "end"
680 (array-set! a 'y 5 9)
681 #t)
682 (pass-if-exception "start i-1" exception:out-of-range
683 (array-set! a 'y 2 7))
684 (pass-if-exception "end i+1" exception:out-of-range
685 (array-set! a 'y 6 9))
686 (pass-if-exception "one index" exception:wrong-num-indices
687 (array-set! a 'y 4))
688 (pass-if-exception "three indexes" exception:wrong-num-indices
689 (array-set! a 'y 4 8 0)))))
690
e275b8a2 691;;;
c4aca3b9 692;;; uniform-vector
e275b8a2
AW		 693;;;
694
8051cf23 695(with-test-prefix "typed arrays"
e275b8a2 696
8051cf23 697 (with-test-prefix "array-ref byte"
e275b8a2
AW		 698
699 (let ((a (make-s8vector 1)))
700
701 (pass-if "0"
702 (begin
703 (array-set! a 0 0)
fb7dd001 704 (= 0 (array-ref a 0))))
e275b8a2
AW		 705 (pass-if "127"
706 (begin
707 (array-set! a 127 0)
fb7dd001 708 (= 127 (array-ref a 0))))
e275b8a2
AW		 709 (pass-if "-128"
710 (begin
711 (array-set! a -128 0)
8051cf23 712 (= -128 (array-ref a 0))))))
c4aca3b9 713
8051cf23 714 (with-test-prefix "shared with rank 1 equality"
c4aca3b9
DL		 715
716 (let ((a #f64(1 2 3 4)))
717
718 (pass-if "change offset"
719 (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
8051cf23
AW		 720 (and (eq? (array-type b) (array-type a))
721 (= 3 (array-length b))
c4aca3b9
DL		 722 (array-equal? b #f64(2 3 4)))))
723
724 (pass-if "change stride"
725 (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2)))
8051cf23
AW		 726 (and (eq? (array-type c) (array-type a))
727 (= 2 (array-length c))
c4aca3b9 728 (array-equal? c #f64(1 3))))))))
e275b8a2
AW		 729
730;;;
731;;; syntax
732;;;
733
ea342aa6 734(with-test-prefix/c&e "syntax"
e275b8a2
AW		 735
736 (pass-if "rank and lower bounds"
737 ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
738 (let ((a '#2u32@2@7((1 2) (3 4))))
739 (and (array? a)
740 (typed-array? a 'u32)
741 (= (array-rank a) 2)
742 (let loop ((bounds '((2 7) (2 8) (3 7) (3 8)))
743 (result #t))
744 (if (null? bounds)
745 result
746 (and result
747 (loop (cdr bounds)
748 (apply array-in-bounds? a (car bounds)))))))))
749
750 (pass-if "negative lower bound"
751 (let ((a '#1@-3(a b)))
752 (and (array? a)
753 (= (array-rank a) 1)
754 (array-in-bounds? a -3) (array-in-bounds? a -2)
755 (eq? 'a (array-ref a -3))
756 (eq? 'b (array-ref a -2)))))
757
758 (pass-if-exception "negative length" exception:length-non-negative
759 (with-input-from-string "'#1:-3(#t #t)" read))
760
761 (pass-if "bitvector is self-evaluating"
c6eaad97
DL		 762 (equal? (compile (bitvector)) (bitvector)))
763
764 ; this failed in 2.0.9.
765 (pass-if "typed arrays that are not uniform arrays"
766 (let ((a #2b((#t #f) (#f #t)))
767 (b (make-typed-array 'b #f 2 2)))
768 (array-set! b #t 0 0)
769 (array-set! b #t 1 1)
770 (array-equal? a b))))
e275b8a2
AW		 771
772;;;
773;;; equal? with vector and one-dimensional array
774;;;
775
ea342aa6 776(with-test-prefix/c&e "equal?"
e275b8a2
AW		 777 (pass-if "array and non-array"
778 (not (equal? #2f64((0 1) (2 3)) 100)))
779
a587d6a9
AW		 780 (pass-if "empty vectors of different types"
781 (not (equal? #s32() #f64())))
782
783 (pass-if "empty arrays of different types"
784 (not (equal? #2s32() #2f64())))
785
786 (pass-if "empty arrays of the same type"
787 (equal? #s32() #s32()))
788
789 (pass-if "identical uniform vectors of the same type"
790 (equal? #s32(1) #s32(1)))
791
792 (pass-if "nonidentical uniform vectors of the same type"
793 (not (equal? #s32(1) #s32(-1))))
794
795 (pass-if "identical uniform vectors of different types"
796 (not (equal? #s32(1) #s64(1))))
797
798 (pass-if "nonidentical uniform vectors of different types"
799 (not (equal? #s32(1) #s64(-1))))
800
e275b8a2
AW		 801 (pass-if "vector and one-dimensional array"
802 (equal? (make-shared-array #2((a b c) (d e f) (g h i))
803 (lambda (i) (list i i))
804 '(0 2))
805 #(a e i))))
2b414e24
AW		 806
807;;;
808;;; slices as generalized vectors
809;;;
810
ea342aa6
DL		 811(define (array-row a i)
812 (make-shared-array a (lambda (j) (list i j))
813 (cadr (array-dimensions a))))
814
815(with-test-prefix/c&e "generalized vector slices"
816 (pass-if (equal? (array-row #2u32((0 1) (2 3)) 1)
817 #u32(2 3)))
818 (pass-if (equal? (array-ref (array-row #2u32((0 1) (2 3)) 1) 0)
819 2)))
Unnamed repository; edit this file 'description' to name the repository.