source: project/release/5/blob-utils/trunk/blob-set-int.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: 5.6 KB
Line 
1;;;; blob-set-int.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-set-int
10
11(;export
12  blob-set-u8!
13  blob-set-u16-le! blob-set-u32-le! blob-set-u64-le!
14  blob-set-u16-be! blob-set-u32-be! blob-set-u64-be!
15  ;
16  *blob-set-u8!
17  *blob-set-u16-le! *blob-set-u32-le! *blob-set-u64-le!
18  *blob-set-u16-be! *blob-set-u32-be! *blob-set-u64-be!)
19
20(import scheme)
21(import (chicken base))
22(import (chicken foreign))
23(import (chicken type))
24(import (only type-checks
25  check-natural-fixnum check-fixnum check-integer
26  check-blob))
27
28;;
29
30(: *blob-set-u8! ((or blob string) number fixnum -> void))
31(: *blob-set-u16-le! ((or blob string) number fixnum -> void))
32(: *blob-set-u32-le! ((or blob string) number fixnum -> void))
33(: *blob-set-u64-le! ((or blob string) number fixnum -> void))
34(: *blob-set-u16-be! ((or blob string) number fixnum -> void))
35(: *blob-set-u32-be! ((or blob string) number fixnum -> void))
36(: *blob-set-u64-be! ((or blob string) number fixnum -> void))
37(: blob-set-u8! (blob fixnum #!optional fixnum -> void))
38(: blob-set-u16-le! (blob fixnum #!optional fixnum -> void))
39(: blob-set-u32-le! (blob number #!optional fixnum -> void))
40(: blob-set-u64-le! (blob number #!optional fixnum -> void))
41(: blob-set-u16-be! (blob fixnum #!optional fixnum -> void))
42(: blob-set-u32-be! (blob number #!optional fixnum -> void))
43(: blob-set-u64-be! (blob number #!optional fixnum -> void))
44
45;; Only Blob Bytevector, No Argument Checking
46
47(define *blob-set-u8!
48  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off)) "
49    ((uint8_t *)bv)[off] = (uint8_t)(u32 & 0xff);"))
50
51(define *blob-set-u16-le!
52  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off)) "
53    ((uint8_t *)bv)[off]   = (uint8_t)(u32 & 0xff);
54    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 8) & 0xff);"))
55
56(define *blob-set-u16-be!
57  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off)) "
58    ((uint8_t *)bv)[off]   = (uint8_t)((u32 >> 8) & 0xff);
59    ((uint8_t *)bv)[++off] = (uint8_t)(u32 & 0xff);"))
60
61(define *blob-set-u32-le!
62  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off)) "
63    ((uint8_t *)bv)[off]   = (uint8_t)(u32 & 0xff);
64    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 8) & 0xff);
65    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 16) & 0xff);
66    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 24) & 0xff);"))
67
68(define *blob-set-u32-be!
69  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer32 u32) (int off)) "
70    ((uint8_t *)bv)[off]   = (uint8_t)((u32 >> 24) & 0xff);
71    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 16) & 0xff);
72    ((uint8_t *)bv)[++off] = (uint8_t)((u32 >> 8) & 0xff);
73    ((uint8_t *)bv)[++off] = (uint8_t)(u32 & 0xff);"))
74
75(define *blob-set-u64-le!
76  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer64 u64) (int off)) "
77    ((uint8_t *)bv)[off]   = (uint8_t)(u64 & 0xff);
78    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 8) & 0xff);
79    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 16) & 0xff);
80    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 24) & 0xff);
81    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 32) & 0xff);
82    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 40) & 0xff);
83    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 48) & 0xff);
84    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 56) & 0xff);"))
85
86(define *blob-set-u64-be!
87  (foreign-lambda* void ((nonnull-scheme-pointer bv) (unsigned-integer64 u64) (int off)) "
88    ((uint8_t *)bv)[off]   = (uint8_t)((u64 >> 56) & 0xff);
89    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 48) & 0xff);
90    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 40) & 0xff);
91    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 32) & 0xff);
92    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 24) & 0xff);
93    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 16) & 0xff);
94    ((uint8_t *)bv)[++off] = (uint8_t)((u64 >> 8) & 0xff);
95    ((uint8_t *)bv)[++off] = (uint8_t)(u64 & 0xff);"))
96
97;; Only Blob Bytevector
98
99;; 8
100
101(define (blob-set-u8! blb uint #!optional (off 0))
102  (*blob-set-u8!
103    (check-blob 'blob-set-u8! blb)
104    (check-fixnum 'blob-set-u8! uint)
105    (check-natural-fixnum 'blob-set-u8! off 'offset)) )
106
107;; Little Endian 16, 32, & 64
108
109(define (blob-set-u16-le! blb uint #!optional (off 0))
110  (*blob-set-u16-le!
111    (check-blob 'blob-set-u16-le! blb)
112    (check-fixnum 'blob-set-u16-le! uint)
113    (check-natural-fixnum 'blob-set-u16-le! off 'offset)) )
114
115(define (blob-set-u32-le! blb uint #!optional (off 0))
116  (*blob-set-u32-le!
117    (check-blob 'blob-set-u32-le! blb)
118    (check-integer 'blob-set-u32-le! uint)
119    (check-natural-fixnum 'blob-set-u32-le! off 'offset)) )
120
121(define (blob-set-u64-le! blb uint #!optional (off 0))
122  (*blob-set-u64-le!
123    (check-blob 'blob-set-u64-le! blb)
124    (check-integer 'blob-set-u64-le! uint)
125    (check-natural-fixnum 'blob-set-u64-le! off 'offset)) )
126
127;; Big Endian 16, 32, & 64
128
129(define (blob-set-u16-be! blb uint #!optional (off 0))
130  (*blob-set-u16-be!
131    (check-blob 'blob-set-u16-be! blb)
132    (check-fixnum 'blob-set-u16-be! uint)
133    (check-natural-fixnum 'blob-set-u16-be! off 'offset)) )
134
135(define (blob-set-u32-be! blb uint #!optional (off 0))
136  (*blob-set-u32-be!
137    (check-blob 'blob-set-u32-be! blb)
138    (check-integer 'blob-set-u32-be! uint)
139    (check-natural-fixnum 'blob-set-u32-be! off 'offset)) )
140
141(define (blob-set-u64-be! blb uint #!optional (off 0))
142  (*blob-set-u64-be!
143    (check-blob 'blob-set-u64-be! blb)
144    (check-integer 'blob-set-u64-be! uint)
145    (check-natural-fixnum 'blob-set-u64-be! off 'offset)) )
146
147) ;module blob-set-int
Note: See TracBrowser for help on using the repository browser.