1 USING: alien alien.c-types arrays assocs byte-arrays io
2 io.binary io.streams.string kernel math math.parser namespaces
3 parser prettyprint quotations sequences strings vectors words
4 macros math.functions math.bitwise ;
12 : >endian ( obj n -- str )
13 big-endian get [ >be ] [ >le ] if ; inline
15 : endian> ( obj -- str )
16 big-endian get [ be> ] [ le> ] if ; inline
18 GENERIC: b, ( n obj -- )
19 M: integer b, ( m n -- ) >endian % ;
21 ! for doing native, platform-dependent sized values
22 M: string b, ( n string -- ) heap-size b, ;
23 : read-native ( string -- n ) heap-size read endian> ;
28 : s16, ( n -- ) 2 b, ;
29 : u16, ( n -- ) 2 b, ;
30 : s24, ( n -- ) 3 b, ;
31 : u24, ( n -- ) 3 b, ;
32 : s32, ( n -- ) 4 b, ;
33 : u32, ( n -- ) 4 b, ;
34 : s64, ( n -- ) 8 b, ;
35 : u64, ( n -- ) 8 b, ;
36 : s128, ( n -- ) 16 b, ;
37 : u128, ( n -- ) 16 b, ;
38 : float, ( n -- ) float>bits 4 b, ;
39 : double, ( n -- ) double>bits 8 b, ;
40 : c-string, ( str -- ) % 0 u8, ;
44 [ HEX: 7f bitand HEX: 80 bitor , ] keep -7 shift
50 : >128-ber ( n -- str )
52 [ HEX: 7f bitand , ] keep -7 shift
56 : >signed ( x n -- y )
57 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
59 : read-signed ( n -- str )
60 dup read endian> swap 8 * >signed ;
62 : read-unsigned ( n -- m ) read endian> ;
64 : read-s8 ( -- n ) 1 read-signed ;
65 : read-u8 ( -- n ) 1 read-unsigned ;
66 : read-s16 ( -- n ) 2 read-signed ;
67 : read-u16 ( -- n ) 2 read-unsigned ;
68 : read-s24 ( -- n ) 3 read-signed ;
69 : read-u24 ( -- n ) 3 read-unsigned ;
70 : read-s32 ( -- n ) 4 read-signed ;
71 : read-u32 ( -- n ) 4 read-unsigned ;
72 : read-s64 ( -- n ) 8 read-signed ;
73 : read-u64 ( -- n ) 8 read-signed ;
74 : read-s128 ( -- n ) 16 read-signed ;
75 : read-u128 ( -- n ) 16 read-unsigned ;
78 4 read endian> bits>float ;
80 : read-double ( -- n )
81 8 read endian> bits>double ;
83 : read-c-string ( -- str/f )
84 "\0" read-until [ drop f ] unless ;
86 : read-c-string* ( n -- str/f )
87 read [ zero? ] trim-right [ f ] when-empty ;
89 : (read-128-ber) ( n -- n )
91 [ >r 7 shift r> 7 clear-bit bitor ] keep
92 7 bit? [ (read-128-ber) ] when ;
94 : read-128-ber ( -- n )
97 : pack-table ( -- hash )
115 : unpack-table ( -- hash )
127 { CHAR: f read-float }
128 { CHAR: F read-float }
129 { CHAR: d read-double }
130 { CHAR: D read-double }
133 MACRO: (pack) ( seq str -- quot )
137 swap , pack-table at ,
139 ] [ ] make 1quotation %
143 : pack-native ( seq str -- seq )
145 big-endian? big-endian set (pack)
148 : pack-be ( seq str -- seq )
149 [ big-endian on (pack) ] with-scope ;
151 : pack-le ( seq str -- seq )
152 [ big-endian off (pack) ] with-scope ;
155 MACRO: (unpack) ( str -- quot )
158 [ unpack-table at , \ , , ] each
160 1quotation [ { } make ] append
162 \ with-string-reader ,
165 : unpack-native ( seq str -- seq )
167 big-endian? big-endian set (unpack)
170 : unpack-be ( seq str -- seq )
171 [ big-endian on (unpack) ] with-scope ;
173 : unpack-le ( seq str -- seq )
174 [ big-endian off (unpack) ] with-scope ;