source: project/release/4/blob-utils/trunk/blob-utils.scm @ 35386

Last change on this file since 35386 was 35386, checked in by Kon Lovett, 19 months ago

add blob-utils module (wider bv api)

File size: 4.4 KB
Line 
1;;;; blob-utils.scm
2;;;; Kon Lovett, Apr '12
3
4;; Issues
5;;
6;; - Chicken uses "signed integer" but treated here as "unsigned integer"
7
8(module blob-utils
9
10(;export
11  bytes->hexstring
12  bytes-set-u8! bytes-set-s8!
13  bytes-set-u16! bytes-set-s16!
14  bytes-set-u32! bytes-set-s32!
15  bytes-set-u64! bytes-set-s64!)
16
17(import scheme chicken)
18(use
19  srfi-4
20  (only type-errors error-argument-type)
21  blob-hexadecimal
22  blob-set-int)
23
24;;; Bytevector - Blob, String, & SRFI-4-Vector
25
26(define-type srfi-4-uint-vector (or u8vector u16vector u32vector))
27(define-type srfi-4-int-vector (or s8vector s16vector s32vector))
28(define-type srfi-4-float-vector (or f32vector f64vector))
29(define-type srfi-4-vector (or srfi-4-uint-vector srfi-4-int-vector srfi-4-float-vector))
30
31(define-type bytevector (or blob string srfi-4-vector))
32
33;;
34
35(define-inline (get-bv-alias loc obj)
36  (cond
37    ((blob? obj)
38      obj )
39    ((string? obj)
40      obj )
41    ((u8vector? obj)
42      (u8vector->blob/shared obj) )
43    ((s8vector? obj)
44      (s8vector->blob/shared obj) )
45    ((u16vector? obj)
46      (u16vector->blob/shared obj) )
47    ((s16vector? obj)
48      (s16vector->blob/shared obj) )
49    ((u32vector? obj)
50      (u32vector->blob/shared obj) )
51    ((s32vector? obj)
52      (s32vector->blob/shared obj) )
53    ((f32vector? obj)
54      (f32vector->blob/shared obj) )
55    ((f64vector? obj)
56      (f64vector->blob/shared obj) )
57    (else
58        (error-argument-type loc obj "blob, string, or srfi-4-vector" obj) ) ) )
59
60(define-inline (get-bv loc obj)
61  (if (string? obj)
62    (string->blob obj)
63    (get-bv-alias loc obj) ) )
64
65;;
66
67(: bytes->hexstring (bytevector #!optional fixnum fixnum -> string))
68;
69(define (bytes->hexstring bv #!optional (start 0) (end #f))
70  (blob->hex (get-bv 'bytes->hexstring bv) start end) )
71
72;; 8
73
74(: bytes-set-u8! (bytevector fixnum fixnum -> void))
75;
76(define (bytes-set-u8! bv idx uint)
77        (*blob-set-u8! (get-bv-alias 'bytes-set-u8! bv) uint idx) )
78
79(: bytes-set-s8! (bytevector fixnum fixnum -> void))
80;
81(define (bytes-set-s8! bv idx int)
82        (*blob-set-u8! (get-bv-alias 'bytes-set-u8! bv) int idx) )
83
84;; Both Endian 16, 32, & 64
85
86(define-inline (get-byte-order loc obj)
87  (case obj
88        ((big-endian be big msb)
89          'big-endian )
90        ((little-endian le little lsb)
91          'little-endian )
92    (else
93        (error-argument-type loc obj "symbol in {big-endian be big msb little-endian le little lsb}" obj) ) ) )
94
95;;
96
97(: bytes-set-u16! (bytevector fixnum fixnum -> void))
98;
99(define (bytes-set-u16! bv idx uint #!optional (order (machine-byte-order)))
100        (let ((bv (get-bv-alias 'bytes-set-u16! bv)))
101                (case (get-byte-order 'bytes-set-u16! order)
102                        ((little-endian)
103                          (*blob-set-u16-le! bv uint idx) )
104                        ((big-endian)
105                          (*blob-set-u16-be! bv uint idx) ) ) ) )
106
107(: bytes-set-s16! (bytevector fixnum fixnum -> void))
108;
109(define (bytes-set-s16! bv idx int #!optional (order (machine-byte-order)))
110        (let ((bv (get-bv-alias 'bytes-set-s16! bv)))
111                (case (get-byte-order 'bytes-set-s16! order)
112                        ((little-endian)
113                          (*blob-set-u16-le! bv int idx) )
114                        ((big-endian)
115                          (*blob-set-u16-be! bv int idx) ) ) ) )
116
117
118(: bytes-set-u32! (bytevector fixnum number -> void))
119;
120(define (bytes-set-u32! bv idx uint #!optional (order (machine-byte-order)))
121        (let ((bv (get-bv-alias 'bytes-set-u32! bv)))
122                (case (get-byte-order 'bytes-set-u32! order)
123                        ((little-endian)
124                          (*blob-set-u32-le! bv uint idx) )
125                        ((big-endian)
126                          (*blob-set-u32-be! bv uint idx) ) ) ) )
127
128(: bytes-set-s32! (bytevector fixnum number -> void))
129;
130(define (bytes-set-s32! bv idx int #!optional (order (machine-byte-order)))
131        (let ((bv (get-bv-alias 'bytes-set-s32! bv)))
132                (case (get-byte-order 'bytes-set-s32! order)
133                        ((little-endian)
134                          (*blob-set-u32-le! bv int idx) )
135                        ((big-endian)
136                          (*blob-set-u32-be! bv int idx) ) ) ) )
137
138(: bytes-set-u64! (bytevector fixnum number -> void))
139;
140(define (bytes-set-u64! bv idx uint #!optional (order (machine-byte-order)))
141        (let ((bv (get-bv-alias 'bytes-set-u64! bv)))
142                (case (get-byte-order 'bytes-set-u64! order)
143                        ((little-endian)
144                          (*blob-set-u64-le! bv uint idx) )
145                        ((big-endian)
146                          (*blob-set-u64-be! bv uint idx) ) ) ) )
147
148(: bytes-set-s64! (bytevector fixnum number -> void))
149;
150(define (bytes-set-s64! bv idx int #!optional (order (machine-byte-order)))
151        (let ((bv (get-bv-alias 'bytes-set-s64! bv)))
152                (case (get-byte-order 'bytes-set-s64! order)
153                        ((little-endian)
154                          (*blob-set-u64-le! bv int idx) )
155                        ((big-endian)
156                          (*blob-set-u64-be! bv int idx) ) ) ) )
157
158) ;module blob-utils
Note: See TracBrowser for help on using the repository browser.