bitstring.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
---
bitstring.scm (31269B)
---
1 (module bitstring
2 (bitmatch
3 bitpacket
4 bitconstruct
5 bitstring-pattern-continue
6 make-bitstring
7 bitstring?
8 bitstring-length
9 ->bitstring
10 vector->bitstring
11 u8vector->bitstring
12 string->bitstring
13 blob->bitstring
14 bitstring-read
15 bitstring-share
16 bitstring-seek
17 bitstring-create
18 bitstring-reserve
19 bitstring=?
20 bitstring-append
21 bitstring-append!
22 bitstring-not
23 bitstring-bit-set?
24 bitstring-reverse
25 bitstring->list
26 bitstring->blob
27 bitstring->string
28 bitstring->vector
29 bitstring->u8vector
30 bitstring->integer
31 bitstring->integer-big
32 bitstring->integer-little
33 bitstring->integer-host
34 integer->bitstring
35 integer->bitstring-big
36 integer->bitstring-little
37 integer->bitstring-host
38 bitstring-start
39 bitstring-end
40 bitstring-buffer
41 bitstring-getter
42 bitstring->half
43 bitstring->single
44 single->bitstring
45 bitstring->double
46 double->bitstring
47 list->bitstring)
48
49 (import scheme (chicken base) (chicken fixnum) (chicken bitwise) (chicken blob) (chicken format) srfi-1 srfi-4 bitstring-lowlevel)
50
51 (define-syntax symbol??
52 (er-macro-transformer
53 (lambda (e r c)
54 (let* ((args (cdr e))
55 (name (car args))
56 (yes (cadr args))
57 (no (caddr args)))
58 (if (symbol? name) yes no)))))
59
60 ; (expand-value x char str int)
61 (define-syntax expand-value
62 (er-macro-transformer
63 (lambda (e r c)
64 (let* ((args (cdr e))
65 (name (car args))
66 (char-branch (cadr args))
67 (string-branch (caddr args))
68 (integer-branch (cadddr args)))
69 (cond
70 ((char? name) char-branch)
71 ((string? name) string-branch)
72 ((integer? name) integer-branch)
73 (else (error "(bitstring) invalid value" `name)))))))
74
75 (define-syntax bitpacket-def-fields
76 (syntax-rules ()
77 ((_ name fields ...)
78 (define-syntax name
79 (er-macro-transformer
80 ;;(name mode stream handler PREFIX rest ...)
81 (lambda (e r c)
82 (define (rename-with-prefix prefix pat)
83 (let* ((n (length pat))
84 (rename (lambda (sym)
85 (string->symbol (string-append (symbol->string prefix)
86 "." (symbol->string sym))))))
87 (or (>= n 1)
88 (syntax-error "(bitstring) invalid bitpacket field pattern" pat))
89 (cond ((and (>= n 1) (symbol? (first pat)))
90 (cons (rename (first pat)) (cdr pat)))
91 (else pat))))
92 (let* ((args (cdr e))
93 (mode (first args))
94 (stream (second args))
95 (handler (third args))
96 (prefix (fourth args))
97 (rest (drop args 4)))
98 (or (symbol? prefix)
99 (equal? prefix #f)
100 (syntax-error "(bitstring) invalid bitpacket prefix" prefix))
101 ;; inline bitpacket fields
102 `(bitstring-pattern-continue ,mode
103 ,stream
104 ,handler
105 ,(if prefix
106 (map (lambda (pat) (rename-with-prefix prefix pat)) '(fields ...))
107 '(fields ...))
108 ,rest))))))))
109
110 (define-syntax bitpacket
111 (syntax-rules ()
112 ((_ (name constructor) fields ...)
113 (begin
114 (bitpacket-def-fields name fields ...)
115 (define-syntax constructor
116 (syntax-rules ()
117 ((_ . args)
118 (let args
119 (bitconstruct (name bitpacket))))))))
120 ((_ name fields ...)
121 (bitpacket-def-fields name fields ...))))
122
123
124 (define-syntax bitstring-pattern-continue
125 (syntax-rules ()
126 ((_ mode stream handler (fields ...) (rest ...))
127 (bitstring-pattern mode stream handler fields ... rest ...))))
128
129 (define-syntax make-bitmatch-result
130 (syntax-rules () ((_ (handler ...))
131 (list (begin handler ...)))))
132
133 (define-syntax bitmatch-result
134 (syntax-rules () ((_ result)
135 (car result))))
136
137 (define-syntax bitconstruct
138 (syntax-rules ()
139 ((_ patterns ...)
140 (let ((bstr (bitstring-reserve 64)))
141 (bitstring-pattern "write" bstr "no-handler" patterns ...)))))
142
143 (define-syntax bitmatch
144 (syntax-rules ()
145 ((_ value . patterns)
146 (let ((bstr (->bitstring value)))
147 (bitmatch-result (bitmatch-pattern-list bstr patterns))))))
148
149 (define-syntax bitmatch-pattern-list
150 (syntax-rules (else ->)
151 ((_ bstr ())
152 (error "(bitstring) no matching pattern"
153 (list 'offset (bitstring-start bstr))))
154 ((_ bstr ((else . handler)))
155 (make-bitmatch-result handler))
156 ; short syntax form (pat ... patX -> exp)
157 ((_ bstr ((pattern ... -> handler) . rest))
158 (or (bitmatch-pattern bstr (handler) (pattern ...))
159 (bitmatch-pattern-list bstr rest)))
160 ((_ bstr ((pattern . handler) . rest))
161 (or (bitmatch-pattern bstr handler pattern)
162 (bitmatch-pattern-list bstr rest)))))
163
164 (define-syntax bitmatch-pattern
165 (syntax-rules ()
166 ((_ bstr handler (pattern ...))
167 ; shared copy of bitstring instance
168 (let ((stream (bitstring-share bstr (bitstring-start bstr) (bitstring-end bstr))))
169 (bitstring-pattern "read" stream handler pattern ...)))))
170
171 (define-syntax bitstring-pattern
172 (syntax-rules (big little host bitstring check float double bitpacket signed unsigned boolean offset seek)
173 ; all patterns take expansion
174 ((_ "read" stream handler)
175 (and
176 ; ensure that no more bits left
177 (zero? (bitstring-length stream))
178 (make-bitmatch-result handler)))
179 ((_ "write" stream handler)
180 stream)
181 ; zero-length bitstring
182 ((_ "read" stream handler ())
183 (and
184 (zero? (bitstring-length stream))
185 (make-bitmatch-result handler)))
186 ((_ "write" stream handler ())
187 stream)
188 ; user guard expression
189 ((_ mode stream handler (check guard) rest ...)
190 (and
191 guard
192 (bitstring-pattern mode stream handler rest ...)))
193 ; evaluate constructing function
194 ((_ "write" stream handler ((VALUE ...) bitstring) rest ...)
195 (and-let* ((tmp (VALUE ...))
196 (bits (bitstring-length tmp)))
197 (bitstring-pattern "write" stream handler (tmp bits bitstring) rest ...)))
198 ; evaluate reader procedure (PROC) -> returns #f or (list num-bits-readed any-value)
199 ((_ "read" stream handler ((name PROC ...) bitstring) rest ...)
200 (and-let* ((tmp (->bitstring stream))
201 (res (PROC ... tmp))
202 (bits (first res)) ; length
203 (name (second res))) ; value
204 (bitstring-pattern "read" stream handler (tmp bits bitstring) rest ...)))
205 ; tell current stream offset
206 ((_ "read" stream handler (NAME offset) rest ...)
207 (let ((NAME (bitstring-start stream)))
208 (bitstring-pattern "read" stream handler rest ...)))
209 ; move current stream offset
210 ((_ "read" stream handler (OFFS seek) rest ...)
211 (and-let* ((with-offset (bitstring-seek stream OFFS)))
212 (bitstring-pattern "read" with-offset handler rest ...)))
213 ; bitpacket
214 ((_ mode stream handler (NAME bitpacket) rest ...)
215 (NAME mode stream handler #f rest ...))
216 ; bitpacket with prefix
217 ((_ mode stream handler (PREFIX NAME bitpacket) rest ...)
218 (NAME mode stream handler PREFIX rest ...))
219 ; allow in bitconstruct dont type length
220 ((_ "write" stream handler (NAME bitstring) rest ...)
221 (bitstring-pattern-expand "write" stream NAME
222 (bitstring-pattern "write" stream handler rest ...)))
223 ; greedy bitstring
224 ((_ mode stream handler (NAME bitstring))
225 (bitstring-pattern-expand mode stream NAME
226 (bitstring-pattern mode stream handler)))
227 ; boolean
228 ((_ mode stream handler (NAME boolean) rest ...)
229 (bitstring-pattern-expand mode stream NAME 8 (boolean big unsigned)
230 (bitstring-pattern mode stream handler rest ...)))
231 ; boolean bits
232 ((_ mode stream handler (NAME BITS boolean) rest ...)
233 (bitstring-pattern-expand mode stream NAME BITS (boolean big unsigned)
234 (bitstring-pattern mode stream handler rest ...)))
235 ; boolean bits endian
236 ((_ mode stream handler (NAME BITS boolean ENDIAN) rest ...)
237 (bitstring-pattern-expand mode stream NAME BITS (boolean ENDIAN unsigned)
238 (bitstring-pattern mode stream handler rest ...)))
239 ; double 64
240 ((_ mode stream handler (NAME double) rest ...)
241 (bitstring-pattern-expand mode stream NAME 64 (float big)
242 (bitstring-pattern mode stream handler rest ...)))
243 ((_ mode stream handler (NAME double ENDIAN) rest ...)
244 (bitstring-pattern-expand mode stream NAME 64 (float ENDIAN)
245 (bitstring-pattern mode stream handler rest ...)))
246 ; float 32
247 ((_ mode stream handler (NAME float) rest ...)
248 (bitstring-pattern-expand mode stream NAME 32 (float big)
249 (bitstring-pattern mode stream handler rest ...)))
250 ((_ mode stream handler (NAME float ENDIAN) rest ...)
251 (bitstring-pattern-expand mode stream NAME 32 (float ENDIAN)
252 (bitstring-pattern mode stream handler rest ...)))
253 ; generic float bits
254 ((_ mode stream handler (NAME BITS float) rest ...)
255 (bitstring-pattern-expand mode stream NAME BITS (float big)
256 (bitstring-pattern mode stream handler rest ...)))
257 ((_ mode stream handler (NAME BITS float ENDIAN) rest ...)
258 (bitstring-pattern-expand mode stream NAME BITS (float ENDIAN)
259 (bitstring-pattern mode stream handler rest ...)))
260 ; bigendian
261 ((_ mode stream handler (NAME BITS big) rest ...)
262 (bitstring-pattern-expand mode stream NAME BITS (big unsigned)
263 (bitstring-pattern mode stream handler rest ...)))
264 ; littleendian
265 ((_ mode stream handler (NAME BITS little) rest ...)
266 (bitstring-pattern-expand mode stream NAME BITS (little unsigned)
267 (bitstring-pattern mode stream handler rest ...)))
268 ; same endianness as host
269 ((_ mode stream handler (NAME BITS host) rest ...)
270 (bitstring-pattern-expand mode stream NAME BITS (host unsigned)
271 (bitstring-pattern mode stream handler rest ...)))
272 ; bitstring
273 ((_ mode stream handler (NAME BITS bitstring) rest ...)
274 (bitstring-pattern-expand mode stream NAME BITS bitstring
275 (bitstring-pattern mode stream handler rest ...)))
276 ; integer attibutes
277 ((_ mode stream handler (NAME BITS signed) rest ...)
278 (bitstring-pattern-expand mode stream NAME BITS (big signed)
279 (bitstring-pattern mode stream handler rest ...)))
280 ((_ mode stream handler (NAME BITS unsigned) rest ...)
281 (bitstring-pattern-expand mode stream NAME BITS (big unsigned)
282 (bitstring-pattern mode stream handler rest ...)))
283 ((_ mode stream handler (NAME BITS signed ENDIAN) rest ...)
284 (bitstring-pattern-expand mode stream NAME BITS (ENDIAN signed)
285 (bitstring-pattern mode stream handler rest ...)))
286 ((_ mode stream handler (NAME BITS unsigned ENDIAN) rest ...)
287 (bitstring-pattern-expand mode stream NAME BITS (ENDIAN unsigned)
288 (bitstring-pattern mode stream handler rest ...)))
289 ((_ mode stream handler (NAME BITS ENDIAN SIGNED) rest ...)
290 (bitstring-pattern-expand mode stream NAME BITS (ENDIAN SIGNED)
291 (bitstring-pattern mode stream handler rest ...)))
292 ((_ mode stream handler (NAME signed) rest ...)
293 (bitstring-pattern-expand mode stream NAME 8 (big signed)
294 (bitstring-pattern mode stream handler rest ...)))
295 ((_ mode stream handler (NAME unsigned) rest ...)
296 (bitstring-pattern-expand mode stream NAME 8 (big unsigned)
297 (bitstring-pattern mode stream handler rest ...)))
298 ; rewrite by default to (NAME BITS (big unsigned))
299 ((_ mode stream handler (NAME BITS) rest ...)
300 (bitstring-pattern mode stream handler (NAME BITS big) rest ...))
301 ; rewrite immidiate value
302 ((_ mode stream handler (NAME) rest ...)
303 (symbol?? NAME
304 ; yes
305 (bitstring-pattern mode stream handler (NAME 8 big) rest ...)
306 ; no
307 (bitstring-pattern-value mode stream handler (NAME) rest ...)))
308 ; dismiss other pattern forms
309 ((_ mode stream handler . rest)
310 (syntax-error "(bitstring) malformed pattern" `rest))))
311
312 (define-syntax bitstring-pattern-value
313 (syntax-rules ()
314 ((_ mode stream handler (VALUE) rest ...)
315 (expand-value VALUE
316 ; char
317 (bitstring-pattern mode stream handler ((char->integer VALUE) 8 big) rest ...)
318 ; string
319 (bitstring-pattern mode stream handler
320 (VALUE (* 8 (string-length VALUE)) bitstring) rest ...)
321 ; integer
322 (bitstring-pattern mode stream handler (VALUE 8 big) rest ...)))))
323
324 (define-syntax bitstring-pattern-expand
325 (syntax-rules ()
326 ((_ "write" stream name continuation)
327 (and-let* ((tmp (->bitstring name)))
328 ;(print "write-expand:" `stream " name:" `name)
329 (bitstring-append! stream tmp)
330 continuation))
331 ((_ "write" stream name bits type continuation)
332 (and-let* ((tmp (bitstring-write-expand name bits type)))
333 ;(print "write-expand:" `stream " name:" `name)
334 (bitstring-append! stream tmp)
335 continuation))
336 ((_ "read" stream name continuation) ; read all rest bytes
337 (symbol?? name
338 (and-let* ((name (bitstring-read stream (bitstring-length stream))))
339 ;(print "read-expand: " `(name bits type) " rest: " `continuation)
340 continuation)
341 (syntax-error "(bitstring) not a symbol name" `name)))
342 ((_ "read" stream name bits type continuation)
343 (and-let* ((tmp (bitstring-read stream bits)))
344 (symbol?? name
345 (let ((name (bitstring-read-expand tmp bits type)))
346 continuation)
347 (and (optimize-compare tmp name bits type)
348 continuation))))))
349
350 (define-syntax optimize-compare
351 (syntax-rules ()
352 ((_ tmp value bits (ENDIAN SIGNED))
353 (= value (bitstring-read-integer tmp bits ENDIAN SIGNED)))
354 ((_ tmp value bits type)
355 (bitstring=? tmp (bitstring-write-expand value bits type)))))
356
357 (define-syntax float-reorder-bytes
358 (syntax-rules (little big host)
359 ((_ host tmp)
360 (cond-expand
361 (little-endian (float-reorder-bytes little tmp))
362 (else (float-reorder-bytes big tmp))))
363 ((_ little tmp)
364 (cond-expand
365 (little-endian tmp)
366 (else (bitstring-reverse tmp 8))))
367 ((_ big tmp)
368 (cond-expand
369 (little-endian (bitstring-reverse tmp 8))
370 (else tmp)))))
371
372 (define-syntax bitstring-read-expand
373 (syntax-rules (bitstring float boolean)
374 ((_ tmp 32 (float ENDIAN))
375 (bitstring->single (float-reorder-bytes ENDIAN tmp)))
376 ((_ tmp 64 (float ENDIAN))
377 (bitstring->double (float-reorder-bytes ENDIAN tmp)))
378 ((_ tmp bits (boolean ENDIAN SIGNED))
379 (not (zero? (bitstring-read-integer tmp bits ENDIAN SIGNED))))
380 ((_ tmp bits (ENDIAN SIGNED))
381 (bitstring-read-integer tmp bits ENDIAN SIGNED))
382 ((_ tmp bits bitstring)
383 tmp))) ; return bitstring as is
384
385 (define-syntax bitstring-read-integer
386 (syntax-rules (big little host signed unsigned)
387 ((_ tmp bits big signed)
388 (if (bitstring-bit-set? tmp 0)
389 (- (+ 1 (bitstring->integer-big (bitstring-not tmp))))
390 (bitstring->integer-big tmp)))
391 ((_ tmp bits little signed)
392 (if (bitstring-bit-set? tmp (if (< bits 8) (sub1 bits) (- bits 8)))
393 (- (+ 1 (bitstring->integer-little (bitstring-not tmp))))
394 (bitstring->integer-little tmp)))
395 ((_ tmp bits host signed)
396 (cond-expand
397 (little-endian (bitstring-read-integer tmp bits little signed))
398 (else (bitstring-read-integer tmp bits big signed))))
399 ((_ tmp bits big unsigned)
400 (bitstring->integer-big tmp))
401 ((_ tmp bits little unsigned)
402 (bitstring->integer-little tmp))
403 ((_ tmp bits host unsigned)
404 (bitstring->integer-host tmp))
405 ((_ tmp bits ENDIAN SIGNED)
406 (syntax-error "(bitstring) invalid integer attibute" `ENDIAN `SIGNED))))
407
408 (define-syntax bitstring-write-expand
409 (syntax-rules (bitstring float boolean)
410 ((_ tmp 32 (float ENDIAN))
411 (float-reorder-bytes ENDIAN (single->bitstring tmp)))
412 ((_ tmp 64 (float ENDIAN))
413 (float-reorder-bytes ENDIAN (double->bitstring tmp)))
414 ((_ tmp bits (boolean ENDIAN SIGNED))
415 (bitstring-write-integer (if tmp 1 0) bits ENDIAN SIGNED))
416 ((_ tmp bits (ENDIAN SIGNED))
417 (bitstring-write-integer tmp bits ENDIAN SIGNED))
418 ((_ tmp bits bitstring)
419 (if (bitstring? tmp)
420 tmp
421 (->bitstring tmp)))))
422
423 (define-syntax bitstring-write-integer
424 (syntax-rules (big little host signed unsigned)
425 ((_ tmp bits big signed)
426 (integer->bitstring-big tmp bits))
427 ((_ tmp bits little signed)
428 (integer->bitstring-little tmp bits))
429 ((_ tmp bits host signed)
430 (integer->bitstring-host tmp bits))
431 ((_ tmp bits big unsigned)
432 (integer->bitstring-big tmp bits))
433 ((_ tmp bits little unsigned)
434 (integer->bitstring-little tmp bits))
435 ((_ tmp bits host unsigned)
436 (integer->bitstring-host tmp bits))
437 ((_ tmp bits ENDIAN SIGNED)
438 (syntax-error "(bitstring) invalid integer attibute" `ENDIAN `SIGNED))))
439
440
441 ;;;;;;;;;;;;;;;;;;;;;;
442 ;; bitstring
443
444 (define-record bitstring
445 start ; buffer offset in bits
446 end ; buffer offset in bits
447 buffer ; any container with random access
448 getter ; (lambda (buffer index) -> byte)
449 setter) ; (lambda (buffer index byte) -> void)
450
451 (define-record-printer (bitstring x out)
452 (fprintf out "<bitstring ~A ~A ~A>"
453 (bitstring-start x) (bitstring-end x) (bitstring-buffer x)))
454
455 (define (bitstring-length bs)
456 (- (bitstring-end bs) (bitstring-start bs)))
457
458 ; compute space required for {{n}} bits
459 (define (space-required n)
460 (+ (quotient n 8) (if (zero? (remainder n 8)) 0 1)))
461
462 (define (bitstring-create)
463 (bitstring-reserve 128))
464
465 (define (bitstring-reserve size-in-bits)
466 (let ((size (space-required size-in-bits)))
467 (make-bitstring 0 0 (make-u8vector size 0) u8vector-ref u8vector-set!)))
468
469 (define (string->bitstring s)
470 (make-bitstring 0 (* 8 (string-length s)) s
471 (lambda (str index) (char->integer (string-ref str index)))
472 (lambda (str index byte) (string-set! str index (integer->char byte)))))
473
474 (define (vector->bitstring v)
475 (make-bitstring 0 (* 8 (vector-length v)) v vector-ref vector-set!))
476
477 (define (u8vector->bitstring v)
478 (make-bitstring 0 (* 8 (u8vector-length v)) v u8vector-ref u8vector-set!))
479
480 (define (blob->bitstring b)
481 (u8vector->bitstring (blob->u8vector/shared b)))
482
483 (define (->bitstring x)
484 (cond
485 ((bitstring? x)
486 (bitstring-share x (bitstring-start x) (bitstring-end x)))
487 ((u8vector? x)
488 (u8vector->bitstring x))
489 ((string? x)
490 (string->bitstring x))
491 ((vector? x)
492 (vector->bitstring x))
493 ((blob? x)
494 (u8vector->bitstring (blob->u8vector/shared x)))
495 (else
496 (error "(bitstring) not implemented for this value type" x))))
497
498 (define (bitstring->blob bs #!optional (zero-extending 'left))
499 (u8vector->blob/shared (bitstring->u8vector bs zero-extending)))
500
501 (define (bitstring->u8vector bs #!optional (zero-extending 'left))
502 ; make bs copy for mutable bitstring-read
503 (let loop ((bs (bitstring-share bs (bitstring-start bs) (bitstring-end bs)))
504 (n (bitstring-length bs))
505 (index 0)
506 (tmp (make-u8vector (space-required (bitstring-length bs)))))
507 (cond
508 ((zero? n)
509 tmp)
510 ((< n 8)
511 (let ((byte (bitstring->integer-big (bitstring-read bs n))))
512 (u8vector-set! tmp index (if (eq? zero-extending 'left)
513 byte
514 (fxshl byte (- 8 n))))
515 tmp))
516 (else
517 (u8vector-set! tmp index (bitstring->integer-big (bitstring-read bs 8)))
518 (loop bs (- n 8) (add1 index) tmp)))))
519
520 (define (bitstring->string bs)
521 (list->string (map integer->char (bitstring->list bs 8))))
522
523 (define (bitstring->vector bs)
524 (list->vector (bitstring->list bs 8)))
525
526 (define (bitstring->list bs #!optional (bits 1) (endian 'big))
527 (bitstring->listn bs bits endian))
528
529 (define (bitstring->listn bs bits endian)
530 (let loop ((bs (->bitstring bs)); make copy for mutable bitstring-read
531 (n (bitstring-length bs))
532 (acc (list)))
533 (cond ((zero? n)
534 (reverse acc))
535 ((< n bits)
536 (loop bs 0
537 (cons (bitstring->integer (bitstring-read bs n) endian) acc)))
538 (else
539 (loop bs (- n bits)
540 (cons (bitstring->integer (bitstring-read bs bits) endian) acc))))))
541
542 (define (list->bitstring lst #!optional (bits 1) (endian 'big))
543 (let loop ((rest lst)
544 (acc (bitstring-reserve (* (length lst) bits))))
545 (if (null-list? rest)
546 acc
547 (loop (cdr rest) (bitstring-append! acc (integer->bitstring (car rest) bits endian))))))
548
549 (define (bitstring-reverse bs #!optional (bits 1) (endian 'big))
550 (list->bitstring (reverse (bitstring->list bs bits endian)) bits endian))
551
552 (define (bitstring=? a b)
553 (and
554 (= (bitstring-length a) (bitstring-length b))
555 (if (and (bytestring? a) (bytestring? b))
556 (bytestring=? a b)
557 (equal? (bitstring->list a 8) (bitstring->list b 8)))))
558
559 (define (bytestring? bs)
560 (and (zero? (remainder (bitstring-start bs) 8))
561 (zero? (remainder (bitstring-length bs) 8))))
562
563 (define (bytestring=? a b)
564 (let ((alen (quotient (bitstring-length a) 8))
565 (blen (quotient (bitstring-length b) 8))
566 (e (quotient (bitstring-end a) 8)))
567 (and (= alen blen)
568 (let loop ((i (quotient (bitstring-start a) 8))
569 (j (quotient (bitstring-start b) 8)))
570 (if (< i e)
571 (if (= (bitstring-load-byte a i)
572 (bitstring-load-byte b j))
573 (loop (add1 i) (add1 j))
574 #f)
575 #t)))))
576
577 (define (bitstring-load-byte bs index)
578 ((bitstring-getter bs) (bitstring-buffer bs) index))
579
580 (define (bitstring-store-byte bs index value)
581 ((bitstring-setter bs) (bitstring-buffer bs) index value))
582
583 ; extract {{count}} bits starting from {{offset}}, {{value}} should'be 8 bit integer.
584 (define-inline (extract-bits value offset count)
585 (fxshr (fxand (fxshl value offset) #xFF)
586 (- 8 count)))
587
588 (define (bitstring-fold proc init bs)
589 (let loop ((start (bitstring-start bs))
590 (end (bitstring-end bs))
591 (index (quotient (bitstring-start bs) 8))
592 (drift (remainder (bitstring-start bs) 8))
593 (count (- 8 (remainder (bitstring-start bs) 8)))
594 (acc init))
595 (let ((n (min (- end start) count)))
596 (if (<= n 0)
597 acc
598 (loop (+ start n) end
599 (add1 index) ; move index
600 0 ; reset drift
601 8 ; setup 8 bit chunk
602 (proc (extract-bits (bitstring-load-byte bs index) drift n) n acc))))))
603
604 (define (bitstring-not bs)
605 (let ((len (bitstring-length bs))
606 (tmp (bitstring->u8vector bs 'right)))
607 (u8vector-not tmp (u8vector-length tmp))
608 (make-bitstring 0 len tmp u8vector-ref u8vector-set!)))
609
610 (define (bitstring-bit-set? bs n)
611 (let ((start (bitstring-start bs))
612 (end (bitstring-end bs)))
613 (let* ((index (if (negative? n)
614 (+ end n)
615 (+ start n)))
616 (byte-index (quotient index 8))
617 (bit-index (- 7 (remainder index 8))))
618 (if (and (<= start index) (< index end))
619 (bit->boolean (bitstring-load-byte bs byte-index) bit-index)
620 (error "(bitstring) out of range" start end n)))))
621
622 (define (bitstring->integer-big bs)
623 (bitstring-fold
624 (lambda (value count result)
625 (bitwise-ior (arithmetic-shift result count) value))
626 0
627 bs))
628
629 (define (bitstring->integer-little bs)
630 (car (bitstring-fold
631 (lambda (value count acc)
632 (let ((result (car acc))
633 (shift (cdr acc)))
634 (cons (bitwise-ior result (arithmetic-shift value shift))
635 (+ shift count))))
636 (cons 0 0)
637 bs)))
638
639 (define (integer->bitstring-little value count)
640 (let loop ((start 0)
641 (n (min count 8))
642 (bs (bitstring-reserve count)))
643 (bitstring-end-set! bs count)
644 (if (<= count start)
645 bs
646 (let ((x (bitwise-and (arithmetic-shift value (- start)) 255)))
647 (bitstring-store-byte bs (quotient start 8) (fxshl x (- 8 n)))
648 (loop (+ start n) (min (- count start n) 8) bs)))))
649
650 (define (integer->bitstring-big value count)
651 (let loop ((start count)
652 (n (min count 8))
653 (bs (bitstring-reserve count)))
654 (bitstring-end-set! bs count)
655 (if (<= start 0)
656 bs
657 (let ((x (bitwise-and (arithmetic-shift value (- n start)) 255)))
658 (bitstring-store-byte bs (quotient (- count start) 8) (fxshl x (- 8 n)))
659 (loop (- start n) (min start 8) bs)))))
660
661 (define (bitstring->integer bitstring endian)
662 (case endian
663 ((big)
664 (bitstring->integer-big bitstring))
665 ((little)
666 (bitstring->integer-little bitstring))
667 ((host)
668 (bitstring->integer-host bitstring))
669 (else
670 (error "(bitstring) invalid endian value" `endian))))
671
672 (define bitstring->integer-host
673 (cond-expand
674 (little-endian bitstring->integer-little)
675 (else bitstring->integer-big)))
676
677 (define integer->bitstring-host
678 (cond-expand
679 (little-endian integer->bitstring-little)
680 (else integer->bitstring-big)))
681
682 (define (integer->bitstring value count endian)
683 (case endian
684 ('little
685 (integer->bitstring-little value count))
686 ('host
687 (integer->bitstring-host value count))
688 (else
689 (integer->bitstring-big value count))))
690
691 (define (bitstring->half bs)
692 (let ((s (bitstring-read bs 1))
693 (e (bitstring-read bs 5))
694 (m (bitstring-read bs 10)))
695 (make-half-float
696 (bitstring->integer-big s)
697 (bitstring->integer-big e)
698 (bitstring->integer-big m))))
699
700 (define (make-half-float signbit exponent mantissa)
701 ;(newline)
702 ;(print "s: " signbit " e: " exponent " m: " mantissa)
703 (cond
704 ((and (zero? exponent) (zero? mantissa))
705 (if (zero? signbit) +0. -0.))
706 ((= exponent 31)
707 (if (zero? mantissa)
708 (if (zero? signbit) +inf.0 -inf.0)
709 (if (zero? signbit) +nan.0 -nan.0)))
710 (else
711 (let ((e (- exponent 15))
712 (m (bitwise-ior #x400 mantissa)))
713 (let loop ((i 10) (s 1.) (f 0.))
714 (let* ((x (arithmetic-shift 1 i))
715 (b (bitwise-and m x)))
716 (if (or (zero? i))
717 (* f (expt 2 e) (if (zero? signbit) 1. -1.))
718 (loop (- i 1) (/ s 2) (if (zero? b) f (+ f s))))))))))
719
720 (define (single->bitstring value)
721 (let ((buf (make-u8vector 4)))
722 (float->uint32 buf value)
723 (->bitstring buf)))
724
725 (define (double->bitstring value)
726 (let ((buf (make-u8vector 8)))
727 (double->uint64 buf value)
728 (->bitstring buf)))
729
730 (define (bitstring->single bs)
731 (uint32->float (bitstring->blob bs)))
732
733 (define (bitstring->double bs)
734 (uint64->double (bitstring->blob bs)))
735
736 (define (bitstring-share bs from to)
737 (make-bitstring from to (bitstring-buffer bs) (bitstring-getter bs) (bitstring-setter bs)))
738
739 (define (bitstring-seek bs offs)
740 (let ((from (+ (bitstring-start bs) offs))
741 (to (bitstring-end bs)))
742 (and (<= 0 from)
743 (<= from to)
744 (bitstring-share bs from to))))
745
746 (define (bitstring-read bs n)
747 (let ((from (bitstring-start bs))
748 (to (+ (bitstring-start bs) n)))
749 (and (<= to (bitstring-end bs))
750 (let ((bs/shared (bitstring-share bs from to)))
751 (bitstring-start-set! bs to)
752 bs/shared))))
753
754 (define (bitstring-buffer-size bs)
755 (let ((buffer (bitstring-buffer bs)))
756 (* 8 ; return size in bits
757 (cond
758 ((u8vector? buffer)
759 (u8vector-length buffer))
760 ((string? buffer)
761 (string-length buffer))
762 (else
763 (error "(bitstring) not implemented for this buffer type"))))))
764
765 (define (bitstring-buffer-resize bs size-in-bits)
766 (let* ((new-size (space-required size-in-bits))
767 (tmp (make-u8vector new-size 0))
768 (used (bitstring-buffer-size bs)))
769 (let copy ((i 0)
770 (e (quotient used 8)))
771 (when (< i e)
772 (u8vector-set! tmp i (bitstring-load-byte bs i))
773 (copy (+ i 1) e)))
774 ; replace buffer with accessors
775 (bitstring-buffer-set! bs tmp)
776 (bitstring-getter-set! bs u8vector-ref)
777 (bitstring-setter-set! bs u8vector-set!)))
778
779 (define (bitstring-required-length args)
780 (fold
781 (lambda (bs len)
782 (+ len (bitstring-length bs)))
783 0
784 args))
785
786 (define (bitstring-append . args)
787 (fold
788 (lambda (bs acc)
789 (bitstring-append! acc bs))
790 (bitstring-reserve (bitstring-required-length args))
791 args))
792
793 (define (bitstring-append! dst . args)
794 (fold
795 (lambda (bs acc)
796 (bitstring-append2! acc bs))
797 dst
798 args))
799
800 (define (bitstring-append2! dest src)
801 ; need ensure that dest buffer long enough
802 (let ((required (bitstring-length src))
803 (position (bitstring-end dest))
804 (reserved (bitstring-buffer-size dest)))
805 (when (< (- reserved position) required)
806 (bitstring-buffer-resize dest
807 (+ reserved (inexact->exact (* 0.50 reserved)) required)))
808 (bitstring-fold
809 (lambda (value nbits acc)
810 (bitstring-append-safe! acc (fxshl value (- 8 nbits)) nbits))
811 dest
812 src)))
813
814 (define (bitstring-append-safe! bs value nbits)
815 (let* ((position (bitstring-end bs))
816 (index (quotient position 8))
817 (drift (remainder position 8)))
818 (if (zero? drift)
819 ; store aligned
820 (begin
821 (bitstring-store-byte bs index value)
822 (bitstring-end-set! bs (+ position nbits)))
823 ; store unaligned
824 (let ((byte-src (bitstring-load-byte bs index))
825 (byte-dst (fxshr value drift))
826 (restbits (- 8 drift)))
827 (bitstring-store-byte bs index (fxior byte-src byte-dst))
828 ; store rest bits if didnt fit in current byte
829 (if (< restbits nbits)
830 (bitstring-store-byte bs (+ index 1) (fxshl value restbits)))
831 (bitstring-end-set! bs (+ position nbits))))
832 bs));return bitstring
833
834 );module