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

Last change on this file since 38412 was 38412, checked in by Kon Lovett, 7 months ago

remove fixnum, add rt type checks, rt type checks obviate compiler checks

File size: 4.6 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;;
38
39(define-inline (get-bv-alias loc obj)
40  (cond
41    ((blob? obj)
42      obj )
43    ((string? obj)
44      obj )
45    ((u8vector? obj)
46      (u8vector->blob/shared obj) )
47    ((s8vector? obj)
48      (s8vector->blob/shared obj) )
49    ((u16vector? obj)
50      (u16vector->blob/shared obj) )
51    ((s16vector? obj)
52      (s16vector->blob/shared obj) )
53    ((u32vector? obj)
54      (u32vector->blob/shared obj) )
55    ((s32vector? obj)
56      (s32vector->blob/shared obj) )
57    ((f32vector? obj)
58      (f32vector->blob/shared obj) )
59    ((f64vector? obj)
60      (f64vector->blob/shared obj) )
61    (else
62        (error-argument-type loc obj "blob, string, or srfi-4-vector" obj) ) ) )
63
64(define-inline (get-bv loc obj)
65  (if (string? obj)
66    (string->blob obj)
67    (get-bv-alias loc obj) ) )
68
69;;
70
71(: bytes->hexstring (bytevector #!optional fixnum fixnum -> string))
72;
73(define (bytes->hexstring bv #!optional (start 0) (end #f))
74  (blob->hex (get-bv 'bytes->hexstring bv) start end) )
75
76;; 8
77
78(: bytes-set-u8! (bytevector fixnum fixnum -> void))
79;
80(define (bytes-set-u8! bv idx uint)
81        (*blob-set-u8! (get-bv-alias 'bytes-set-u8! bv) uint idx) )
82
83(: bytes-set-s8! (bytevector fixnum fixnum -> void))
84;
85(define (bytes-set-s8! bv idx int)
86        (*blob-set-u8! (get-bv-alias 'bytes-set-u8! bv) int idx) )
87
88;; Both Endian 16, 32, & 64
89
90(define-inline (get-byte-order loc obj)
91  (case obj
92        ((big-endian be big msb)
93          'big-endian )
94        ((little-endian le little lsb)
95          'little-endian )
96    (else
97        (error-argument-type loc obj "symbol in {big-endian be big msb little-endian le little lsb}" obj) ) ) )
98
99;;
100
101(: bytes-set-u16! (bytevector fixnum fixnum -> void))
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(: bytes-set-s16! (bytevector fixnum fixnum -> void))
112;
113(define (bytes-set-s16! bv idx int #!optional (order (machine-byte-order)))
114        (let ((bv (get-bv-alias 'bytes-set-s16! bv)))
115                (case (get-byte-order 'bytes-set-s16! order)
116                        ((little-endian)
117                          (*blob-set-u16-le! bv int idx) )
118                        ((big-endian)
119                          (*blob-set-u16-be! bv int idx) ) ) ) )
120
121
122(: bytes-set-u32! (bytevector fixnum number -> void))
123;
124(define (bytes-set-u32! bv idx uint #!optional (order (machine-byte-order)))
125        (let ((bv (get-bv-alias 'bytes-set-u32! bv)))
126                (case (get-byte-order 'bytes-set-u32! order)
127                        ((little-endian)
128                          (*blob-set-u32-le! bv uint idx) )
129                        ((big-endian)
130                          (*blob-set-u32-be! bv uint idx) ) ) ) )
131
132(: bytes-set-s32! (bytevector fixnum number -> void))
133;
134(define (bytes-set-s32! bv idx int #!optional (order (machine-byte-order)))
135        (let ((bv (get-bv-alias 'bytes-set-s32! bv)))
136                (case (get-byte-order 'bytes-set-s32! order)
137                        ((little-endian)
138                          (*blob-set-u32-le! bv int idx) )
139                        ((big-endian)
140                          (*blob-set-u32-be! bv int idx) ) ) ) )
141
142(: bytes-set-u64! (bytevector fixnum number -> void))
143;
144(define (bytes-set-u64! bv idx uint #!optional (order (machine-byte-order)))
145        (let ((bv (get-bv-alias 'bytes-set-u64! bv)))
146                (case (get-byte-order 'bytes-set-u64! order)
147                        ((little-endian)
148                          (*blob-set-u64-le! bv uint idx) )
149                        ((big-endian)
150                          (*blob-set-u64-be! bv uint idx) ) ) ) )
151
152(: bytes-set-s64! (bytevector fixnum number -> void))
153;
154(define (bytes-set-s64! bv idx int #!optional (order (machine-byte-order)))
155        (let ((bv (get-bv-alias 'bytes-set-s64! bv)))
156                (case (get-byte-order 'bytes-set-s64! order)
157                        ((little-endian)
158                          (*blob-set-u64-le! bv int idx) )
159                        ((big-endian)
160                          (*blob-set-u64-be! bv int idx) ) ) ) )
161
162) ;module blob-utils
Note: See TracBrowser for help on using the repository browser.