1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien.c-types alien.data byte-arrays combinators
4 combinators.smart grouping hints kernel math math.bitwise
5 ranges namespaces sequences sequences.generalizations ;
8 SINGLETONS: big-endian little-endian ;
10 : compute-native-endianness ( -- class )
11 1 int <ref> char deref 0 = big-endian little-endian ? ; foldable
15 : slow-be> ( seq -- x ) 0 [ [ 8 shift ] dip + ] reduce ;
17 : slow-le> ( seq -- x ) 0 [ 8 * shift + ] reduce-index ;
19 ERROR: bad-length bytes n ;
21 : check-length ( seq n -- seq n )
22 2dup [ length ] dip > [ bad-length ] when ; inline
25 : be-range ( n -- range )
26 1 - 8 * 0 -8 <range> ; inline
28 : le-range ( n -- range )
29 1 - 8 * 0 swap 8 <range> ; inline
31 : reassemble-bytes ( range -- quot )
32 [ [ [ ] ] [ '[ _ shift ] ] if-zero ] map
33 '[ [ _ spread ] [ bitor ] reduce-outputs ] ; inline
35 MACRO: reassemble-be ( n -- quot ) be-range reassemble-bytes ;
37 MACRO: reassemble-le ( n -- quot ) le-range reassemble-bytes ;
40 :: n-be> ( seq n -- x )
41 seq n check-length drop n firstn-unsafe n reassemble-be ; inline
43 :: n-le> ( seq n -- x )
44 seq n check-length drop n firstn-unsafe n reassemble-le ; inline
46 : if-endian ( endian bytes-quot seq-quot -- )
48 compute-native-endianness =
49 [ dup byte-array? ] [ f ] if
53 big-endian [ uint8_t deref ] [ 1 n-be> ] if-endian ;
56 big-endian [ uint16_t deref ] [ 2 n-be> ] if-endian ;
59 big-endian [ uint32_t deref ] [ 4 n-be> ] if-endian ;
62 big-endian [ uint64_t deref ] [ 8 n-be> ] if-endian ;
65 little-endian [ uint8_t deref ] [ 1 n-le> ] if-endian ;
68 little-endian [ uint16_t deref ] [ 2 n-le> ] if-endian ;
71 little-endian [ uint32_t deref ] [ 4 n-le> ] if-endian ;
74 little-endian [ uint64_t deref ] [ 8 n-le> ] if-endian ;
98 : signed> ( x seq -- n )
99 length 8 * 2dup 1 - bit? [ 2^ - ] [ drop ] if ; inline
101 : slow-signed-le> ( seq -- x ) [ le> ] [ signed> ] bi ;
103 : slow-signed-be> ( seq -- x ) [ be> ] [ signed> ] bi ;
107 : signed-be> ( seq -- x )
110 { 1 [ int8_t deref ] }
111 { 2 [ int16_t deref ] }
112 { 4 [ int32_t deref ] }
113 { 8 [ int64_t deref ] }
114 [ drop slow-signed-be> ]
116 ] [ slow-signed-be> ] if-endian ;
118 : signed-le> ( seq -- x )
121 { 1 [ int8_t deref ] }
122 { 2 [ int16_t deref ] }
123 { 4 [ int32_t deref ] }
124 { 8 [ int64_t deref ] }
125 [ drop slow-signed-le> ]
127 ] [ slow-signed-le> ] if-endian ;
129 : nth-byte ( x n -- b ) -8 * shift 0xff bitand ; inline
133 : map-bytes ( x seq -- byte-array )
134 [ nth-byte ] with B{ } map-as ; inline
136 : >slow-be ( x n -- byte-array ) <iota> <reversed> map-bytes ;
138 : >slow-le ( x n -- byte-array ) <iota> map-bytes ;
142 : >le ( x n -- byte-array )
143 compute-native-endianness little-endian = [
145 { 2 [ int16_t <ref> ] }
146 { 4 [ int32_t <ref> ] }
147 { 8 [ int64_t <ref> ] }
152 : >be ( x n -- byte-array )
153 compute-native-endianness big-endian = [
155 { 2 [ int16_t <ref> ] }
156 { 4 [ int32_t <ref> ] }
157 { 8 [ int64_t <ref> ] }
162 SYMBOL: native-endianness
163 native-endianness [ compute-native-endianness ] initialize
165 HOOK: >native-endian native-endianness ( x n -- byte-array )
167 M: big-endian >native-endian >be ;
169 M: little-endian >native-endian >le ;
171 HOOK: unsigned-native-endian> native-endianness ( x -- byte-array )
173 M: big-endian unsigned-native-endian> be> ;
175 M: little-endian unsigned-native-endian> le> ;
178 endianness [ native-endianness get-global ] initialize
180 : signed-native-endian> ( x n -- byte-array )
181 [ unsigned-native-endian> ] dip >signed ;
183 HOOK: >endian endianness ( x n -- byte-array )
185 M: big-endian >endian >be ;
187 M: little-endian >endian >le ;
189 HOOK: endian> endianness ( seq -- n )
191 M: big-endian endian> be> ;
193 M: little-endian endian> le> ;
195 HOOK: unsigned-endian> endianness ( seq -- n )
197 M: big-endian unsigned-endian> be> ;
199 M: little-endian unsigned-endian> le> ;
201 HOOK: signed-endian> endianness ( seq -- n )
203 M: big-endian signed-endian> signed-be> ;
205 M: little-endian signed-endian> signed-le> ;
207 : with-endianness ( endian quot -- )
208 [ endianness ] dip with-variable ; inline
210 : with-big-endian ( quot -- )
211 big-endian swap with-endianness ; inline
213 : with-little-endian ( quot -- )
214 little-endian swap with-endianness ; inline
216 : with-native-endian ( quot -- )
217 \ native-endianness get-global swap with-endianness ; inline
219 : seq>native-endianness ( seq n -- seq' )
220 native-endianness get-global dup endianness get = [
223 [ [ <groups> ] keep ] dip
231 HINTS: n-be> { byte-array object } ;
232 HINTS: n-le> { byte-array object } ;
235 { { fixnum fixnum } { bignum fixnum } }
240 { byte-array } set-specializer