1 ;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
3 ;;;; Copyright 2004, 2006 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 2.1 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-unif)
20 #:use-module (test-suite lib))
26 (define exception:wrong-num-indices
27 (cons 'misc-error "^wrong number of indices.*"))
29 (with-test-prefix "array?"
31 (let ((bool (make-typed-array 'b #t '(5 6)))
32 (char (make-typed-array 'a #\a '(5 6)))
33 (byte (make-typed-array 'u8 0 '(5 6)))
34 (short (make-typed-array 's16 0 '(5 6)))
35 (ulong (make-typed-array 'u32 0 '(5 6)))
36 (long (make-typed-array 's32 0 '(5 6)))
37 (longlong (make-typed-array 's64 0 '(5 6)))
38 (float (make-typed-array 'f32 0 '(5 6)))
39 (double (make-typed-array 'f64 0 '(5 6)))
40 (complex (make-typed-array 'c64 0 '(5 6)))
41 (scm (make-typed-array #t 0 '(5 6))))
43 (with-test-prefix "is bool"
44 (pass-if (eq? #t (typed-array? bool 'b)))
45 (pass-if (eq? #f (typed-array? char 'b)))
46 (pass-if (eq? #f (typed-array? byte 'b)))
47 (pass-if (eq? #f (typed-array? short 'b)))
48 (pass-if (eq? #f (typed-array? ulong 'b)))
49 (pass-if (eq? #f (typed-array? long 'b)))
50 (pass-if (eq? #f (typed-array? longlong 'b)))
51 (pass-if (eq? #f (typed-array? float 'b)))
52 (pass-if (eq? #f (typed-array? double 'b)))
53 (pass-if (eq? #f (typed-array? complex 'b)))
54 (pass-if (eq? #f (typed-array? scm 'b))))
56 (with-test-prefix "is char"
57 (pass-if (eq? #f (typed-array? bool 'a)))
58 (pass-if (eq? #t (typed-array? char 'a)))
59 (pass-if (eq? #f (typed-array? byte 'a)))
60 (pass-if (eq? #f (typed-array? short 'a)))
61 (pass-if (eq? #f (typed-array? ulong 'a)))
62 (pass-if (eq? #f (typed-array? long 'a)))
63 (pass-if (eq? #f (typed-array? longlong 'a)))
64 (pass-if (eq? #f (typed-array? float 'a)))
65 (pass-if (eq? #f (typed-array? double 'a)))
66 (pass-if (eq? #f (typed-array? complex 'a)))
67 (pass-if (eq? #f (typed-array? scm 'a))))
69 (with-test-prefix "is byte"
70 (pass-if (eq? #f (typed-array? bool 'u8)))
71 (pass-if (eq? #f (typed-array? char 'u8)))
72 (pass-if (eq? #t (typed-array? byte 'u8)))
73 (pass-if (eq? #f (typed-array? short 'u8)))
74 (pass-if (eq? #f (typed-array? ulong 'u8)))
75 (pass-if (eq? #f (typed-array? long 'u8)))
76 (pass-if (eq? #f (typed-array? longlong 'u8)))
77 (pass-if (eq? #f (typed-array? float 'u8)))
78 (pass-if (eq? #f (typed-array? double 'u8)))
79 (pass-if (eq? #f (typed-array? complex 'u8)))
80 (pass-if (eq? #f (typed-array? scm 'u8))))
82 (with-test-prefix "is short"
83 (pass-if (eq? #f (typed-array? bool 's16)))
84 (pass-if (eq? #f (typed-array? char 's16)))
85 (pass-if (eq? #f (typed-array? byte 's16)))
86 (pass-if (eq? #t (typed-array? short 's16)))
87 (pass-if (eq? #f (typed-array? ulong 's16)))
88 (pass-if (eq? #f (typed-array? long 's16)))
89 (pass-if (eq? #f (typed-array? longlong 's16)))
90 (pass-if (eq? #f (typed-array? float 's16)))
91 (pass-if (eq? #f (typed-array? double 's16)))
92 (pass-if (eq? #f (typed-array? complex 's16)))
93 (pass-if (eq? #f (typed-array? scm 's16))))
95 (with-test-prefix "is ulong"
96 (pass-if (eq? #f (typed-array? bool 'u32)))
97 (pass-if (eq? #f (typed-array? char 'u32)))
98 (pass-if (eq? #f (typed-array? byte 'u32)))
99 (pass-if (eq? #f (typed-array? short 'u32)))
100 (pass-if (eq? #t (typed-array? ulong 'u32)))
101 (pass-if (eq? #f (typed-array? long 'u32)))
102 (pass-if (eq? #f (typed-array? longlong 'u32)))
103 (pass-if (eq? #f (typed-array? float 'u32)))
104 (pass-if (eq? #f (typed-array? double 'u32)))
105 (pass-if (eq? #f (typed-array? complex 'u32)))
106 (pass-if (eq? #f (typed-array? scm 'u32))))
108 (with-test-prefix "is long"
109 (pass-if (eq? #f (typed-array? bool 's32)))
110 (pass-if (eq? #f (typed-array? char 's32)))
111 (pass-if (eq? #f (typed-array? byte 's32)))
112 (pass-if (eq? #f (typed-array? short 's32)))
113 (pass-if (eq? #f (typed-array? ulong 's32)))
114 (pass-if (eq? #t (typed-array? long 's32)))
115 (pass-if (eq? #f (typed-array? longlong 's32)))
116 (pass-if (eq? #f (typed-array? float 's32)))
117 (pass-if (eq? #f (typed-array? double 's32)))
118 (pass-if (eq? #f (typed-array? complex 's32)))
119 (pass-if (eq? #f (typed-array? scm 's32))))
121 (with-test-prefix "is long long"
122 (pass-if (eq? #f (typed-array? bool 's64)))
123 (pass-if (eq? #f (typed-array? char 's64)))
124 (pass-if (eq? #f (typed-array? byte 's64)))
125 (pass-if (eq? #f (typed-array? short 's64)))
126 (pass-if (eq? #f (typed-array? ulong 's64)))
127 (pass-if (eq? #f (typed-array? long 's64)))
128 (pass-if (eq? #t (typed-array? longlong 's64)))
129 (pass-if (eq? #f (typed-array? float 's64)))
130 (pass-if (eq? #f (typed-array? double 's64)))
131 (pass-if (eq? #f (typed-array? complex 's64)))
132 (pass-if (eq? #f (typed-array? scm 's64))))
134 (with-test-prefix "is float"
135 (pass-if (eq? #f (typed-array? bool 'f32)))
136 (pass-if (eq? #f (typed-array? char 'f32)))
137 (pass-if (eq? #f (typed-array? byte 'f32)))
138 (pass-if (eq? #f (typed-array? short 'f32)))
139 (pass-if (eq? #f (typed-array? ulong 'f32)))
140 (pass-if (eq? #f (typed-array? long 'f32)))
141 (pass-if (eq? #f (typed-array? longlong 'f32)))
142 (pass-if (eq? #t (typed-array? float 'f32)))
143 (pass-if (eq? #f (typed-array? double 'f32)))
144 (pass-if (eq? #f (typed-array? complex 'f32)))
145 (pass-if (eq? #f (typed-array? scm 'f32))))
147 (with-test-prefix "is double"
148 (pass-if (eq? #f (typed-array? bool 'f64)))
149 (pass-if (eq? #f (typed-array? char 'f64)))
150 (pass-if (eq? #f (typed-array? byte 'f64)))
151 (pass-if (eq? #f (typed-array? short 'f64)))
152 (pass-if (eq? #f (typed-array? ulong 'f64)))
153 (pass-if (eq? #f (typed-array? long 'f64)))
154 (pass-if (eq? #f (typed-array? longlong 'f64)))
155 (pass-if (eq? #f (typed-array? float 'f64)))
156 (pass-if (eq? #t (typed-array? double 'f64)))
157 (pass-if (eq? #f (typed-array? complex 'f64)))
158 (pass-if (eq? #f (typed-array? scm 'f64))))
160 (with-test-prefix "is complex"
161 (pass-if (eq? #f (typed-array? bool 'c64)))
162 (pass-if (eq? #f (typed-array? char 'c64)))
163 (pass-if (eq? #f (typed-array? byte 'c64)))
164 (pass-if (eq? #f (typed-array? short 'c64)))
165 (pass-if (eq? #f (typed-array? ulong 'c64)))
166 (pass-if (eq? #f (typed-array? long 'c64)))
167 (pass-if (eq? #f (typed-array? longlong 'c64)))
168 (pass-if (eq? #f (typed-array? float 'c64)))
169 (pass-if (eq? #f (typed-array? double 'c64)))
170 (pass-if (eq? #t (typed-array? complex 'c64)))
171 (pass-if (eq? #f (typed-array? scm 'c64))))
173 (with-test-prefix "is scm"
174 (pass-if (eq? #f (typed-array? bool #t)))
175 (pass-if (eq? #f (typed-array? char #t)))
176 (pass-if (eq? #f (typed-array? byte #t)))
177 (pass-if (eq? #f (typed-array? short #t)))
178 (pass-if (eq? #f (typed-array? ulong #t)))
179 (pass-if (eq? #f (typed-array? long #t)))
180 (pass-if (eq? #f (typed-array? longlong #t)))
181 (pass-if (eq? #f (typed-array? float #t)))
182 (pass-if (eq? #f (typed-array? double #t)))
183 (pass-if (eq? #f (typed-array? complex #t)))
184 (pass-if (eq? #t (typed-array? scm #t))))))
190 (with-test-prefix "array-equal?"
193 (array-equal? #s16(1 2 3) #s16(1 2 3))))
199 (with-test-prefix "array-fill!"
201 (with-test-prefix "bool"
202 (let ((a (make-bitvector 1 #t)))
203 (pass-if "#f" (array-fill! a #f) #t)
204 (pass-if "#t" (array-fill! a #t) #t)))
206 (with-test-prefix "char"
207 (let ((a (make-string 1 #\a)))
208 (pass-if "x" (array-fill! a #\x) #t)))
210 (with-test-prefix "byte"
211 (let ((a (make-s8vector 1 0)))
212 (pass-if "0" (array-fill! a 0) #t)
213 (pass-if "127" (array-fill! a 127) #t)
214 (pass-if "-128" (array-fill! a -128) #t)
215 (pass-if-exception "128" exception:out-of-range
217 (pass-if-exception "-129" exception:out-of-range
218 (array-fill! a -129))
219 (pass-if-exception "symbol" exception:wrong-type-arg
220 (array-fill! a 'symbol))))
222 (with-test-prefix "short"
223 (let ((a (make-s16vector 1 0)))
224 (pass-if "0" (array-fill! a 0) #t)
225 (pass-if "123" (array-fill! a 123) #t)
226 (pass-if "-123" (array-fill! a -123) #t)))
228 (with-test-prefix "ulong"
229 (let ((a (make-u32vector 1 1)))
230 (pass-if "0" (array-fill! a 0) #t)
231 (pass-if "123" (array-fill! a 123) #t)
232 (pass-if-exception "-123" exception:out-of-range
233 (array-fill! a -123) #t)))
235 (with-test-prefix "long"
236 (let ((a (make-s32vector 1 -1)))
237 (pass-if "0" (array-fill! a 0) #t)
238 (pass-if "123" (array-fill! a 123) #t)
239 (pass-if "-123" (array-fill! a -123) #t)))
241 (with-test-prefix "float"
242 (let ((a (make-f32vector 1 1.0)))
243 (pass-if "0.0" (array-fill! a 0) #t)
244 (pass-if "123.0" (array-fill! a 123.0) #t)
245 (pass-if "-123.0" (array-fill! a -123.0) #t)
246 (pass-if "0" (array-fill! a 0) #t)
247 (pass-if "123" (array-fill! a 123) #t)
248 (pass-if "-123" (array-fill! a -123) #t)
249 (pass-if "5/8" (array-fill! a 5/8) #t)))
251 (with-test-prefix "double"
252 (let ((a (make-f64vector 1 1/3)))
253 (pass-if "0.0" (array-fill! a 0) #t)
254 (pass-if "123.0" (array-fill! a 123.0) #t)
255 (pass-if "-123.0" (array-fill! a -123.0) #t)
256 (pass-if "0" (array-fill! a 0) #t)
257 (pass-if "123" (array-fill! a 123) #t)
258 (pass-if "-123" (array-fill! a -123) #t)
259 (pass-if "5/8" (array-fill! a 5/8) #t))))
265 (with-test-prefix "array-in-bounds?"
267 (pass-if (let ((a (make-array #f '(425 425))))
268 (eq? #f (array-in-bounds? a 0)))))
274 (with-test-prefix "array-type"
276 (with-test-prefix "on make-foo-vector"
279 (eq? 'b (array-type (make-bitvector 1))))
282 (eq? 'a (array-type (make-string 1))))
285 (eq? 'u8 (array-type (make-u8vector 1))))
288 (eq? 's16 (array-type (make-s16vector 1))))
291 (eq? 'u32 (array-type (make-u32vector 1))))
294 (eq? 's32 (array-type (make-s32vector 1))))
297 (eq? 's64 (array-type (make-s64vector 1))))
300 (eq? 'f32 (array-type (make-f32vector 1))))
303 (eq? 'f64 (array-type (make-f64vector 1))))
306 (eq? 'c64 (array-type (make-c64vector 1))))
309 (eq? #t (array-type (make-vector 1)))))
311 (with-test-prefix "on make-typed-array"
313 (let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64)))
314 (for-each (lambda (type)
315 (pass-if (symbol->string type)
317 (array-type (make-typed-array type
326 (with-test-prefix "array-set!"
328 (with-test-prefix "bitvector"
330 ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set!
331 ;; on a bitvector like the following
332 (let ((a (make-bitvector 1)))
333 (pass-if "one elem set #t"
336 (eq? #t (array-ref a 0))))
337 (pass-if "one elem set #f"
340 (eq? #f (array-ref a 0))))))
342 (with-test-prefix "byte"
344 (let ((a (make-s8vector 1)))
347 (begin (array-set! a -128 0) #t))
349 (begin (array-set! a 0 0) #t))
351 (begin (array-set! a 127 0) #t))
352 (pass-if-exception "-129" exception:out-of-range
353 (begin (array-set! a -129 0) #t))
354 (pass-if-exception "128" exception:out-of-range
355 (begin (array-set! a 128 0) #t))))
357 (with-test-prefix "short"
359 (let ((a (make-s16vector 1)))
360 ;; true if n can be array-set! into a
362 (false-if-exception (begin (array-set! a n 0) #t)))
364 (with-test-prefix "store/fetch"
365 ;; Check array-ref gives back what was put with array-set!.
366 ;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and
367 ;; would silently truncate to a short.
369 (do ((n 1 (1+ (* 2 n)))) ;; n=2^k-1
373 (= n (array-ref a 0))))
375 (do ((n -1 (* 2 n))) ;; -n=2^k
379 (= n (array-ref a 0))))))))
385 (with-test-prefix "array-set!"
387 (with-test-prefix "one dim"
388 (let ((a (make-array #f '(3 5))))
395 (pass-if-exception "start-1" exception:out-of-range
397 (pass-if-exception "end+1" exception:out-of-range
399 (pass-if-exception "two indexes" exception:out-of-range
400 (array-set! a 'y 6 7))))
402 (with-test-prefix "two dim"
403 (let ((a (make-array #f '(3 5) '(7 9))))
405 (array-set! a 'y 3 7)
408 (array-set! a 'y 5 9)
410 (pass-if-exception "start i-1" exception:out-of-range
411 (array-set! a 'y 2 7))
412 (pass-if-exception "end i+1" exception:out-of-range
413 (array-set! a 'y 6 9))
414 (pass-if-exception "one index" exception:wrong-num-indices
416 (pass-if-exception "three indexes" exception:wrong-num-indices
417 (array-set! a 'y 4 8 0)))))
420 ;;; make-shared-array
423 (define exception:mapping-out-of-range
424 (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
426 (with-test-prefix "make-shared-array"
428 ;; this failed in guile 1.8.0
429 (pass-if "vector unchanged"
430 (let* ((a (make-array #f '(0 7)))
431 (s (make-shared-array a list '(0 7))))
434 (pass-if-exception "vector, high too big" exception:mapping-out-of-range
435 (let* ((a (make-array #f '(0 7))))
436 (make-shared-array a list '(0 8))))
438 (pass-if-exception "vector, low too big" exception:out-of-range
439 (let* ((a (make-array #f '(0 7))))
440 (make-shared-array a list '(-1 7))))
442 (pass-if "truncate columns"
443 (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
444 #2((a b) (d e) (g h))))
446 (pass-if "pick one column"
447 (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
448 (lambda (i) (list i 2))
453 (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
454 (lambda (i) (list i i))
458 ;; this failed in guile 1.8.0
459 (pass-if "2 dims from 1 dim"
460 (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
461 (lambda (i j) (list (+ (* i 3) j)))
463 #2((a b c) (d e f) (g h i) (j k l))))
465 (pass-if "reverse columns"
466 (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
467 (lambda (i j) (list i (- 2 j)))
469 #2((c b a) (f e d) (i h g))))
471 (pass-if "fixed offset, 0 based becomes 1 based"
472 (let* ((x #2((a b c) (d e f) (g h i)))
473 (y (make-shared-array x
474 (lambda (i j) (list (1- i) (1- j)))
476 (and (eq? (array-ref x 0 0) 'a)
477 (eq? (array-ref y 1 1) 'a))))
479 ;; this failed in guile 1.8.0
480 (pass-if "stride every third element"
481 (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
482 (lambda (i) (list (* i 3)))
486 (pass-if "shared of shared"
487 (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
488 (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
489 (s2 (make-shared-array s1 list '(1 2))))
490 (and (eqv? 5 (array-ref s2 1))
491 (eqv? 8 (array-ref s2 2))))))
494 ;;; uniform-vector-ref
497 (with-test-prefix "uniform-vector-ref"
499 (with-test-prefix "byte"
501 (let ((a (make-s8vector 1)))
506 (= 0 (uniform-vector-ref a 0))))
510 (= 127 (uniform-vector-ref a 0))))
513 (array-set! a -128 0)
514 (= -128 (uniform-vector-ref a 0)))))))