source: project/release/5/blob-utils/trunk/blob-utils.scm @ 38917

Last change on this file since 38917 was 38917, checked in by Kon Lovett, 2 months ago

add -strict-types, fix pack-integer single-byte error (arg order), group types

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