source: project/release/5/blob-utils/trunk/pack-integer.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: 7.6 KB
Line 
1;;;; pack-integer.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Apr '12
4;;;; Kon Lovett, May '10 (message-digest.scm)
5;;;; Kon Lovett, Jan '06 (message-digest.scm)
6
7;; Issues
8
9#>
10/* start is not a general offset. bytes length <= size */
11static void
12pack_uint64( uint8_t *bytes, uint64_t n, int size, int direction, int start )
13{
14  int end;
15
16  if(size == 1) {                           /* 1 byte */
17    bytes[start] = n;
18  } else if(direction == -1) {           /* Big endian */
19    end = start;
20    bytes[start += size - 1] = n & 0xff;    /* 2 bytes */
21    bytes[--start] = (n >> 8) & 0xff;
22    if(start != end) {                      /* 4 bytes */
23      bytes[--start] = (n >> 16) & 0xff;
24      bytes[--start] = (n >> 24) & 0xff;
25      if(start != end) {                    /* 8 bytes */
26        bytes[--start] = (n >> 32) & 0xff;
27        bytes[--start] = (n >> 40) & 0xff;
28        bytes[--start] = (n >> 48) & 0xff;
29        bytes[--start] = (n >> 56) & 0xff;
30      }
31    }
32  } else {                              /* Little endian */
33    end = start + size - 1;
34    bytes[start] = n & 0xff;              /* 2 bytes */
35    bytes[++start] = (n >> 8) & 0xff;
36    if(start != end) {                    /* 4 bytes */
37      bytes[++start] = (n >> 16) & 0xff;
38      bytes[++start] = (n >> 24) & 0xff;
39      if(start != end) {                  /* 8 bytes */
40        bytes[++start] = (n >> 32) & 0xff;
41        bytes[++start] = (n >> 40) & 0xff;
42        bytes[++start] = (n >> 48) & 0xff;
43        bytes[++start] = (n >> 56) & 0xff;
44      }
45    }
46  }
47}
48<#
49
50(module pack-integer
51
52(;export
53  pack-u8
54  pack-u16
55  pack-u32
56  pack-u64
57  pack-integer)
58
59(import scheme)
60(import (chicken base))
61(import (chicken type))
62(import (chicken blob))
63(import (chicken platform))
64(import (chicken foreign))
65(import (only (chicken memory representation) number-of-bytes))
66(import (only (srfi 4)
67  make-u8vector u8vector? u8vector-length u8vector-set!))
68(import (only type-checks
69  check-blob check-fixnum check-integer check-natural-fixnum
70  define-check+error-type))
71(import (only type-errors
72  error-argument-type
73  error-half-closed-interval
74  define-error-type))
75(import blob-set-int)
76
77;;; Integer Packing Utilities
78
79;;
80
81; All the below primitive pack routines must return the supplied buffer object.
82
83;; Pack an 8 bit integer
84
85(define-inline (pack-u8-with-u8vector! u8vec n i)
86  (u8vector-set! u8vec i n)
87  u8vec )
88
89(define-inline (pack-u8-with-bytevector! bv n i)
90  (##core#inline "C_setbyte" bv i n) ;(bytevector-set! bv i n)
91  bv )
92
93(define-inline (pack-u8-with-blob! blb n i)
94  (pack-u8-with-bytevector! blb n i) )
95
96(define-inline (pack-u8-with-string! str n i)
97  (pack-u8-with-bytevector! str n i) )
98
99; Pack a 16, 32, or 64 bit integer with endian order
100
101(define-inline (pack-u64-with-u8vector! u8vec n size direction start)
102  ((foreign-lambda void "pack_uint64" nonnull-u8vector unsigned-integer64 int int int)
103     u8vec n size direction start)
104  u8vec )
105
106(define-inline (pack-u64-with-bytevector! bv n size direction start)
107  ((foreign-lambda void "pack_uint64" nonnull-scheme-pointer unsigned-integer64 int int int)
108    bv n size direction start)
109  bv )
110
111(define-inline (pack-u64-with-blob! blb n size direction start)
112  (pack-u64-with-bytevector! blb n size direction start) )
113
114(define-inline (pack-u64-with-string! str n size direction start)
115  (pack-u64-with-bytevector! str n size direction start) )
116
117;;
118
119(define-constant MAX-BV-LEN 16777215) ;2^24-1 is the maximum length of a bytevector
120
121(define-inline (byte-order->direction order)
122  (case order
123    ((big-endian be big)
124      -1 )
125    ((little-endian le little)
126      1 )
127    (else
128      0 ) ) )
129
130(define-inline (check-byte-size loc obj)
131  (unless (memq obj '(1 2 4 8))
132    (error-argument-type loc obj "integer in {1 2 4 8}" 'size) )
133  obj )
134
135(define-inline (check-byte-buffer-size loc dessiz actsiz)
136  (unless (<= dessiz actsiz)
137    ;FIXME this message is too strong
138    (error-half-closed-interval loc actsiz dessiz MAX-BV-LEN "byte-buffer size+start") )
139  actsiz )
140
141(define-type byte-order symbol)
142
143(: byte-order? (* -> boolean : byte-order))
144;
145(define (byte-order? obj)
146  (not (zero? (byte-order->direction obj))) )
147
148(define-check+error-type byte-order byte-order? "symbol in {big-endian be big little-endian le little}")
149
150(define-type buffer-type (or string blob u8vector))
151
152(define-error-type byte-buffer-kind "symbol in {u8vector blob string}")
153(define-error-type byte-buffer "u8vector, blob, string")
154
155(: ensure-byte-buffer (symbol fixnum (or symbol buffer-type) fixnum -> symbol buffer-type))
156;
157(define (ensure-byte-buffer loc size kind start)
158  (check-natural-fixnum loc size 'size)
159  (check-natural-fixnum loc start 'start)
160  (let (
161    (buffer-size (+ start size)) )
162    ;cases ordered by a guess of probability
163    (cond
164      ((symbol? kind)
165        (case kind
166          ((string)
167            (values 'string (make-string buffer-size)) )
168          ((blob)
169            (values 'blob (make-blob buffer-size)) )
170          ((u8vector)
171            (values 'u8vector (make-u8vector buffer-size)) )
172          (else
173            (error-byte-buffer-kind loc kind) ) ) )
174      ((string? kind)
175        (check-byte-buffer-size loc buffer-size (number-of-bytes kind))
176        (values 'string kind) )
177      ((blob? kind)
178        (check-byte-buffer-size loc buffer-size (number-of-bytes kind))
179        (values 'blob kind) )
180      ((u8vector? kind)
181        (check-byte-buffer-size loc buffer-size (u8vector-length kind))
182        (values 'u8vector kind) )
183      (else
184        (error-byte-buffer loc kind) ) ) ) )
185
186;;
187
188(: *pack-u8 (symbol fixnum (or symbol buffer-type) fixnum -> buffer-type))
189;
190(define (*pack-u8 loc n kind start)
191  (check-fixnum loc n)
192  (let-values (
193    ((knd obj) (ensure-byte-buffer loc 1 kind start)) )
194    (case knd
195      ((string)
196        (pack-u8-with-string! obj n start) )
197      ((blob)
198        (pack-u8-with-blob! obj n start) )
199      ((u8vector)
200        (pack-u8-with-u8vector! obj n start) ) )
201    obj ) )
202
203(: pack-u8 (fixnum #!rest -> buffer-type))
204;
205(define (pack-u8 n #!key (kind 'string) (start 0))
206  (*pack-u8 'pack-u8 n kind start) )
207
208;;
209
210(: *pack-integer (symbol integer (or symbol buffer-type) fixnum symbol fixnum -> buffer-type))
211;
212(define (*pack-integer loc n kind size order start)
213  (check-integer loc n)
214  (check-byte-order loc order)
215  (let-values (
216    ((knd obj) (ensure-byte-buffer loc size kind start)) )
217    (let (
218      (direction (byte-order->direction order)) )
219      (case knd
220        ((string)
221          (pack-u64-with-string! obj n size direction start) )
222        ((blob)
223          (pack-u64-with-blob! obj n size direction start) )
224        ((u8vector)
225          (pack-u64-with-u8vector! obj n size direction start) ) ) )
226    obj ) )
227
228;;
229
230(: pack-u16 (fixnum #!rest -> buffer-type))
231;
232(define (pack-u16 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
233  (*pack-integer 'pack-u16 n kind 2 order start) )
234
235;;
236
237(: pack-u32 (integer #!rest -> buffer-type))
238;
239(define (pack-u32 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
240  (*pack-integer 'pack-u32 n kind 4 order start) )
241
242;;
243
244(: pack-u64 (integer #!rest -> buffer-type))
245;
246(define (pack-u64 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
247  (*pack-integer 'pack-u64 n kind 8 order start) )
248
249;;
250
251(: pack-integer (integer #!rest -> buffer-type))
252;
253(define (pack-integer n #!key (kind 'string) (start 0) (order (machine-byte-order)) (size 4))
254  (let (
255    (size (the fixnum (check-byte-size 'pack-integer size))) )
256    (if (= 1 size)
257      (let-values (
258        ((knd obj) (ensure-byte-buffer 'pack-integer size kind start)) )
259        (*blob-set-u8! n obj start) )
260      (*pack-integer 'pack-integer n kind size order start) ) ) )
261
262) ;module pack-integer
Note: See TracBrowser for help on using the repository browser.