run.scm - bitstring - A fork of the CHICKEN bitstring egg for CHICKEN 5
(HTM) git clone git://vernunftzentrum.de/bitstring.git
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) README
---
run.scm (17231B)
---
1 (use srfi-4 bitstring test)
2
3 (current-test-epsilon .01)
4
5 (test-begin "bitstring")
6
7 ;;;;;;;;;;;;;;;;;;
8
9 (test-begin "bit-set?")
10 (test #t (bitstring-bit-set? (->bitstring '#${80 00}) 0))
11 (test #t (bitstring-bit-set? (->bitstring '#${01 00}) 7))
12 (test #t (bitstring-bit-set? (->bitstring '#${00 01}) -1))
13 (test #t (bitstring-bit-set? (->bitstring '#${80 00}) -16))
14 (test-end)
15
16 (test-begin "construct bitstring syntax")
17 (define foo "\x01")
18 (test (bitconstruct (1)(2)) (bitconstruct (foo bitstring) (2)))
19 (test (bitconstruct (1)) (bitconstruct (foo bitstring)))
20 (test-end)
21
22 (test-begin "integer attributes")
23 (test -25 (bitmatch "\xE7" ((x 8 signed) -> x)))
24 ;(test -45 (bitmatch "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xD3" ((skip 1) (x 63 signed) -> x)))
25 (define bstr (->bitstring "\xFE"))
26 (test -2 (bitmatch bstr ((x signed) -> x)))
27 (test 254 (bitmatch bstr ((x unsigned) -> x)))
28 (test -2 (bitmatch bstr ((x 8 signed) -> x)))
29 (test 254 (bitmatch bstr ((x 8 unsigned) -> x)))
30 (test -2 (bitmatch bstr ((x 8 big signed) -> x)))
31 (test 254 (bitmatch bstr ((x 8 big unsigned) -> x)))
32 (test -2 (bitmatch bstr ((x 8 little signed) -> x)))
33 (test 254 (bitmatch bstr ((x 8 little unsigned) -> x)))
34 (test -2 (bitmatch bstr ((x 8 signed host) -> x)))
35 (test 254 (bitmatch bstr ((x 8 unsigned host) -> x)))
36 (test-error (bitmatch bstr ((x 8 unsigned cost) -> x)))
37 (test -1 (bitmatch (bitstring-share bstr 0 4) ((x 4 signed) -> x)))
38 (test -2 (bitmatch (bitstring-share bstr 4 8) ((x 4 signed) -> x)))
39 (test-end)
40
41 (test-begin "bitstring->list")
42 (define bstr (->bitstring "\xff"))
43 (test (make-list 8 1) (bitstring->list bstr 1 'big))
44 (test (make-list 8 1) (bitstring->list bstr 1 'little))
45 (test (make-list 8 1) (bitstring->list bstr 1 'host))
46 (test-end)
47
48 (test-begin "list->bitstring")
49 (define foo (list 1 0 1))
50 (define bar (list->bitstring foo 8))
51 (test foo (bitstring->list bar 8))
52 (test foo (bitstring->list bar 8 'big))
53 (test foo (bitstring->list bar 8 'little))
54 (test foo (bitstring->list bar 8 'host))
55 (test-end)
56
57 (test-begin "bitstring-reverse")
58 (define bs (->bitstring '#${0a 0b 0c 0d}))
59 (test (list #xd #xc #xb #xa) (bitstring->list (bitstring-reverse bs 8) 8))
60 (test-end)
61
62 (test-begin "bitstring <-> vector")
63 (define x (vector 1 2 3))
64 (test x (bitstring->vector (vector->bitstring x)))
65 (test-end)
66
67 (define bs9)
68 (define bs7)
69 (bitmatch (u8vector #xff #xff)
70 (((a 9 bitstring) (b bitstring))
71 (set! bs9 a)
72 (set! bs7 b)))
73
74 (test-begin "bitstring <-> u8vector")
75 (define x (u8vector 1 2 3))
76 (test x (bitstring->u8vector (u8vector->bitstring x)))
77 (define y (u8vector #xff #x01))
78 (test y (bitstring->u8vector bs9))
79 (define z (u8vector #xff #x80))
80 (test z (bitstring->u8vector bs9 'right))
81 (define w (u8vector #b01111111))
82 (test w (bitstring->u8vector bs7 'left))
83 (define g (u8vector #b11111110))
84 (test g (bitstring->u8vector bs7 'right))
85 (test-end)
86
87 (test-begin "bitstring <-> blob")
88 (define x '#${1 2 3})
89 (test x (bitstring->blob (blob->bitstring x)))
90 (define y '#${ff01})
91 (test y (bitstring->blob bs9))
92 (define z '#${ff80})
93 (test z (bitstring->blob bs9 'right))
94 (test-end)
95
96 (test-begin "bitstring <-> string")
97 (define x "123")
98 (test x (bitstring->string (string->bitstring x)))
99 (test-end)
100
101 (test-begin "single-double")
102 (define a (bitconstruct (0.123 float)))
103 (define b (bitconstruct (0.2 double)))
104 (test 0.123 (bitmatch a (((x float)) x)))
105 (test 0.2 (bitmatch b (((x double)) x)))
106
107 (test 0.123
108 (bitmatch (bitconstruct (0.123 float little))
109 (((f float little)) f)))
110
111 (test 0.123
112 (bitmatch (bitconstruct (0.123 float big))
113 (((f float big)) f)))
114
115 (test 0.123
116 (bitmatch (bitconstruct (0.123 double host))
117 (((f double host)) f)))
118
119 (test (list 63 191 124 237 145 104 114 176)
120 (bitstring->list (bitconstruct (0.123 double big)) 8))
121
122 (test (list 176 114 104 145 237 124 191 63)
123 (bitstring->list (bitconstruct (0.123 double little)) 8))
124
125 (test-end)
126
127 (test-begin "string-constant")
128 (test 2 (bitmatch "123" ((("234")) 1) ((("123")) 2)))
129 (define s123 "123")
130 (test 2 (bitmatch s123 ((("234")) 1) ((("123")) 2)))
131 (test 2 (bitmatch s123 ((("234")) 1) (((s123 bitstring)) 2)))
132 (test 2 (bitmatch "123" ((("234")) 1) (((s123 bitstring)) 2)))
133 (test-end)
134
135 (test-begin "construct")
136 (bitpacket NString (size 8) (data (* 8 size) bitstring))
137 (define (make-nstr str)
138 (let ((size (string-length str))
139 (data str))
140 (bitconstruct (NString bitpacket))))
141 (define nstr (make-nstr "ABC"))
142 (test #t (bitmatch nstr (((3) ("ABC")) #t) (else #f)))
143 (test-end)
144
145 (test-begin "append")
146 ; append list immutable
147 (test "1234567890"
148 (bitstring->string
149 (bitstring-append (->bitstring "123") (->bitstring "456") (->bitstring "7890"))))
150 ; append list mutable
151 (define bs (->bitstring (u8vector)))
152 (bitstring-append! bs (->bitstring "123") (->bitstring "456") (->bitstring "7890"))
153 (test "1234567890" (bitstring->string bs))
154 ; append aligned
155 (define bs (->bitstring (u8vector)))
156 (bitstring-append! bs (->bitstring "A"))
157 (bitstring-append! bs (->bitstring "B"))
158 (bitstring-append! bs (->bitstring "\x20"))
159 (test #t (bitstring=? bs (->bitstring "AB\x20")))
160 ; test immutable append
161 (define a (->bitstring "A"))
162 (define b (->bitstring "B"))
163 (define c (bitstring-append a b))
164 (test #t (bitstring=? (bitconstruct ("AB")) c))
165 (test #t (bitstring=? (bitconstruct ("A")) a))
166 (test #t (bitstring=? (bitconstruct ("B")) b))
167 (test 16 (bitstring-length c))
168 ; append unaligned
169 (define bs (->bitstring (u8vector)))
170 (bitstring-append! bs (integer->bitstring-big #b100 3))
171 (bitstring-append! bs (integer->bitstring-big #b10 2))
172 (bitstring-append! bs (integer->bitstring-big #b1 1))
173 (bitstring-append! bs (integer->bitstring-big #b0101 4))
174 (bitstring-append! bs (integer->bitstring-big #b10 2))
175 (bitstring-append! bs (integer->bitstring-big #b0 1))
176 (bitstring-append! bs (integer->bitstring-big #b10100 5))
177 (test #b100101010110010100 (bitstring->integer-big bs))
178 ; append unaligned with overflow
179 (define bs (->bitstring (u8vector)))
180 (bitstring-append! bs (integer->bitstring-big #b100111010 9))
181 (bitstring-append! bs (integer->bitstring-big #b1000111100100 13))
182 (test #b1001110101000111100100 (bitstring->integer-big bs))
183 (define bs (->bitstring (u8vector)))
184 (bitstring-append! bs (integer->bitstring-big #b0 1))
185 (bitstring-append! bs (integer->bitstring-big #b01001011011101 14))
186 (bitstring-append! bs (integer->bitstring-big #b110001 6))
187 (bitstring-append! bs (integer->bitstring-big #b10100011100 11))
188 (test #b00100101101110111000110100011100 (bitstring->integer-big bs))
189 ; append with resize
190 (define bs (->bitstring (u8vector)))
191 (let ((a "Is There Love")
192 (b "in Space?")
193 (c "Nobody knows."))
194 (bitstring-append! bs (->bitstring a))
195 (bitstring-append! bs (->bitstring b))
196 (test #t (bitstring=? (->bitstring (string-append a b)) bs))
197 (bitstring-append! bs (->bitstring c))
198 (test #t (bitstring=? (->bitstring (string-append a b c)) bs)))
199 (test-end)
200
201 (test-begin "bitpacket")
202 (bitpacket Packet1 (1) (2))
203 (bitpacket Packet2 (A 8) (B))
204 (test 3 (bitmatch `#(1 2 3) (((Packet1 bitpacket) (C 8)) C)))
205 (test 6 (bitmatch `#(1 2 3) (((Packet2 bitpacket) (C 8)) (+ A B C))))
206 (test-error (bitmatch `#(1 2 3) (((Packet1 bitpacket) (C 8) (D 8)) C)))
207
208 (bitpacket PacketC (C 8))
209 (bitpacket PacketB (B 8))
210 (bitpacket PacketA (A 8) (PacketB bitpacket) (PacketC bitpacket))
211 (test 6 (bitmatch `#(1 2 3) (( (PacketA bitpacket) ) (+ A B C))))
212
213 (bitpacket PacketX (22) (ValueX 8))
214 (bitpacket PacketY (33) (ValueY 8))
215 (bitpacket PacketZ (44) (ValueZ 8))
216 (test 13 (bitmatch `#( 44 10 )
217 (((PacketX bitpacket)) (+ 1 ValueX))
218 (((PacketY bitpacket)) (+ 2 ValueY))
219 (((PacketZ bitpacket)) (+ 3 ValueZ))))
220
221 ;;bitpacket with prefix
222 (bitpacket Point (x 8) (y 8))
223
224 (test 5 (bitmatch "\x01\x02\x03\x04"
225 (((p1 Point bitpacket) (p2 Point bitpacket))
226 (+ p1.x p2.y))))
227
228 (bitpacket Line (start Point bitpacket)
229 (end Point bitpacket))
230
231 (test 5 (bitmatch "\x01\x02\x03\x04"
232 (((Line bitpacket))
233 (+ start.x end.y))))
234
235 (test 5 (bitmatch "\x01\x02\x03\x04"
236 (((line Line bitpacket))
237 (+ line.start.x line.end.y))))
238
239 (test "\x01\x02\x03\x04" (let ((line.start.x 1)
240 (line.start.y 2)
241 (line.end.x 3)
242 (line.end.y 4))
243 (bitstring->string (bitconstruct (line Line bitpacket)))))
244 ; bitpacket constructor
245 (bitpacket (Point3D make-Point3D)
246 (x float host)
247 (y float host)
248 (z float host))
249 (test (f32vector 0.0 -1.0 1.0)
250 (blob->f32vector (bitstring->blob (make-Point3D (x 0.0) (y -1.0) (z 1.0)))))
251
252 (test-end)
253
254 (test-begin "->bitstring")
255 (test 'ok (bitmatch "ABC" ((("A") (66) (#\C)) 'ok)))
256 (test 'ok (bitmatch "ABC" ((("AB") (#\C)) 'ok)))
257 (test 'ok (bitmatch `#( 65 66 67 ) ( (("A") (66) (#\C)) 'ok)))
258 (test 'ok (bitmatch `#u8( 65 66 67 ) ((("A") (66) (#\C)) 'ok)))
259 (test 'ok (bitmatch (string->blob "ABC") ((("A") (66) (#\C)) 'ok)))
260 (test-error (bitmatch (s8vector 65 66 67) ((("A") (66) (#\C)) 'ok)))
261
262 (bitmatch `#( 5 1 2 3 4 5)
263 (((count 8) (rest (* count 8) bitstring))
264 (print " count=" count " rest=" (bitstring-length rest))))
265 (test-end)
266
267 (test-begin "short form")
268 (bitpacket B30 (30))
269 (test 'yes (bitmatch `#( 10 20 30 )
270 (((10) (20) (11)) 'no)
271 (((10) (20) (33)) 'no)
272 (((10) (20) (B30 bitpacket)) 'yes)))
273 (test-end)
274
275 (test-begin "match")
276
277 #;(test 1.5
278 (bitmatch `#( #x38 #x00 #x00 #x00 #x80 #x3f)
279 (((a 16 float) (b 32 float))
280 (+ a b))))
281
282 (test (list 1 15)
283 (bitmatch `#( #x8F )
284 (((flagBit 1 big) (restValue 7)) (list flagBit restValue))))
285
286 (test 'ok
287 (bitmatch `#( #x8F )
288 (((1 1) (rest)) 'fail)
289 (((x 1) (check (= x 0)) (rest bitstring)) 'fail2)
290 (((1 1) (rest bitstring)) 'ok)))
291
292 (test 'ok
293 (bitmatch `#( #x8F )
294 (((#x8E)) 'fail1)
295 (((#x8C)) 'fail2)
296 (((#x8F)) 'ok)))
297
298 (test 'ok
299 (bitmatch `#( #x8F )
300 (((#x8E)) 'fail1)
301 (((#x8C)) 'fail2)
302 (else 'ok)))
303
304 (test-end)
305
306 (test-begin "read")
307 (define bs (vector->bitstring `#(65 66 67)))
308 (test #f (bitstring-read bs 100))
309 (test 2 (bitstring->integer-big (bitstring-share bs 0 3)))
310 (test 5 (bitstring->integer-big (bitstring-share bs 3 10)))
311 (test 579 (bitstring->integer-big (bitstring-share bs 10 24)))
312 (test 2 (bitstring->integer-big (bitstring-read bs 3)))
313 (test 5 (bitstring->integer-big (bitstring-read bs 7)))
314 (test 579 (bitstring->integer-big (bitstring-read bs 14)))
315 (test #f (bitstring-read bs 1))
316 (define bs (vector->bitstring `#( #x8F )))
317 (test 1 (bitstring->integer-big (bitstring-share bs 0 1)))
318 (test 15 (bitstring->integer-big (bitstring-share bs 1 8)))
319 (define bs (vector->bitstring `#( #x7C #x00)))
320 (test 0 (bitstring->integer-big (bitstring-share bs 0 1)))
321 (test 31 (bitstring->integer-big (bitstring-share bs 1 6)))
322 (test-end)
323
324 (define (get-fields bs)
325 (list (bitstring-start bs) (bitstring-end bs) (bitstring-buffer bs)))
326
327 (test-begin "big")
328 (test `(0 0 #u8()) (get-fields (integer->bitstring-big 0 0)))
329 (test `(0 3 #u8(32)) (get-fields (integer->bitstring-big 1 3)))
330 (test 1 (bitstring->integer-big (integer->bitstring-big 1 3)))
331 (test `(0 8 #u8(15)) (get-fields (integer->bitstring-big 15 8)))
332 (test 15 (bitstring->integer-big (integer->bitstring-big 15 8)))
333 (test `(0 9 #u8(94 0)) (get-fields (integer->bitstring-big #xABC 9)))
334 (test 188 (bitstring->integer-big (integer->bitstring-big #xABC 9)))
335 (test `(0 10 #u8(175 0)) (get-fields (integer->bitstring-big #xABC 10)))
336 (test 700 (bitstring->integer-big (integer->bitstring-big #xABC 10)))
337 (test 123213 (bitstring->integer-big (integer->bitstring-big 123213 32)))
338 (test #x00000001 (bitstring->integer-big (integer->bitstring-big #x00000001 32)))
339 (test #x10000000 (bitstring->integer-big (integer->bitstring-big #x10000000 32)))
340 (test #x7FFFFFFF (bitstring->integer-big (integer->bitstring-big #x7FFFFFFF 32)))
341 (test #xFFFFFFFF (bitstring->integer-big (integer->bitstring-big #xFFFFFFFF 32)))
342 (test-end)
343
344 (test-begin "little")
345 (test `(0 0 #u8()) (get-fields (integer->bitstring-little 0 0)))
346 (test `(0 3 #u8(32)) (get-fields (integer->bitstring-little 1 3)))
347 (test 1 (bitstring->integer-little (integer->bitstring-little 1 3)))
348 (test `(0 8 #u8(15)) (get-fields (integer->bitstring-little 15 8)))
349 (test 15 (bitstring->integer-little (integer->bitstring-little 15 8)))
350 (test `(0 9 #u8(188 0)) (get-fields(integer->bitstring-little #xABC 9)))
351 (test 188 (bitstring->integer-little (integer->bitstring-little #xABC 9)))
352 (test `(0 10 #u8(188 128)) (get-fields (integer->bitstring-little #xABC 10)))
353 (test 700 (bitstring->integer-little (integer->bitstring-little #xABC 10)))
354 (test 123213 (bitstring->integer-little (integer->bitstring-little 123213 32)))
355 (test #x00000001 (bitstring->integer-little (integer->bitstring-little #x00000001 32)))
356 (test #x10000000 (bitstring->integer-little (integer->bitstring-little #x10000000 32)))
357 (test #x7FFFFFFF (bitstring->integer-little (integer->bitstring-little #x7FFFFFFF 32)))
358 (test #xFFFFFFFF (bitstring->integer-little (integer->bitstring-little #xFFFFFFFF 32)))
359 (test-end)
360
361 (test-begin "half")
362 (test +inf.0 (bitstring->half (vector->bitstring `#( #x7C #x00))))
363 (test -inf.0 (bitstring->half (vector->bitstring `#( #xFC #x00))))
364 (test 0. (bitstring->half (vector->bitstring `#( #x00 #x00))))
365 (test -0. (bitstring->half (vector->bitstring `#( #x80 #x00))))
366 (test 0.5 (bitstring->half (vector->bitstring `#( #x38 #x00))))
367 (test 1. (bitstring->half (vector->bitstring `#( #x3C #x00))))
368 (test 25. (bitstring->half (vector->bitstring `#( #x4E #x40))))
369 (test 0.099976 (bitstring->half (vector->bitstring `#( #x2E #x66))))
370 (test -0.122986 (bitstring->half (vector->bitstring `#( #xAF #xDF))))
371 ;-124.0625
372 (test-end)
373
374 (test-begin "single")
375 (test +inf.0 (bitstring->single (vector->bitstring `#( #x00 #x00 #x80 #x7F))))
376 (test -inf.0 (bitstring->single (vector->bitstring `#( #x00 #x00 #x80 #xFF))))
377 ;(test +nan.0 (bitstring->single (vector->bitstring `#( #x7F #xC0 #x00 #x00))))
378 (test 0. (bitstring->single (vector->bitstring `#( #x00 #x00 #x00 #x00))))
379 (test -0. (bitstring->single (vector->bitstring `#( #x00 #x00 #x00 #x80))))
380 (test #t (equal? 1. (bitstring->single (vector->bitstring `#( #x00 #x00 #x80 #x3f)))))
381 (test 0.5 (bitstring->single (vector->bitstring `#( #x00 #x00 #x00 #x3f))))
382 (test 25. (bitstring->single (vector->bitstring `#( #x00 #x00 #xc8 #x41))))
383 (test 0.1 (bitstring->single (vector->bitstring `#( #xcd #xcc #xcc #x3d))))
384 (test -0.123 (bitstring->single (vector->bitstring `#( #xE7 #x6D #xFB #xBD))))
385 (test `(0 32 #u8( #x00 #x00 #x00 #x3f)) (get-fields (single->bitstring 0.5)))
386 (test `(0 32 #u8( #x6D #xE7 #xFB #xBD)) (get-fields (single->bitstring -0.123)))
387 (test-end)
388
389 (test-begin "boolean")
390 (test #t (bitmatch (bitconstruct (#t boolean))
391 (((B boolean)) B)))
392
393 (test #t (bitmatch (bitconstruct (#t 32 boolean))
394 (((B 32 boolean)) B)))
395
396 (test #t (bitmatch (bitconstruct (#t 32 boolean little))
397 (((B 32 boolean little)) B)))
398
399 (test #f (bitmatch (bitconstruct (#f 16 boolean host))
400 (((B 16 boolean host)) B)
401 (((X bitstring)) X)))
402
403 (test (vector 0.0 0.0 #t #t)
404 (bitmatch (u8vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
405 (((a double big) (b double big) (c boolean) (d boolean))
406 (vector a b c d))))
407
408 (test (list 1) (bitstring->list (bitconstruct (#t boolean)) 8))
409 (test (list 0) (bitstring->list (bitconstruct (#f boolean)) 8))
410 (test-end)
411
412 (test-begin "reader proc")
413
414 (define (zterminated-string bs)
415 (let loop ((n 8) (acc '()))
416 (bitmatch (or (bitstring-read bs 8) "")
417 (() -> #f) ; end of stream
418 ((0) -> (list n (list->string (reverse acc))))
419 ((c) -> (loop (+ n 8) (cons (integer->char c) acc))))))
420 (test "BC" (bitmatch "ABC\x00" ((("A") ((str zterminated-string) bitstring)) str)))
421 (test-error (bitmatch "ABC" ((("A") ((str zterminated-string) bitstring)) str)))
422 (test #f (bitmatch "ABC" ((("A") ((str zterminated-string) bitstring)) str) (else #f)))
423
424 (test-end)
425
426 (test-begin "offset")
427 (test 32 (bitmatch "ABCD" (((start offset) ("ABCD") (end offset)) (- end start))))
428 (test 6 (bitmatch "X" (((_ 1) (start offset) (_ 6) (end offset) (_ 1)) (- end start))))
429 (test 5 (bitmatch "X" (((_ 3) (rest bitstring))
430 (bitmatch rest (((start offset) (_ 5) (end offset)) (- end start))))))
431 (test (list 3 8)
432 (bitmatch "X" (((_ 3) (rest bitstring))
433 (bitmatch rest (((start offset) (_ 5) (end offset)) (list start end))))))
434 (test-end)
435
436 (test-begin "seek")
437 (test #t (bitmatch "ABC" ((("A") (-8 seek) ("ABC")) #t)))
438 (test #t (bitmatch "ABC" (((+8 seek) ("BC")) #t)))
439 (test #t (bitmatch "ABC" (((0 seek) ("ABC")) #t)))
440 (test #t (bitmatch "ABC" (((-0 seek) ("ABC")) #t)))
441 (test-error (bitmatch "ABC" ((("A") (-16 seek) (rest bitstring)) #t)))
442 (test-error (bitmatch "ABC" ((("A") (+20 seek) (rest bitstring)) #t)))
443 (test-end)
444
445 (test-end "bitstring")
446
447 (test-exit)
448