source: project/release/5/blob-utils/trunk/pack-integer.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: 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
82(define-type buffer-type (or string blob u8vector))
83
84(: byte-order? (* -> boolean : byte-order))
85(: ensure-byte-buffer (symbol fixnum (or symbol buffer-type) fixnum -> symbol buffer-type))
86(: *pack-u8 (symbol fixnum (or symbol buffer-type) fixnum -> buffer-type))
87(: pack-u8 (fixnum #!rest -> buffer-type))
88(: *pack-integer (symbol integer (or symbol buffer-type) fixnum symbol fixnum -> buffer-type))
89(: pack-u16 (fixnum #!rest -> buffer-type))
90(: pack-u32 (integer #!rest -> buffer-type))
91(: pack-u64 (integer #!rest -> buffer-type))
92(: pack-integer (integer #!rest -> buffer-type))
93
94;;
95
96; All the below primitive pack routines must return the supplied buffer object.
97
98;; Pack an 8 bit integer
99
100(define-inline (pack-u8-with-u8vector! u8vec n i)
101  (u8vector-set! u8vec i n)
102  u8vec )
103
104(define-inline (pack-u8-with-bytevector! bv n i)
105  (##core#inline "C_setbyte" bv i n) ;(bytevector-set! bv i n)
106  bv )
107
108(define-inline (pack-u8-with-blob! blb n i)
109  (pack-u8-with-bytevector! blb n i) )
110
111(define-inline (pack-u8-with-string! str n i)
112  (pack-u8-with-bytevector! str n i) )
113
114; Pack a 16, 32, or 64 bit integer with endian order
115
116(define-inline (pack-u64-with-u8vector! u8vec n size direction start)
117  ((foreign-lambda void "pack_uint64" nonnull-u8vector unsigned-integer64 int int int)
118     u8vec n size direction start)
119  u8vec )
120
121(define-inline (pack-u64-with-bytevector! bv n size direction start)
122  ((foreign-lambda void "pack_uint64" nonnull-scheme-pointer unsigned-integer64 int int int)
123    bv n size direction start)
124  bv )
125
126(define-inline (pack-u64-with-blob! blb n size direction start)
127  (pack-u64-with-bytevector! blb n size direction start) )
128
129(define-inline (pack-u64-with-string! str n size direction start)
130  (pack-u64-with-bytevector! str n size direction start) )
131
132;;
133
134(define-constant MAX-BV-LEN 16777215) ;2^24-1 is the maximum length of a bytevector
135
136(define-inline (byte-order->direction order)
137  (case order
138    ((big-endian be big)
139      -1 )
140    ((little-endian le little)
141      1 )
142    (else
143      0 ) ) )
144
145(define-inline (check-byte-size loc obj)
146  (unless (memq obj '(1 2 4 8))
147    (error-argument-type loc obj "integer in {1 2 4 8}" 'size) )
148  obj )
149
150(define-inline (check-byte-buffer-size loc dessiz actsiz)
151  (unless (<= dessiz actsiz)
152    ;FIXME this message is too strong
153    (error-half-closed-interval loc actsiz dessiz MAX-BV-LEN "byte-buffer size+start") )
154  actsiz )
155
156(define-type byte-order symbol)
157
158(define (byte-order? obj)
159  (not (zero? (byte-order->direction obj))) )
160
161(define-check+error-type byte-order byte-order? "symbol in {big-endian be big little-endian le little}")
162
163(define-error-type byte-buffer-kind "symbol in {u8vector blob string}")
164(define-error-type byte-buffer "u8vector, blob, string")
165
166(define (ensure-byte-buffer loc size kind start)
167  (check-natural-fixnum loc size 'size)
168  (check-natural-fixnum loc start 'start)
169  (let (
170    (buffer-size (+ start size)) )
171    ;cases ordered by a guess of probability
172    (cond
173      ((symbol? kind)
174        (case kind
175          ((string)
176            (values 'string (make-string buffer-size)) )
177          ((blob)
178            (values 'blob (make-blob buffer-size)) )
179          ((u8vector)
180            (values 'u8vector (make-u8vector buffer-size)) )
181          (else
182            (error-byte-buffer-kind loc kind) ) ) )
183      ((string? kind)
184        (check-byte-buffer-size loc buffer-size (number-of-bytes kind))
185        (values 'string kind) )
186      ((blob? kind)
187        (check-byte-buffer-size loc buffer-size (number-of-bytes kind))
188        (values 'blob kind) )
189      ((u8vector? kind)
190        (check-byte-buffer-size loc buffer-size (u8vector-length kind))
191        (values 'u8vector kind) )
192      (else
193        (error-byte-buffer loc kind) ) ) ) )
194
195;;
196
197(define (*pack-u8 loc n kind start)
198  (check-fixnum loc n)
199  (let-values (
200    ((knd obj) (ensure-byte-buffer loc 1 kind start)) )
201    (case knd
202      ((string)
203        (pack-u8-with-string! obj n start) )
204      ((blob)
205        (pack-u8-with-blob! obj n start) )
206      ((u8vector)
207        (pack-u8-with-u8vector! obj n start) ) )
208    obj ) )
209
210(define (pack-u8 n #!key (kind 'string) (start 0))
211  (*pack-u8 'pack-u8 n kind start) )
212
213;;
214
215(define (*pack-integer loc n kind size order start)
216  (check-integer loc n)
217  (check-byte-order loc order)
218  (let-values (
219    ((knd obj) (ensure-byte-buffer loc size kind start)) )
220    (let (
221      (direction (byte-order->direction order)) )
222      (case knd
223        ((string)
224          (pack-u64-with-string! obj n size direction start) )
225        ((blob)
226          (pack-u64-with-blob! obj n size direction start) )
227        ((u8vector)
228          (pack-u64-with-u8vector! obj n size direction start) ) ) )
229    obj ) )
230
231;;
232
233(define (pack-u16 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
234  (*pack-integer 'pack-u16 n kind 2 order start) )
235
236;;
237
238(define (pack-u32 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
239  (*pack-integer 'pack-u32 n kind 4 order start) )
240
241;;
242
243(define (pack-u64 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
244  (*pack-integer 'pack-u64 n kind 8 order start) )
245
246;;
247
248(define (pack-integer n #!key (kind 'string) (start 0) (order (machine-byte-order)) (size 4))
249  (let (
250    (size (the fixnum (check-byte-size 'pack-integer size))) )
251    (if (= 1 size)
252      (let-values (
253        ((knd obj) (ensure-byte-buffer 'pack-integer size kind start)) )
254        (*blob-set-u8! obj n start) )
255      (*pack-integer 'pack-integer n kind size order start) ) ) )
256
257) ;module pack-integer
Note: See TracBrowser for help on using the repository browser.