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