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