1;;;
2;;; srfi-74 - Octet-addressed binary blocks
3;;;
4
5;; On Gauche, a blob is just an u8vector.
6
7(define-module srfi-74
8  (use gauche.uvector)
9  (use gauche.generator)
10  (use binary.io)
11  (export endianness blob? make-blob blob-length
12          blob-u8-ref blob-u8-set!
13          blob-s8-ref blob-s8-set!
14          blob-u16-ref blob-u16-set!
15          blob-u16-native-ref blob-u16-native-set!
16          blob-s16-ref blob-s16-set!
17          blob-s16-native-ref blob-s16-native-set!
18          blob-u32-ref blob-u32-set!
19          blob-u32-native-ref blob-u32-native-set!
20          blob-s32-ref blob-s32-set!
21          blob-s32-native-ref blob-s32-native-set!
22          blob-u64-ref blob-u64-set!
23          blob-u64-native-ref blob-u64-native-set!
24          blob-s64-ref blob-s64-set!
25          blob-s64-native-ref blob-s64-native-set!
26          blob-uint-ref blob-uint-set!
27          blob-sint-ref blob-sint-set!
28          blob=? blob-copy! blob-copy
29          blob->u8-list u8-list->blob
30          blob->uint-list uint-list->blob
31          blob->sint-list sint-list->blob))
32(select-module srfi-74)
33
34(define-constant native (native-endian))
35
36(define-syntax endianness
37  (syntax-rules (big little native)
38    [(_ big)    'big-endian]
39    [(_ little) 'little-endian]
40    [(_ native) native]
41    [(_ x)      (syntax-error "Unknown endianness:" x)]))
42
43(define blob? u8vector?)
44
45(define (make-blob k) (make-u8vector k))
46
47(define (blob-length blob) (u8vector-length blob))
48
49(define (blob-u8-ref blob k) (get-u8 blob k))
50(define (blob-u8-set! blob k v) (put-u8! blob k v))
51(define (blob-s8-ref blob k) (get-s8 blob k))
52(define (blob-s8-set! blob k v) (put-s8! blob k v))
53
54(define (blob-u16-ref endi blob k)      (get-u16 blob k endi))
55(define (blob-u16-native-ref blob k)    (get-u16 blob k native))
56(define (blob-u16-set! endi blob k v)   (put-u16! blob k endi))
57(define (blob-u16-native-set! blob k v) (put-u16! blob k native))
58
59(define (blob-s16-ref endi blob k)      (get-s16 blob k endi))
60(define (blob-s16-native-ref blob k)    (get-s16 blob k native))
61(define (blob-s16-set! endi blob k v)   (put-s16! blob k endi))
62(define (blob-s16-native-set! blob k v) (put-s16! blob k native))
63
64(define (blob-u32-ref endi blob k)      (get-u32 blob k endi))
65(define (blob-u32-native-ref blob k)    (get-u32 blob k native))
66(define (blob-u32-set! endi blob k v)   (put-u32! blob k endi))
67(define (blob-u32-native-set! blob k v) (put-u32! blob k native))
68
69(define (blob-s32-ref endi blob k)      (get-s32 blob k endi))
70(define (blob-s32-native-ref blob k)    (get-s32 blob k native))
71(define (blob-s32-set! endi blob k v)   (put-s32! blob k endi))
72(define (blob-s32-native-set! blob k v) (put-s32! blob k native))
73
74(define (blob-u64-ref endi blob k)      (get-u64 blob k endi))
75(define (blob-u64-native-ref blob k)    (get-u64 blob k native))
76(define (blob-u64-set! endi blob k v)   (put-u64! blob k endi))
77(define (blob-u64-native-set! blob k v) (put-u64! blob k native))
78
79(define (blob-s64-ref endi blob k)      (get-s64 blob k endi))
80(define (blob-s64-native-ref blob k)    (get-s64 blob k native))
81(define (blob-s64-set! endi blob k v)   (put-s64! blob k endi))
82(define (blob-s64-native-set! blob k v) (put-s64! blob k native))
83
84(define (blob-uint-ref size endi blob k)
85  (assume-type blob <u8vector>)
86  (get-uint size blob k endi))
87
88(define (blob-sint-ref size endi blob k)
89  (assume-type blob <u8vector>)
90  (get-sint size blob k endi))
91
92(define (blob-uint-set! size endi blob k v)
93  (assume-type blob <u8vector>)
94  (put-uint! size blob k v endi))
95
96(define (blob-sint-set! size endi blob k v)
97  (assume-type blob <u8vector>)
98  (put-sint! size blob k v endi))
99
100(define (blob=? a b) (u8vector=? a b))
101
102(define (blob-copy! src src-start target target-start n)
103  (u8vector-copy! target target-start src src-start (+ src-start n)))
104
105(define (blob-copy blob) (u8vector-copy blob))
106
107(define blob->u8-list u8vector->list)
108(define u8-list->blob list->u8vector)
109
110(define (blob->uint-list size endi blob)
111  (generator->list (gmap (cut blob-uint-ref size endi blob <>)
112                         (grange 0 (blob-length blob) size))))
113(define (blob->sint-list size endi blob)
114  (generator->list (gmap (cut blob-sint-ref size endi blob <>)
115                         (grange 0 (blob-length blob) size))))
116
117(define (uint-list->blob size endi lis)
118  (rlet1 v (make-u8vector (* size (length lis)))
119    (do ([k 0 (+ k size)]
120         [lis lis (cdr lis)])
121        [(null? lis)]
122      (blob-uint-set! size endi v k (car lis)))))
123(define (sint-list->blob size endi lis)
124  (rlet1 v (make-u8vector (* size (length lis)))
125    (do ([k 0 (+ k size)]
126         [lis lis (cdr lis)])
127        [(null? lis)]
128      (blob-sint-set! size endi v k (car lis)))))
129