initial import from mercurial master - 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
---
(DIR) commit 0e2b01cfa97cd5d5131862bc7611fd03ca5c389d
(HTM) Author: Christian Kellermann <ckeen@pestilenz.org>
Date: Mon, 30 Jul 2018 15:35:55 +0200
initial import from mercurial master
Diffstat:
README | 3 +++
bitstring-lowlevel.scm | 25 +++++++++++++++++++++++++
bitstring.egg | 8 ++++++++
bitstring.scm | 834 +++++++++++++++++++++++++++++++
tests/24compressed.tga | 0
tests/24uncompressed.tga | 0
tests/examples.scm | 178 +++++++++++++++++++++++++++++++
tests/run.scm | 448 +++++++++++++++++++++++++++++++
tests/tga.scm | 90 +++++++++++++++++++++++++++++++
9 files changed, 1586 insertions(+), 0 deletions(-)
---
(DIR) diff --git a/README b/README
@@ -0,0 +1,3 @@
+Easy binary parsing with Chicken scheme.
+
+Doc: https://wiki.call-cc.org/eggref/4/bitstring
(DIR) diff --git a/bitstring-lowlevel.scm b/bitstring-lowlevel.scm
@@ -0,0 +1,25 @@
+(module bitstring-lowlevel
+ (u8vector-not float->uint32 double->uint64 uint32->float uint64->double)
+ (import scheme (chicken foreign))
+
+(define u8vector-not
+ (foreign-primitive void ((u8vector data) (int size))
+ "int i; for(i=0;i<size;++i) data[i] = ~data[i];"))
+
+(define float->uint32
+ (foreign-primitive void ((u8vector i) (float f))
+ "*(uint32_t*)i = *(uint32_t*)&f;"))
+
+(define double->uint64
+ (foreign-primitive void ((u8vector i) (double d))
+ "*(uint64_t*)i = *(uint64_t*)&d;"))
+
+(define uint32->float
+ (foreign-primitive float ((blob i))
+ "C_return(*(float*)i);"))
+
+(define uint64->double
+ (foreign-primitive double ((blob i))
+ "C_return(*(double*)i);"))
+
+)
(DIR) diff --git a/bitstring.egg b/bitstring.egg
@@ -0,0 +1,8 @@
+((license "BSD")
+ (category parsing)
+ (test-dependencies test)
+ (author "rivo")
+ (dependencies srfi-1 srfi-4)
+ (synopsis "Binary pattern matching")
+ (components (extension bitstring-lowlevel)
+ (extension bitstring (component-dependencies bitstring-lowlevel))))
(DIR) diff --git a/bitstring.scm b/bitstring.scm
@@ -0,0 +1,834 @@
+(module bitstring
+ (bitmatch
+ bitpacket
+ bitconstruct
+ bitstring-pattern-continue
+ make-bitstring
+ bitstring?
+ bitstring-length
+ ->bitstring
+ vector->bitstring
+ u8vector->bitstring
+ string->bitstring
+ blob->bitstring
+ bitstring-read
+ bitstring-share
+ bitstring-seek
+ bitstring-create
+ bitstring-reserve
+ bitstring=?
+ bitstring-append
+ bitstring-append!
+ bitstring-not
+ bitstring-bit-set?
+ bitstring-reverse
+ bitstring->list
+ bitstring->blob
+ bitstring->string
+ bitstring->vector
+ bitstring->u8vector
+ bitstring->integer
+ bitstring->integer-big
+ bitstring->integer-little
+ bitstring->integer-host
+ integer->bitstring
+ integer->bitstring-big
+ integer->bitstring-little
+ integer->bitstring-host
+ bitstring-start
+ bitstring-end
+ bitstring-buffer
+ bitstring-getter
+ bitstring->half
+ bitstring->single
+ single->bitstring
+ bitstring->double
+ double->bitstring
+ list->bitstring)
+
+ (import scheme (chicken base) (chicken fixnum) (chicken bitwise) (chicken blob) (chicken format) srfi-1 srfi-4 bitstring-lowlevel)
+
+(define-syntax symbol??
+ (er-macro-transformer
+ (lambda (e r c)
+ (let* ((args (cdr e))
+ (name (car args))
+ (yes (cadr args))
+ (no (caddr args)))
+ (if (symbol? name) yes no)))))
+
+; (expand-value x char str int)
+(define-syntax expand-value
+ (er-macro-transformer
+ (lambda (e r c)
+ (let* ((args (cdr e))
+ (name (car args))
+ (char-branch (cadr args))
+ (string-branch (caddr args))
+ (integer-branch (cadddr args)))
+ (cond
+ ((char? name) char-branch)
+ ((string? name) string-branch)
+ ((integer? name) integer-branch)
+ (else (error "(bitstring) invalid value" `name)))))))
+
+(define-syntax bitpacket-def-fields
+ (syntax-rules ()
+ ((_ name fields ...)
+ (define-syntax name
+ (er-macro-transformer
+ ;;(name mode stream handler PREFIX rest ...)
+ (lambda (e r c)
+ (define (rename-with-prefix prefix pat)
+ (let* ((n (length pat))
+ (rename (lambda (sym)
+ (string->symbol (string-append (symbol->string prefix)
+ "." (symbol->string sym))))))
+ (or (>= n 1)
+ (syntax-error "(bitstring) invalid bitpacket field pattern" pat))
+ (cond ((and (>= n 1) (symbol? (first pat)))
+ (cons (rename (first pat)) (cdr pat)))
+ (else pat))))
+ (let* ((args (cdr e))
+ (mode (first args))
+ (stream (second args))
+ (handler (third args))
+ (prefix (fourth args))
+ (rest (drop args 4)))
+ (or (symbol? prefix)
+ (equal? prefix #f)
+ (syntax-error "(bitstring) invalid bitpacket prefix" prefix))
+ ;; inline bitpacket fields
+ `(bitstring-pattern-continue ,mode
+ ,stream
+ ,handler
+ ,(if prefix
+ (map (lambda (pat) (rename-with-prefix prefix pat)) '(fields ...))
+ '(fields ...))
+ ,rest))))))))
+
+(define-syntax bitpacket
+ (syntax-rules ()
+ ((_ (name constructor) fields ...)
+ (begin
+ (bitpacket-def-fields name fields ...)
+ (define-syntax constructor
+ (syntax-rules ()
+ ((_ . args)
+ (let args
+ (bitconstruct (name bitpacket))))))))
+ ((_ name fields ...)
+ (bitpacket-def-fields name fields ...))))
+
+
+(define-syntax bitstring-pattern-continue
+ (syntax-rules ()
+ ((_ mode stream handler (fields ...) (rest ...))
+ (bitstring-pattern mode stream handler fields ... rest ...))))
+
+(define-syntax make-bitmatch-result
+ (syntax-rules () ((_ (handler ...))
+ (list (begin handler ...)))))
+
+(define-syntax bitmatch-result
+ (syntax-rules () ((_ result)
+ (car result))))
+
+(define-syntax bitconstruct
+ (syntax-rules ()
+ ((_ patterns ...)
+ (let ((bstr (bitstring-reserve 64)))
+ (bitstring-pattern "write" bstr "no-handler" patterns ...)))))
+
+(define-syntax bitmatch
+ (syntax-rules ()
+ ((_ value . patterns)
+ (let ((bstr (->bitstring value)))
+ (bitmatch-result (bitmatch-pattern-list bstr patterns))))))
+
+(define-syntax bitmatch-pattern-list
+ (syntax-rules (else ->)
+ ((_ bstr ())
+ (error "(bitstring) no matching pattern"
+ (list 'offset (bitstring-start bstr))))
+ ((_ bstr ((else . handler)))
+ (make-bitmatch-result handler))
+ ; short syntax form (pat ... patX -> exp)
+ ((_ bstr ((pattern ... -> handler) . rest))
+ (or (bitmatch-pattern bstr (handler) (pattern ...))
+ (bitmatch-pattern-list bstr rest)))
+ ((_ bstr ((pattern . handler) . rest))
+ (or (bitmatch-pattern bstr handler pattern)
+ (bitmatch-pattern-list bstr rest)))))
+
+(define-syntax bitmatch-pattern
+ (syntax-rules ()
+ ((_ bstr handler (pattern ...))
+ ; shared copy of bitstring instance
+ (let ((stream (bitstring-share bstr (bitstring-start bstr) (bitstring-end bstr))))
+ (bitstring-pattern "read" stream handler pattern ...)))))
+
+(define-syntax bitstring-pattern
+ (syntax-rules (big little host bitstring check float double bitpacket signed unsigned boolean offset seek)
+ ; all patterns take expansion
+ ((_ "read" stream handler)
+ (and
+ ; ensure that no more bits left
+ (zero? (bitstring-length stream))
+ (make-bitmatch-result handler)))
+ ((_ "write" stream handler)
+ stream)
+ ; zero-length bitstring
+ ((_ "read" stream handler ())
+ (and
+ (zero? (bitstring-length stream))
+ (make-bitmatch-result handler)))
+ ((_ "write" stream handler ())
+ stream)
+ ; user guard expression
+ ((_ mode stream handler (check guard) rest ...)
+ (and
+ guard
+ (bitstring-pattern mode stream handler rest ...)))
+ ; evaluate constructing function
+ ((_ "write" stream handler ((VALUE ...) bitstring) rest ...)
+ (and-let* ((tmp (VALUE ...))
+ (bits (bitstring-length tmp)))
+ (bitstring-pattern "write" stream handler (tmp bits bitstring) rest ...)))
+ ; evaluate reader procedure (PROC) -> returns #f or (list num-bits-readed any-value)
+ ((_ "read" stream handler ((name PROC ...) bitstring) rest ...)
+ (and-let* ((tmp (->bitstring stream))
+ (res (PROC ... tmp))
+ (bits (first res)) ; length
+ (name (second res))) ; value
+ (bitstring-pattern "read" stream handler (tmp bits bitstring) rest ...)))
+ ; tell current stream offset
+ ((_ "read" stream handler (NAME offset) rest ...)
+ (let ((NAME (bitstring-start stream)))
+ (bitstring-pattern "read" stream handler rest ...)))
+ ; move current stream offset
+ ((_ "read" stream handler (OFFS seek) rest ...)
+ (and-let* ((with-offset (bitstring-seek stream OFFS)))
+ (bitstring-pattern "read" with-offset handler rest ...)))
+ ; bitpacket
+ ((_ mode stream handler (NAME bitpacket) rest ...)
+ (NAME mode stream handler #f rest ...))
+ ; bitpacket with prefix
+ ((_ mode stream handler (PREFIX NAME bitpacket) rest ...)
+ (NAME mode stream handler PREFIX rest ...))
+ ; allow in bitconstruct dont type length
+ ((_ "write" stream handler (NAME bitstring) rest ...)
+ (bitstring-pattern-expand "write" stream NAME
+ (bitstring-pattern "write" stream handler rest ...)))
+ ; greedy bitstring
+ ((_ mode stream handler (NAME bitstring))
+ (bitstring-pattern-expand mode stream NAME
+ (bitstring-pattern mode stream handler)))
+ ; boolean
+ ((_ mode stream handler (NAME boolean) rest ...)
+ (bitstring-pattern-expand mode stream NAME 8 (boolean big unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; boolean bits
+ ((_ mode stream handler (NAME BITS boolean) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (boolean big unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; boolean bits endian
+ ((_ mode stream handler (NAME BITS boolean ENDIAN) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (boolean ENDIAN unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; double 64
+ ((_ mode stream handler (NAME double) rest ...)
+ (bitstring-pattern-expand mode stream NAME 64 (float big)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME double ENDIAN) rest ...)
+ (bitstring-pattern-expand mode stream NAME 64 (float ENDIAN)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; float 32
+ ((_ mode stream handler (NAME float) rest ...)
+ (bitstring-pattern-expand mode stream NAME 32 (float big)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME float ENDIAN) rest ...)
+ (bitstring-pattern-expand mode stream NAME 32 (float ENDIAN)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; generic float bits
+ ((_ mode stream handler (NAME BITS float) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (float big)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME BITS float ENDIAN) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (float ENDIAN)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; bigendian
+ ((_ mode stream handler (NAME BITS big) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (big unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; littleendian
+ ((_ mode stream handler (NAME BITS little) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (little unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; same endianness as host
+ ((_ mode stream handler (NAME BITS host) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (host unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; bitstring
+ ((_ mode stream handler (NAME BITS bitstring) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS bitstring
+ (bitstring-pattern mode stream handler rest ...)))
+ ; integer attibutes
+ ((_ mode stream handler (NAME BITS signed) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (big signed)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME BITS unsigned) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (big unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME BITS signed ENDIAN) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (ENDIAN signed)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME BITS unsigned ENDIAN) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (ENDIAN unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME BITS ENDIAN SIGNED) rest ...)
+ (bitstring-pattern-expand mode stream NAME BITS (ENDIAN SIGNED)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME signed) rest ...)
+ (bitstring-pattern-expand mode stream NAME 8 (big signed)
+ (bitstring-pattern mode stream handler rest ...)))
+ ((_ mode stream handler (NAME unsigned) rest ...)
+ (bitstring-pattern-expand mode stream NAME 8 (big unsigned)
+ (bitstring-pattern mode stream handler rest ...)))
+ ; rewrite by default to (NAME BITS (big unsigned))
+ ((_ mode stream handler (NAME BITS) rest ...)
+ (bitstring-pattern mode stream handler (NAME BITS big) rest ...))
+ ; rewrite immidiate value
+ ((_ mode stream handler (NAME) rest ...)
+ (symbol?? NAME
+ ; yes
+ (bitstring-pattern mode stream handler (NAME 8 big) rest ...)
+ ; no
+ (bitstring-pattern-value mode stream handler (NAME) rest ...)))
+ ; dismiss other pattern forms
+ ((_ mode stream handler . rest)
+ (syntax-error "(bitstring) malformed pattern" `rest))))
+
+(define-syntax bitstring-pattern-value
+ (syntax-rules ()
+ ((_ mode stream handler (VALUE) rest ...)
+ (expand-value VALUE
+ ; char
+ (bitstring-pattern mode stream handler ((char->integer VALUE) 8 big) rest ...)
+ ; string
+ (bitstring-pattern mode stream handler
+ (VALUE (* 8 (string-length VALUE)) bitstring) rest ...)
+ ; integer
+ (bitstring-pattern mode stream handler (VALUE 8 big) rest ...)))))
+
+(define-syntax bitstring-pattern-expand
+ (syntax-rules ()
+ ((_ "write" stream name continuation)
+ (and-let* ((tmp (->bitstring name)))
+ ;(print "write-expand:" `stream " name:" `name)
+ (bitstring-append! stream tmp)
+ continuation))
+ ((_ "write" stream name bits type continuation)
+ (and-let* ((tmp (bitstring-write-expand name bits type)))
+ ;(print "write-expand:" `stream " name:" `name)
+ (bitstring-append! stream tmp)
+ continuation))
+ ((_ "read" stream name continuation) ; read all rest bytes
+ (symbol?? name
+ (and-let* ((name (bitstring-read stream (bitstring-length stream))))
+ ;(print "read-expand: " `(name bits type) " rest: " `continuation)
+ continuation)
+ (syntax-error "(bitstring) not a symbol name" `name)))
+ ((_ "read" stream name bits type continuation)
+ (and-let* ((tmp (bitstring-read stream bits)))
+ (symbol?? name
+ (let ((name (bitstring-read-expand tmp bits type)))
+ continuation)
+ (and (optimize-compare tmp name bits type)
+ continuation))))))
+
+(define-syntax optimize-compare
+ (syntax-rules ()
+ ((_ tmp value bits (ENDIAN SIGNED))
+ (= value (bitstring-read-integer tmp bits ENDIAN SIGNED)))
+ ((_ tmp value bits type)
+ (bitstring=? tmp (bitstring-write-expand value bits type)))))
+
+(define-syntax float-reorder-bytes
+ (syntax-rules (little big host)
+ ((_ host tmp)
+ (cond-expand
+ (little-endian (float-reorder-bytes little tmp))
+ (else (float-reorder-bytes big tmp))))
+ ((_ little tmp)
+ (cond-expand
+ (little-endian tmp)
+ (else (bitstring-reverse tmp 8))))
+ ((_ big tmp)
+ (cond-expand
+ (little-endian (bitstring-reverse tmp 8))
+ (else tmp)))))
+
+(define-syntax bitstring-read-expand
+ (syntax-rules (bitstring float boolean)
+ ((_ tmp 32 (float ENDIAN))
+ (bitstring->single (float-reorder-bytes ENDIAN tmp)))
+ ((_ tmp 64 (float ENDIAN))
+ (bitstring->double (float-reorder-bytes ENDIAN tmp)))
+ ((_ tmp bits (boolean ENDIAN SIGNED))
+ (not (zero? (bitstring-read-integer tmp bits ENDIAN SIGNED))))
+ ((_ tmp bits (ENDIAN SIGNED))
+ (bitstring-read-integer tmp bits ENDIAN SIGNED))
+ ((_ tmp bits bitstring)
+ tmp))) ; return bitstring as is
+
+(define-syntax bitstring-read-integer
+ (syntax-rules (big little host signed unsigned)
+ ((_ tmp bits big signed)
+ (if (bitstring-bit-set? tmp 0)
+ (- (+ 1 (bitstring->integer-big (bitstring-not tmp))))
+ (bitstring->integer-big tmp)))
+ ((_ tmp bits little signed)
+ (if (bitstring-bit-set? tmp (if (< bits 8) (sub1 bits) (- bits 8)))
+ (- (+ 1 (bitstring->integer-little (bitstring-not tmp))))
+ (bitstring->integer-little tmp)))
+ ((_ tmp bits host signed)
+ (cond-expand
+ (little-endian (bitstring-read-integer tmp bits little signed))
+ (else (bitstring-read-integer tmp bits big signed))))
+ ((_ tmp bits big unsigned)
+ (bitstring->integer-big tmp))
+ ((_ tmp bits little unsigned)
+ (bitstring->integer-little tmp))
+ ((_ tmp bits host unsigned)
+ (bitstring->integer-host tmp))
+ ((_ tmp bits ENDIAN SIGNED)
+ (syntax-error "(bitstring) invalid integer attibute" `ENDIAN `SIGNED))))
+
+(define-syntax bitstring-write-expand
+ (syntax-rules (bitstring float boolean)
+ ((_ tmp 32 (float ENDIAN))
+ (float-reorder-bytes ENDIAN (single->bitstring tmp)))
+ ((_ tmp 64 (float ENDIAN))
+ (float-reorder-bytes ENDIAN (double->bitstring tmp)))
+ ((_ tmp bits (boolean ENDIAN SIGNED))
+ (bitstring-write-integer (if tmp 1 0) bits ENDIAN SIGNED))
+ ((_ tmp bits (ENDIAN SIGNED))
+ (bitstring-write-integer tmp bits ENDIAN SIGNED))
+ ((_ tmp bits bitstring)
+ (if (bitstring? tmp)
+ tmp
+ (->bitstring tmp)))))
+
+(define-syntax bitstring-write-integer
+ (syntax-rules (big little host signed unsigned)
+ ((_ tmp bits big signed)
+ (integer->bitstring-big tmp bits))
+ ((_ tmp bits little signed)
+ (integer->bitstring-little tmp bits))
+ ((_ tmp bits host signed)
+ (integer->bitstring-host tmp bits))
+ ((_ tmp bits big unsigned)
+ (integer->bitstring-big tmp bits))
+ ((_ tmp bits little unsigned)
+ (integer->bitstring-little tmp bits))
+ ((_ tmp bits host unsigned)
+ (integer->bitstring-host tmp bits))
+ ((_ tmp bits ENDIAN SIGNED)
+ (syntax-error "(bitstring) invalid integer attibute" `ENDIAN `SIGNED))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;
+;; bitstring
+
+(define-record bitstring
+ start ; buffer offset in bits
+ end ; buffer offset in bits
+ buffer ; any container with random access
+ getter ; (lambda (buffer index) -> byte)
+ setter) ; (lambda (buffer index byte) -> void)
+
+(define-record-printer (bitstring x out)
+ (fprintf out "<bitstring ~A ~A ~A>"
+ (bitstring-start x) (bitstring-end x) (bitstring-buffer x)))
+
+(define (bitstring-length bs)
+ (- (bitstring-end bs) (bitstring-start bs)))
+
+; compute space required for {{n}} bits
+(define (space-required n)
+ (+ (quotient n 8) (if (zero? (remainder n 8)) 0 1)))
+
+(define (bitstring-create)
+ (bitstring-reserve 128))
+
+(define (bitstring-reserve size-in-bits)
+ (let ((size (space-required size-in-bits)))
+ (make-bitstring 0 0 (make-u8vector size 0) u8vector-ref u8vector-set!)))
+
+(define (string->bitstring s)
+ (make-bitstring 0 (* 8 (string-length s)) s
+ (lambda (str index) (char->integer (string-ref str index)))
+ (lambda (str index byte) (string-set! str index (integer->char byte)))))
+
+(define (vector->bitstring v)
+ (make-bitstring 0 (* 8 (vector-length v)) v vector-ref vector-set!))
+
+(define (u8vector->bitstring v)
+ (make-bitstring 0 (* 8 (u8vector-length v)) v u8vector-ref u8vector-set!))
+
+(define (blob->bitstring b)
+ (u8vector->bitstring (blob->u8vector/shared b)))
+
+(define (->bitstring x)
+ (cond
+ ((bitstring? x)
+ (bitstring-share x (bitstring-start x) (bitstring-end x)))
+ ((u8vector? x)
+ (u8vector->bitstring x))
+ ((string? x)
+ (string->bitstring x))
+ ((vector? x)
+ (vector->bitstring x))
+ ((blob? x)
+ (u8vector->bitstring (blob->u8vector/shared x)))
+ (else
+ (error "(bitstring) not implemented for this value type" x))))
+
+(define (bitstring->blob bs #!optional (zero-extending 'left))
+ (u8vector->blob/shared (bitstring->u8vector bs zero-extending)))
+
+(define (bitstring->u8vector bs #!optional (zero-extending 'left))
+ ; make bs copy for mutable bitstring-read
+ (let loop ((bs (bitstring-share bs (bitstring-start bs) (bitstring-end bs)))
+ (n (bitstring-length bs))
+ (index 0)
+ (tmp (make-u8vector (space-required (bitstring-length bs)))))
+ (cond
+ ((zero? n)
+ tmp)
+ ((< n 8)
+ (let ((byte (bitstring->integer-big (bitstring-read bs n))))
+ (u8vector-set! tmp index (if (eq? zero-extending 'left)
+ byte
+ (fxshl byte (- 8 n))))
+ tmp))
+ (else
+ (u8vector-set! tmp index (bitstring->integer-big (bitstring-read bs 8)))
+ (loop bs (- n 8) (add1 index) tmp)))))
+
+(define (bitstring->string bs)
+ (list->string (map integer->char (bitstring->list bs 8))))
+
+(define (bitstring->vector bs)
+ (list->vector (bitstring->list bs 8)))
+
+(define (bitstring->list bs #!optional (bits 1) (endian 'big))
+ (bitstring->listn bs bits endian))
+
+(define (bitstring->listn bs bits endian)
+ (let loop ((bs (->bitstring bs)); make copy for mutable bitstring-read
+ (n (bitstring-length bs))
+ (acc (list)))
+ (cond ((zero? n)
+ (reverse acc))
+ ((< n bits)
+ (loop bs 0
+ (cons (bitstring->integer (bitstring-read bs n) endian) acc)))
+ (else
+ (loop bs (- n bits)
+ (cons (bitstring->integer (bitstring-read bs bits) endian) acc))))))
+
+(define (list->bitstring lst #!optional (bits 1) (endian 'big))
+ (let loop ((rest lst)
+ (acc (bitstring-reserve (* (length lst) bits))))
+ (if (null-list? rest)
+ acc
+ (loop (cdr rest) (bitstring-append! acc (integer->bitstring (car rest) bits endian))))))
+
+(define (bitstring-reverse bs #!optional (bits 1) (endian 'big))
+ (list->bitstring (reverse (bitstring->list bs bits endian)) bits endian))
+
+(define (bitstring=? a b)
+ (and
+ (= (bitstring-length a) (bitstring-length b))
+ (if (and (bytestring? a) (bytestring? b))
+ (bytestring=? a b)
+ (equal? (bitstring->list a 8) (bitstring->list b 8)))))
+
+(define (bytestring? bs)
+ (and (zero? (remainder (bitstring-start bs) 8))
+ (zero? (remainder (bitstring-length bs) 8))))
+
+(define (bytestring=? a b)
+ (let ((alen (quotient (bitstring-length a) 8))
+ (blen (quotient (bitstring-length b) 8))
+ (e (quotient (bitstring-end a) 8)))
+ (and (= alen blen)
+ (let loop ((i (quotient (bitstring-start a) 8))
+ (j (quotient (bitstring-start b) 8)))
+ (if (< i e)
+ (if (= (bitstring-load-byte a i)
+ (bitstring-load-byte b j))
+ (loop (add1 i) (add1 j))
+ #f)
+ #t)))))
+
+(define (bitstring-load-byte bs index)
+ ((bitstring-getter bs) (bitstring-buffer bs) index))
+
+(define (bitstring-store-byte bs index value)
+ ((bitstring-setter bs) (bitstring-buffer bs) index value))
+
+; extract {{count}} bits starting from {{offset}}, {{value}} should'be 8 bit integer.
+(define-inline (extract-bits value offset count)
+ (fxshr (fxand (fxshl value offset) #xFF)
+ (- 8 count)))
+
+(define (bitstring-fold proc init bs)
+ (let loop ((start (bitstring-start bs))
+ (end (bitstring-end bs))
+ (index (quotient (bitstring-start bs) 8))
+ (drift (remainder (bitstring-start bs) 8))
+ (count (- 8 (remainder (bitstring-start bs) 8)))
+ (acc init))
+ (let ((n (min (- end start) count)))
+ (if (<= n 0)
+ acc
+ (loop (+ start n) end
+ (add1 index) ; move index
+ 0 ; reset drift
+ 8 ; setup 8 bit chunk
+ (proc (extract-bits (bitstring-load-byte bs index) drift n) n acc))))))
+
+(define (bitstring-not bs)
+ (let ((len (bitstring-length bs))
+ (tmp (bitstring->u8vector bs 'right)))
+ (u8vector-not tmp (u8vector-length tmp))
+ (make-bitstring 0 len tmp u8vector-ref u8vector-set!)))
+
+(define (bitstring-bit-set? bs n)
+ (let ((start (bitstring-start bs))
+ (end (bitstring-end bs)))
+ (let* ((index (if (negative? n)
+ (+ end n)
+ (+ start n)))
+ (byte-index (quotient index 8))
+ (bit-index (- 7 (remainder index 8))))
+ (if (and (<= start index) (< index end))
+ (bit->boolean (bitstring-load-byte bs byte-index) bit-index)
+ (error "(bitstring) out of range" start end n)))))
+
+(define (bitstring->integer-big bs)
+ (bitstring-fold
+ (lambda (value count result)
+ (bitwise-ior (arithmetic-shift result count) value))
+ 0
+ bs))
+
+(define (bitstring->integer-little bs)
+ (car (bitstring-fold
+ (lambda (value count acc)
+ (let ((result (car acc))
+ (shift (cdr acc)))
+ (cons (bitwise-ior result (arithmetic-shift value shift))
+ (+ shift count))))
+ (cons 0 0)
+ bs)))
+
+(define (integer->bitstring-little value count)
+ (let loop ((start 0)
+ (n (min count 8))
+ (bs (bitstring-reserve count)))
+ (bitstring-end-set! bs count)
+ (if (<= count start)
+ bs
+ (let ((x (bitwise-and (arithmetic-shift value (- start)) 255)))
+ (bitstring-store-byte bs (quotient start 8) (fxshl x (- 8 n)))
+ (loop (+ start n) (min (- count start n) 8) bs)))))
+
+(define (integer->bitstring-big value count)
+ (let loop ((start count)
+ (n (min count 8))
+ (bs (bitstring-reserve count)))
+ (bitstring-end-set! bs count)
+ (if (<= start 0)
+ bs
+ (let ((x (bitwise-and (arithmetic-shift value (- n start)) 255)))
+ (bitstring-store-byte bs (quotient (- count start) 8) (fxshl x (- 8 n)))
+ (loop (- start n) (min start 8) bs)))))
+
+(define (bitstring->integer bitstring endian)
+ (case endian
+ ((big)
+ (bitstring->integer-big bitstring))
+ ((little)
+ (bitstring->integer-little bitstring))
+ ((host)
+ (bitstring->integer-host bitstring))
+ (else
+ (error "(bitstring) invalid endian value" `endian))))
+
+(define bitstring->integer-host
+ (cond-expand
+ (little-endian bitstring->integer-little)
+ (else bitstring->integer-big)))
+
+(define integer->bitstring-host
+ (cond-expand
+ (little-endian integer->bitstring-little)
+ (else integer->bitstring-big)))
+
+(define (integer->bitstring value count endian)
+ (case endian
+ ('little
+ (integer->bitstring-little value count))
+ ('host
+ (integer->bitstring-host value count))
+ (else
+ (integer->bitstring-big value count))))
+
+(define (bitstring->half bs)
+ (let ((s (bitstring-read bs 1))
+ (e (bitstring-read bs 5))
+ (m (bitstring-read bs 10)))
+ (make-half-float
+ (bitstring->integer-big s)
+ (bitstring->integer-big e)
+ (bitstring->integer-big m))))
+
+(define (make-half-float signbit exponent mantissa)
+ ;(newline)
+ ;(print "s: " signbit " e: " exponent " m: " mantissa)
+ (cond
+ ((and (zero? exponent) (zero? mantissa))
+ (if (zero? signbit) +0. -0.))
+ ((= exponent 31)
+ (if (zero? mantissa)
+ (if (zero? signbit) +inf.0 -inf.0)
+ (if (zero? signbit) +nan.0 -nan.0)))
+ (else
+ (let ((e (- exponent 15))
+ (m (bitwise-ior #x400 mantissa)))
+ (let loop ((i 10) (s 1.) (f 0.))
+ (let* ((x (arithmetic-shift 1 i))
+ (b (bitwise-and m x)))
+ (if (or (zero? i))
+ (* f (expt 2 e) (if (zero? signbit) 1. -1.))
+ (loop (- i 1) (/ s 2) (if (zero? b) f (+ f s))))))))))
+
+(define (single->bitstring value)
+ (let ((buf (make-u8vector 4)))
+ (float->uint32 buf value)
+ (->bitstring buf)))
+
+(define (double->bitstring value)
+ (let ((buf (make-u8vector 8)))
+ (double->uint64 buf value)
+ (->bitstring buf)))
+
+(define (bitstring->single bs)
+ (uint32->float (bitstring->blob bs)))
+
+(define (bitstring->double bs)
+ (uint64->double (bitstring->blob bs)))
+
+(define (bitstring-share bs from to)
+ (make-bitstring from to (bitstring-buffer bs) (bitstring-getter bs) (bitstring-setter bs)))
+
+(define (bitstring-seek bs offs)
+ (let ((from (+ (bitstring-start bs) offs))
+ (to (bitstring-end bs)))
+ (and (<= 0 from)
+ (<= from to)
+ (bitstring-share bs from to))))
+
+(define (bitstring-read bs n)
+ (let ((from (bitstring-start bs))
+ (to (+ (bitstring-start bs) n)))
+ (and (<= to (bitstring-end bs))
+ (let ((bs/shared (bitstring-share bs from to)))
+ (bitstring-start-set! bs to)
+ bs/shared))))
+
+(define (bitstring-buffer-size bs)
+ (let ((buffer (bitstring-buffer bs)))
+ (* 8 ; return size in bits
+ (cond
+ ((u8vector? buffer)
+ (u8vector-length buffer))
+ ((string? buffer)
+ (string-length buffer))
+ (else
+ (error "(bitstring) not implemented for this buffer type"))))))
+
+(define (bitstring-buffer-resize bs size-in-bits)
+ (let* ((new-size (space-required size-in-bits))
+ (tmp (make-u8vector new-size 0))
+ (used (bitstring-buffer-size bs)))
+ (let copy ((i 0)
+ (e (quotient used 8)))
+ (when (< i e)
+ (u8vector-set! tmp i (bitstring-load-byte bs i))
+ (copy (+ i 1) e)))
+ ; replace buffer with accessors
+ (bitstring-buffer-set! bs tmp)
+ (bitstring-getter-set! bs u8vector-ref)
+ (bitstring-setter-set! bs u8vector-set!)))
+
+(define (bitstring-required-length args)
+ (fold
+ (lambda (bs len)
+ (+ len (bitstring-length bs)))
+ 0
+ args))
+
+(define (bitstring-append . args)
+ (fold
+ (lambda (bs acc)
+ (bitstring-append! acc bs))
+ (bitstring-reserve (bitstring-required-length args))
+ args))
+
+(define (bitstring-append! dst . args)
+ (fold
+ (lambda (bs acc)
+ (bitstring-append2! acc bs))
+ dst
+ args))
+
+(define (bitstring-append2! dest src)
+ ; need ensure that dest buffer long enough
+ (let ((required (bitstring-length src))
+ (position (bitstring-end dest))
+ (reserved (bitstring-buffer-size dest)))
+ (when (< (- reserved position) required)
+ (bitstring-buffer-resize dest
+ (+ reserved (inexact->exact (* 0.50 reserved)) required)))
+ (bitstring-fold
+ (lambda (value nbits acc)
+ (bitstring-append-safe! acc (fxshl value (- 8 nbits)) nbits))
+ dest
+ src)))
+
+(define (bitstring-append-safe! bs value nbits)
+ (let* ((position (bitstring-end bs))
+ (index (quotient position 8))
+ (drift (remainder position 8)))
+ (if (zero? drift)
+ ; store aligned
+ (begin
+ (bitstring-store-byte bs index value)
+ (bitstring-end-set! bs (+ position nbits)))
+ ; store unaligned
+ (let ((byte-src (bitstring-load-byte bs index))
+ (byte-dst (fxshr value drift))
+ (restbits (- 8 drift)))
+ (bitstring-store-byte bs index (fxior byte-src byte-dst))
+ ; store rest bits if didnt fit in current byte
+ (if (< restbits nbits)
+ (bitstring-store-byte bs (+ index 1) (fxshl value restbits)))
+ (bitstring-end-set! bs (+ position nbits))))
+ bs));return bitstring
+
+);module
(DIR) diff --git a/tests/24compressed.tga b/tests/24compressed.tga
Binary files differ.
(DIR) diff --git a/tests/24uncompressed.tga b/tests/24uncompressed.tga
Binary files differ.
(DIR) diff --git a/tests/examples.scm b/tests/examples.scm
@@ -0,0 +1,178 @@
+(use bitstring)
+(use srfi-4)
+
+; Example 1. Tagged data structure.
+;
+; struct Tagged {
+; enum { IntegerType = 1, FloatType = 2 };
+; unsigned char Tag; // integer type = 1, float type = 2
+; union {
+; unsigned int IValue;
+; float FValue;
+; };
+; };
+;
+
+; The following will print "integer:3721182122",
+; which is the decimal value of #xDDCCBBAA
+(bitmatch "\x01\xAA\xBB\xCC\xDD"
+ (((#x01) (IValue 32 little))
+ (print "integer:" IValue))
+ (((#x02) (FValue 32 float))
+ (print "float:" FValue)))
+
+; Example 2. Fixed length string.
+;
+; struct FixedString {
+; short Length; // length of StringData array
+; char StringData[0];
+; };
+;
+
+; This will print "StringData:(65 66 67 68 69)"
+; First it reads the length byte of 5, bind it to Length and
+; then it will read a bit string with a length of that many octets.
+(bitmatch "\x05\x00ABCDE"
+ (((Length 16 little)
+ (StringData (* 8 Length) bitstring))
+ (print "StringData:" (bitstring->list StringData 8)))
+ (else
+ (print "invalid string")))
+
+; Example 3. IP packet parsing.
+;
+
+(use bitstring srfi-4)
+
+(define IPRaw `#u8( #x45 #x00 #x00 #x6c
+ #x92 #xcc #x00 #x00
+ #x38 #x06 #x00 #x00
+ #x92 #x95 #xba #x14
+ #xa9 #x7c #x15 #x95 ))
+
+(bitmatch IPRaw
+ (((Version 4)
+ (IHL 4)
+ (TOS 8)
+ (TL 16)
+ (Identification 16)
+ (Reserved 1) (DF 1) (MF 1)
+ (FramgentOffset 13)
+ (TTL 8)
+ (Protocol 8) (check (or (= Protocol 1)
+ (= Protocol 2)
+ (= Protocol 6)
+ (= Protocol 17)))
+ (CheckSum 16)
+ (SourceAddr 32 bitstring)
+ (DestinationAddr 32 bitstring)
+ (Optional bitstring))
+ ; print packet filds
+ (print "\n Version: " Version
+ "\n IHL: " IHL
+ "\n TOS: " TOS
+ "\n TL: " TL
+ "\n Identification: " Identification
+ "\n DF: " DF
+ "\n MF: " MF
+ "\n FramgentOffset: " FramgentOffset
+ "\n Protocol: " Protocol
+ "\n CheckSum: " CheckSum
+ "\n SourceAddr: "
+ (bitmatch SourceAddr (((A)(B)(C)(D)) (list A B C D)))
+ "\n DestinationAddr: "
+ (bitmatch DestinationAddr (((A)(B)(C)(D)) (list A B C D)))))
+ (else
+ (print "bad datagram")))
+
+; Example 3.1 Using bitconstruct.
+
+(define (construct-fixed-string str)
+ (bitconstruct
+ ((string-length str) 16) (str bitstring) ))
+
+; The following will print "#t". First, it reads a 16-bit number length
+; and compares it to the immediate value of 7. Then it will read a
+; string and compare it to the immediate value of "qwerty.". If there
+; was any remaining data in the string, it would fail.
+(bitmatch (construct-fixed-string "qwerty.")
+ (((7 16) ("qwerty."))
+ (print #t))
+ (else
+ (print #f)))
+
+; Example 3.2 Concatenating bitstrings.
+
+(define (construct-complex-object)
+ (bitconstruct
+ ((construct-fixed-string "A") bitstring)
+ (#xAABB 16)
+ ((construct-fixed-string "RRR") bitstring)
+ (#\X)))
+
+(print (construct-complex-object))
+
+
+; Example 4.1 Using bitpacket for better code reuse
+
+(bitpacket Point (x float host)
+ (y float host))
+
+(bitpacket Line (start Point bitpacket)
+ (end Point bitpacket))
+
+; parse array of line coordinates
+(bitmatch (f32vector->blob (f32vector 0.5 -0.5 1.0 0.0))
+ (((Line bitpacket))
+ (print "start x: " start.x " y: " start.y " x2: " end.x " y2: " end.y)))
+
+; create line coordinate
+(define (bitstring->f32vector bs)
+ (blob->f32vector (bitstring->blob bs)))
+
+; construct Line
+(let ((start.x 1.0)
+ (start.y 2.0)
+ (end.x -1.0)
+ (end.y -2.0))
+ (print "Line: "
+ (bitstring->f32vector
+ (bitconstruct (Line bitpacket)))))
+
+; Example 4.2 Using bitpacket constructor
+
+; Special syntax (bitpacket (packet-name constructor-name) fields ...)
+(bitpacket (Point3D make-Point3D)
+ (x float host)
+ (y float host)
+ (z float host))
+
+; make-Point3D just syntax sugar for '(let (args ...) (bitconstruct (Point3D bitpacket)))'
+(print "Point3D: " (bitstring->f32vector
+ (make-Point3D (x 0.0) (y -1.0) (z 1.0))))
+
+; Example 5. Reader procedure
+
+; Pattern: ((Name reader-proc) bitstring)
+; Signature: (reader-proc bitstring) -> returns #f or (list num-bits-consumed user-value)
+
+; C string reader
+(define (cstring-reader bs)
+ (let loop ((n 8) (acc '()) (rest bs))
+ (bitmatch rest
+ ; end of stream (fail!)
+ (() #f)
+ ; zero-terminator (success!)
+ (((0) (rest bitstring))
+ (list n ; number of bits consumed
+ (list->string (reverse acc)))) ; result string
+ ; continue
+ (((c) (rest bitstring))
+ (loop (+ n 8) ; accumulate length
+ (cons (integer->char c) acc); save char
+ rest))))) ; inspect rest of stream
+
+(bitmatch "Kernighan\x00Ritchie\x00"
+ ((((s1 cstring-reader) bitstring)
+ ((s2 cstring-reader) bitstring))
+ (print (string-append s1 " and " s2))))
(DIR) diff --git a/tests/run.scm b/tests/run.scm
@@ -0,0 +1,448 @@
+(use srfi-4 bitstring test)
+
+(current-test-epsilon .01)
+
+(test-begin "bitstring")
+
+;;;;;;;;;;;;;;;;;;
+
+(test-begin "bit-set?")
+(test #t (bitstring-bit-set? (->bitstring '#${80 00}) 0))
+(test #t (bitstring-bit-set? (->bitstring '#${01 00}) 7))
+(test #t (bitstring-bit-set? (->bitstring '#${00 01}) -1))
+(test #t (bitstring-bit-set? (->bitstring '#${80 00}) -16))
+(test-end)
+
+(test-begin "construct bitstring syntax")
+(define foo "\x01")
+(test (bitconstruct (1)(2)) (bitconstruct (foo bitstring) (2)))
+(test (bitconstruct (1)) (bitconstruct (foo bitstring)))
+(test-end)
+
+(test-begin "integer attributes")
+(test -25 (bitmatch "\xE7" ((x 8 signed) -> x)))
+;(test -45 (bitmatch "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xD3" ((skip 1) (x 63 signed) -> x)))
+(define bstr (->bitstring "\xFE"))
+(test -2 (bitmatch bstr ((x signed) -> x)))
+(test 254 (bitmatch bstr ((x unsigned) -> x)))
+(test -2 (bitmatch bstr ((x 8 signed) -> x)))
+(test 254 (bitmatch bstr ((x 8 unsigned) -> x)))
+(test -2 (bitmatch bstr ((x 8 big signed) -> x)))
+(test 254 (bitmatch bstr ((x 8 big unsigned) -> x)))
+(test -2 (bitmatch bstr ((x 8 little signed) -> x)))
+(test 254 (bitmatch bstr ((x 8 little unsigned) -> x)))
+(test -2 (bitmatch bstr ((x 8 signed host) -> x)))
+(test 254 (bitmatch bstr ((x 8 unsigned host) -> x)))
+(test-error (bitmatch bstr ((x 8 unsigned cost) -> x)))
+(test -1 (bitmatch (bitstring-share bstr 0 4) ((x 4 signed) -> x)))
+(test -2 (bitmatch (bitstring-share bstr 4 8) ((x 4 signed) -> x)))
+(test-end)
+
+(test-begin "bitstring->list")
+(define bstr (->bitstring "\xff"))
+(test (make-list 8 1) (bitstring->list bstr 1 'big))
+(test (make-list 8 1) (bitstring->list bstr 1 'little))
+(test (make-list 8 1) (bitstring->list bstr 1 'host))
+(test-end)
+
+(test-begin "list->bitstring")
+(define foo (list 1 0 1))
+(define bar (list->bitstring foo 8))
+(test foo (bitstring->list bar 8))
+(test foo (bitstring->list bar 8 'big))
+(test foo (bitstring->list bar 8 'little))
+(test foo (bitstring->list bar 8 'host))
+(test-end)
+
+(test-begin "bitstring-reverse")
+(define bs (->bitstring '#${0a 0b 0c 0d}))
+(test (list #xd #xc #xb #xa) (bitstring->list (bitstring-reverse bs 8) 8))
+(test-end)
+
+(test-begin "bitstring <-> vector")
+(define x (vector 1 2 3))
+(test x (bitstring->vector (vector->bitstring x)))
+(test-end)
+
+(define bs9)
+(define bs7)
+(bitmatch (u8vector #xff #xff)
+ (((a 9 bitstring) (b bitstring))
+ (set! bs9 a)
+ (set! bs7 b)))
+
+(test-begin "bitstring <-> u8vector")
+(define x (u8vector 1 2 3))
+(test x (bitstring->u8vector (u8vector->bitstring x)))
+(define y (u8vector #xff #x01))
+(test y (bitstring->u8vector bs9))
+(define z (u8vector #xff #x80))
+(test z (bitstring->u8vector bs9 'right))
+(define w (u8vector #b01111111))
+(test w (bitstring->u8vector bs7 'left))
+(define g (u8vector #b11111110))
+(test g (bitstring->u8vector bs7 'right))
+(test-end)
+
+(test-begin "bitstring <-> blob")
+(define x '#${1 2 3})
+(test x (bitstring->blob (blob->bitstring x)))
+(define y '#${ff01})
+(test y (bitstring->blob bs9))
+(define z '#${ff80})
+(test z (bitstring->blob bs9 'right))
+(test-end)
+
+(test-begin "bitstring <-> string")
+(define x "123")
+(test x (bitstring->string (string->bitstring x)))
+(test-end)
+
+(test-begin "single-double")
+(define a (bitconstruct (0.123 float)))
+(define b (bitconstruct (0.2 double)))
+(test 0.123 (bitmatch a (((x float)) x)))
+(test 0.2 (bitmatch b (((x double)) x)))
+
+(test 0.123
+ (bitmatch (bitconstruct (0.123 float little))
+ (((f float little)) f)))
+
+(test 0.123
+ (bitmatch (bitconstruct (0.123 float big))
+ (((f float big)) f)))
+
+(test 0.123
+ (bitmatch (bitconstruct (0.123 double host))
+ (((f double host)) f)))
+
+(test (list 63 191 124 237 145 104 114 176)
+ (bitstring->list (bitconstruct (0.123 double big)) 8))
+
+(test (list 176 114 104 145 237 124 191 63)
+ (bitstring->list (bitconstruct (0.123 double little)) 8))
+
+(test-end)
+
+(test-begin "string-constant")
+(test 2 (bitmatch "123" ((("234")) 1) ((("123")) 2)))
+(define s123 "123")
+(test 2 (bitmatch s123 ((("234")) 1) ((("123")) 2)))
+(test 2 (bitmatch s123 ((("234")) 1) (((s123 bitstring)) 2)))
+(test 2 (bitmatch "123" ((("234")) 1) (((s123 bitstring)) 2)))
+(test-end)
+
+(test-begin "construct")
+(bitpacket NString (size 8) (data (* 8 size) bitstring))
+(define (make-nstr str)
+ (let ((size (string-length str))
+ (data str))
+ (bitconstruct (NString bitpacket))))
+(define nstr (make-nstr "ABC"))
+(test #t (bitmatch nstr (((3) ("ABC")) #t) (else #f)))
+(test-end)
+
+(test-begin "append")
+; append list immutable
+(test "1234567890"
+ (bitstring->string
+ (bitstring-append (->bitstring "123") (->bitstring "456") (->bitstring "7890"))))
+; append list mutable
+(define bs (->bitstring (u8vector)))
+(bitstring-append! bs (->bitstring "123") (->bitstring "456") (->bitstring "7890"))
+(test "1234567890" (bitstring->string bs))
+; append aligned
+(define bs (->bitstring (u8vector)))
+(bitstring-append! bs (->bitstring "A"))
+(bitstring-append! bs (->bitstring "B"))
+(bitstring-append! bs (->bitstring "\x20"))
+(test #t (bitstring=? bs (->bitstring "AB\x20")))
+; test immutable append
+(define a (->bitstring "A"))
+(define b (->bitstring "B"))
+(define c (bitstring-append a b))
+(test #t (bitstring=? (bitconstruct ("AB")) c))
+(test #t (bitstring=? (bitconstruct ("A")) a))
+(test #t (bitstring=? (bitconstruct ("B")) b))
+(test 16 (bitstring-length c))
+; append unaligned
+(define bs (->bitstring (u8vector)))
+(bitstring-append! bs (integer->bitstring-big #b100 3))
+(bitstring-append! bs (integer->bitstring-big #b10 2))
+(bitstring-append! bs (integer->bitstring-big #b1 1))
+(bitstring-append! bs (integer->bitstring-big #b0101 4))
+(bitstring-append! bs (integer->bitstring-big #b10 2))
+(bitstring-append! bs (integer->bitstring-big #b0 1))
+(bitstring-append! bs (integer->bitstring-big #b10100 5))
+(test #b100101010110010100 (bitstring->integer-big bs))
+; append unaligned with overflow
+(define bs (->bitstring (u8vector)))
+(bitstring-append! bs (integer->bitstring-big #b100111010 9))
+(bitstring-append! bs (integer->bitstring-big #b1000111100100 13))
+(test #b1001110101000111100100 (bitstring->integer-big bs))
+(define bs (->bitstring (u8vector)))
+(bitstring-append! bs (integer->bitstring-big #b0 1))
+(bitstring-append! bs (integer->bitstring-big #b01001011011101 14))
+(bitstring-append! bs (integer->bitstring-big #b110001 6))
+(bitstring-append! bs (integer->bitstring-big #b10100011100 11))
+(test #b00100101101110111000110100011100 (bitstring->integer-big bs))
+; append with resize
+(define bs (->bitstring (u8vector)))
+(let ((a "Is There Love")
+ (b "in Space?")
+ (c "Nobody knows."))
+ (bitstring-append! bs (->bitstring a))
+ (bitstring-append! bs (->bitstring b))
+ (test #t (bitstring=? (->bitstring (string-append a b)) bs))
+ (bitstring-append! bs (->bitstring c))
+ (test #t (bitstring=? (->bitstring (string-append a b c)) bs)))
+(test-end)
+
+(test-begin "bitpacket")
+(bitpacket Packet1 (1) (2))
+(bitpacket Packet2 (A 8) (B))
+(test 3 (bitmatch `#(1 2 3) (((Packet1 bitpacket) (C 8)) C)))
+(test 6 (bitmatch `#(1 2 3) (((Packet2 bitpacket) (C 8)) (+ A B C))))
+(test-error (bitmatch `#(1 2 3) (((Packet1 bitpacket) (C 8) (D 8)) C)))
+
+(bitpacket PacketC (C 8))
+(bitpacket PacketB (B 8))
+(bitpacket PacketA (A 8) (PacketB bitpacket) (PacketC bitpacket))
+(test 6 (bitmatch `#(1 2 3) (( (PacketA bitpacket) ) (+ A B C))))
+
+(bitpacket PacketX (22) (ValueX 8))
+(bitpacket PacketY (33) (ValueY 8))
+(bitpacket PacketZ (44) (ValueZ 8))
+(test 13 (bitmatch `#( 44 10 )
+ (((PacketX bitpacket)) (+ 1 ValueX))
+ (((PacketY bitpacket)) (+ 2 ValueY))
+ (((PacketZ bitpacket)) (+ 3 ValueZ))))
+
+;;bitpacket with prefix
+(bitpacket Point (x 8) (y 8))
+
+(test 5 (bitmatch "\x01\x02\x03\x04"
+ (((p1 Point bitpacket) (p2 Point bitpacket))
+ (+ p1.x p2.y))))
+
+(bitpacket Line (start Point bitpacket)
+ (end Point bitpacket))
+
+(test 5 (bitmatch "\x01\x02\x03\x04"
+ (((Line bitpacket))
+ (+ start.x end.y))))
+
+(test 5 (bitmatch "\x01\x02\x03\x04"
+ (((line Line bitpacket))
+ (+ line.start.x line.end.y))))
+
+(test "\x01\x02\x03\x04" (let ((line.start.x 1)
+ (line.start.y 2)
+ (line.end.x 3)
+ (line.end.y 4))
+ (bitstring->string (bitconstruct (line Line bitpacket)))))
+; bitpacket constructor
+(bitpacket (Point3D make-Point3D)
+ (x float host)
+ (y float host)
+ (z float host))
+(test (f32vector 0.0 -1.0 1.0)
+ (blob->f32vector (bitstring->blob (make-Point3D (x 0.0) (y -1.0) (z 1.0)))))
+
+(test-end)
+
+(test-begin "->bitstring")
+(test 'ok (bitmatch "ABC" ((("A") (66) (#\C)) 'ok)))
+(test 'ok (bitmatch "ABC" ((("AB") (#\C)) 'ok)))
+(test 'ok (bitmatch `#( 65 66 67 ) ( (("A") (66) (#\C)) 'ok)))
+(test 'ok (bitmatch `#u8( 65 66 67 ) ((("A") (66) (#\C)) 'ok)))
+(test 'ok (bitmatch (string->blob "ABC") ((("A") (66) (#\C)) 'ok)))
+(test-error (bitmatch (s8vector 65 66 67) ((("A") (66) (#\C)) 'ok)))
+
+(bitmatch `#( 5 1 2 3 4 5)
+ (((count 8) (rest (* count 8) bitstring))
+ (print " count=" count " rest=" (bitstring-length rest))))
+(test-end)
+
+(test-begin "short form")
+(bitpacket B30 (30))
+(test 'yes (bitmatch `#( 10 20 30 )
+ (((10) (20) (11)) 'no)
+ (((10) (20) (33)) 'no)
+ (((10) (20) (B30 bitpacket)) 'yes)))
+(test-end)
+
+(test-begin "match")
+
+#;(test 1.5
+ (bitmatch `#( #x38 #x00 #x00 #x00 #x80 #x3f)
+ (((a 16 float) (b 32 float))
+ (+ a b))))
+
+(test (list 1 15)
+ (bitmatch `#( #x8F )
+ (((flagBit 1 big) (restValue 7)) (list flagBit restValue))))
+
+(test 'ok
+ (bitmatch `#( #x8F )
+ (((1 1) (rest)) 'fail)
+ (((x 1) (check (= x 0)) (rest bitstring)) 'fail2)
+ (((1 1) (rest bitstring)) 'ok)))
+
+(test 'ok
+ (bitmatch `#( #x8F )
+ (((#x8E)) 'fail1)
+ (((#x8C)) 'fail2)
+ (((#x8F)) 'ok)))
+
+(test 'ok
+ (bitmatch `#( #x8F )
+ (((#x8E)) 'fail1)
+ (((#x8C)) 'fail2)
+ (else 'ok)))
+
+(test-end)
+
+(test-begin "read")
+(define bs (vector->bitstring `#(65 66 67)))
+(test #f (bitstring-read bs 100))
+(test 2 (bitstring->integer-big (bitstring-share bs 0 3)))
+(test 5 (bitstring->integer-big (bitstring-share bs 3 10)))
+(test 579 (bitstring->integer-big (bitstring-share bs 10 24)))
+(test 2 (bitstring->integer-big (bitstring-read bs 3)))
+(test 5 (bitstring->integer-big (bitstring-read bs 7)))
+(test 579 (bitstring->integer-big (bitstring-read bs 14)))
+(test #f (bitstring-read bs 1))
+(define bs (vector->bitstring `#( #x8F )))
+(test 1 (bitstring->integer-big (bitstring-share bs 0 1)))
+(test 15 (bitstring->integer-big (bitstring-share bs 1 8)))
+(define bs (vector->bitstring `#( #x7C #x00)))
+(test 0 (bitstring->integer-big (bitstring-share bs 0 1)))
+(test 31 (bitstring->integer-big (bitstring-share bs 1 6)))
+(test-end)
+
+(define (get-fields bs)
+ (list (bitstring-start bs) (bitstring-end bs) (bitstring-buffer bs)))
+
+(test-begin "big")
+(test `(0 0 #u8()) (get-fields (integer->bitstring-big 0 0)))
+(test `(0 3 #u8(32)) (get-fields (integer->bitstring-big 1 3)))
+(test 1 (bitstring->integer-big (integer->bitstring-big 1 3)))
+(test `(0 8 #u8(15)) (get-fields (integer->bitstring-big 15 8)))
+(test 15 (bitstring->integer-big (integer->bitstring-big 15 8)))
+(test `(0 9 #u8(94 0)) (get-fields (integer->bitstring-big #xABC 9)))
+(test 188 (bitstring->integer-big (integer->bitstring-big #xABC 9)))
+(test `(0 10 #u8(175 0)) (get-fields (integer->bitstring-big #xABC 10)))
+(test 700 (bitstring->integer-big (integer->bitstring-big #xABC 10)))
+(test 123213 (bitstring->integer-big (integer->bitstring-big 123213 32)))
+(test #x00000001 (bitstring->integer-big (integer->bitstring-big #x00000001 32)))
+(test #x10000000 (bitstring->integer-big (integer->bitstring-big #x10000000 32)))
+(test #x7FFFFFFF (bitstring->integer-big (integer->bitstring-big #x7FFFFFFF 32)))
+(test #xFFFFFFFF (bitstring->integer-big (integer->bitstring-big #xFFFFFFFF 32)))
+(test-end)
+
+(test-begin "little")
+(test `(0 0 #u8()) (get-fields (integer->bitstring-little 0 0)))
+(test `(0 3 #u8(32)) (get-fields (integer->bitstring-little 1 3)))
+(test 1 (bitstring->integer-little (integer->bitstring-little 1 3)))
+(test `(0 8 #u8(15)) (get-fields (integer->bitstring-little 15 8)))
+(test 15 (bitstring->integer-little (integer->bitstring-little 15 8)))
+(test `(0 9 #u8(188 0)) (get-fields(integer->bitstring-little #xABC 9)))
+(test 188 (bitstring->integer-little (integer->bitstring-little #xABC 9)))
+(test `(0 10 #u8(188 128)) (get-fields (integer->bitstring-little #xABC 10)))
+(test 700 (bitstring->integer-little (integer->bitstring-little #xABC 10)))
+(test 123213 (bitstring->integer-little (integer->bitstring-little 123213 32)))
+(test #x00000001 (bitstring->integer-little (integer->bitstring-little #x00000001 32)))
+(test #x10000000 (bitstring->integer-little (integer->bitstring-little #x10000000 32)))
+(test #x7FFFFFFF (bitstring->integer-little (integer->bitstring-little #x7FFFFFFF 32)))
+(test #xFFFFFFFF (bitstring->integer-little (integer->bitstring-little #xFFFFFFFF 32)))
+(test-end)
+
+(test-begin "half")
+(test +inf.0 (bitstring->half (vector->bitstring `#( #x7C #x00))))
+(test -inf.0 (bitstring->half (vector->bitstring `#( #xFC #x00))))
+(test 0. (bitstring->half (vector->bitstring `#( #x00 #x00))))
+(test -0. (bitstring->half (vector->bitstring `#( #x80 #x00))))
+(test 0.5 (bitstring->half (vector->bitstring `#( #x38 #x00))))
+(test 1. (bitstring->half (vector->bitstring `#( #x3C #x00))))
+(test 25. (bitstring->half (vector->bitstring `#( #x4E #x40))))
+(test 0.099976 (bitstring->half (vector->bitstring `#( #x2E #x66))))
+(test -0.122986 (bitstring->half (vector->bitstring `#( #xAF #xDF))))
+;-124.0625
+(test-end)
+
+(test-begin "single")
+(test +inf.0 (bitstring->single (vector->bitstring `#( #x00 #x00 #x80 #x7F))))
+(test -inf.0 (bitstring->single (vector->bitstring `#( #x00 #x00 #x80 #xFF))))
+;(test +nan.0 (bitstring->single (vector->bitstring `#( #x7F #xC0 #x00 #x00))))
+(test 0. (bitstring->single (vector->bitstring `#( #x00 #x00 #x00 #x00))))
+(test -0. (bitstring->single (vector->bitstring `#( #x00 #x00 #x00 #x80))))
+(test #t (equal? 1. (bitstring->single (vector->bitstring `#( #x00 #x00 #x80 #x3f)))))
+(test 0.5 (bitstring->single (vector->bitstring `#( #x00 #x00 #x00 #x3f))))
+(test 25. (bitstring->single (vector->bitstring `#( #x00 #x00 #xc8 #x41))))
+(test 0.1 (bitstring->single (vector->bitstring `#( #xcd #xcc #xcc #x3d))))
+(test -0.123 (bitstring->single (vector->bitstring `#( #xE7 #x6D #xFB #xBD))))
+(test `(0 32 #u8( #x00 #x00 #x00 #x3f)) (get-fields (single->bitstring 0.5)))
+(test `(0 32 #u8( #x6D #xE7 #xFB #xBD)) (get-fields (single->bitstring -0.123)))
+(test-end)
+
+(test-begin "boolean")
+(test #t (bitmatch (bitconstruct (#t boolean))
+ (((B boolean)) B)))
+
+(test #t (bitmatch (bitconstruct (#t 32 boolean))
+ (((B 32 boolean)) B)))
+
+(test #t (bitmatch (bitconstruct (#t 32 boolean little))
+ (((B 32 boolean little)) B)))
+
+(test #f (bitmatch (bitconstruct (#f 16 boolean host))
+ (((B 16 boolean host)) B)
+ (((X bitstring)) X)))
+
+(test (vector 0.0 0.0 #t #t)
+ (bitmatch (u8vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
+ (((a double big) (b double big) (c boolean) (d boolean))
+ (vector a b c d))))
+
+(test (list 1) (bitstring->list (bitconstruct (#t boolean)) 8))
+(test (list 0) (bitstring->list (bitconstruct (#f boolean)) 8))
+(test-end)
+
+(test-begin "reader proc")
+
+(define (zterminated-string bs)
+ (let loop ((n 8) (acc '()))
+ (bitmatch (or (bitstring-read bs 8) "")
+ (() -> #f) ; end of stream
+ ((0) -> (list n (list->string (reverse acc))))
+ ((c) -> (loop (+ n 8) (cons (integer->char c) acc))))))
+(test "BC" (bitmatch "ABC\x00" ((("A") ((str zterminated-string) bitstring)) str)))
+(test-error (bitmatch "ABC" ((("A") ((str zterminated-string) bitstring)) str)))
+(test #f (bitmatch "ABC" ((("A") ((str zterminated-string) bitstring)) str) (else #f)))
+
+(test-end)
+
+(test-begin "offset")
+(test 32 (bitmatch "ABCD" (((start offset) ("ABCD") (end offset)) (- end start))))
+(test 6 (bitmatch "X" (((_ 1) (start offset) (_ 6) (end offset) (_ 1)) (- end start))))
+(test 5 (bitmatch "X" (((_ 3) (rest bitstring))
+ (bitmatch rest (((start offset) (_ 5) (end offset)) (- end start))))))
+(test (list 3 8)
+ (bitmatch "X" (((_ 3) (rest bitstring))
+ (bitmatch rest (((start offset) (_ 5) (end offset)) (list start end))))))
+(test-end)
+
+(test-begin "seek")
+(test #t (bitmatch "ABC" ((("A") (-8 seek) ("ABC")) #t)))
+(test #t (bitmatch "ABC" (((+8 seek) ("BC")) #t)))
+(test #t (bitmatch "ABC" (((0 seek) ("ABC")) #t)))
+(test #t (bitmatch "ABC" (((-0 seek) ("ABC")) #t)))
+(test-error (bitmatch "ABC" ((("A") (-16 seek) (rest bitstring)) #t)))
+(test-error (bitmatch "ABC" ((("A") (+20 seek) (rest bitstring)) #t)))
+(test-end)
+
+(test-end "bitstring")
+
+(test-exit)
+
(DIR) diff --git a/tests/tga.scm b/tests/tga.scm
@@ -0,0 +1,90 @@
+
+; Basic TGA image parser.
+; Support True-Image type format and Run-Length-Encoding compression.
+; SPEC: http://www.dca.fee.unicamp.br/~martino/disciplinas/ea978/tgaffs.pdf
+
+(use bitstring posix srfi-4)
+
+(bitpacket TGA-Header
+ (ID-length 8)
+ (ColorMapType 8)
+ (ImageType 8)
+ (TGA-ColorMapSpec bitpacket)
+ (TGA-ImageSpec bitpacket))
+
+(bitpacket TGA-ColorMapSpec
+ (FirstEntryIndex 16 little)
+ (ColorMapLength 16 little)
+ (ColorMapEntrySize 8))
+
+(bitpacket TGA-ImageSpec
+ (X-Origin 16 little)
+ (Y-Origin 16 little)
+ (ImageWidth 16 little)
+ (ImageHeight 16 little)
+ (PixelDepth 8)
+ (ImageTransferOrder 2)
+ (#x00 2) ; reserved
+ (AttributesBitsPerPixel 4))
+
+(define (parse-tga file file-out)
+ (let* ((fi (file-open file (+ open/rdonly open/binary)))
+ (fo (file-open file-out (+ open/write open/creat open/trunc open/binary)))
+ (size (file-size fi))
+ (res (file-read fi size))
+ (data (car res)))
+ (bitmatch data
+ ; True-Color uncompressed
+ (((TGA-Header bitpacket)
+ (check (and (= 0 ColorMapType) (= 2 ImageType)))
+ (ID-data ID-length bitstring)
+ (Image-data (* ImageWidth ImageHeight PixelDepth) bitstring)
+ (Rest-data bitstring))
+ (begin
+ (print "True-Color uncompressed")
+ (print ImageWidth "x" ImageHeight "x" PixelDepth)
+ (parse-image-uncompressed
+ (lambda (color)
+ (file-write fo (bitstring->blob color)))
+ PixelDepth Image-data)))
+ ; True-Color compressed
+ (((TGA-Header bitpacket)
+ (check (and (= 0 ColorMapType) (= 10 ImageType)))
+ (ID-data ID-length bitstring)
+ (Image-data bitstring))
+ (begin
+ (print "True-Color compressed")
+ (print ImageWidth "x" ImageHeight "x" PixelDepth)
+ (parse-image-compressed
+ (lambda (color)
+ (file-write fo (bitstring->blob color)))
+ PixelDepth Image-data))))))
+
+(define (parse-image-uncompressed func depth image)
+ (bitmatch image
+ ((())
+ 'ok)
+ (((Color depth bitstring) (Rest bitstring))
+ (begin
+ (func Color)
+ (parse-image-uncompressed func depth Rest)))))
+
+(define (parse-image-compressed func depth image)
+ (bitmatch image
+ ((())
+ 'ok)
+ (((1 1) (Count 7) (Color depth bitstring) (Rest bitstring))
+ (let loop ((i 0))
+ (func Color)
+ (if (< i Count)
+ (loop (+ i 1))
+ (parse-image-compressed func depth Rest))))
+ (((0 1) (Count 7) (RAW-data (* depth (+ Count 1)) bitstring) (Rest bitstring))
+ (begin
+ (parse-image-uncompressed func depth RAW-data)
+ (parse-image-compressed func depth Rest)))))
+
+; Convert images to raw pixels
+(parse-tga "tests/24compressed.tga" "tests/24c.raw")
+(parse-tga "tests/24uncompressed.tga" "tests/24u.raw")
+