basis/endian/endian.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: alien.c-types alien.data byte-arrays combinators
   5 combinators.smart endian kernel math math.ranges sequences
   6 sequences.generalizations ;
   7
   8 USING: alien.c-types alien.data grouping kernel
   9 math.bitwise namespaces sequences ;
  10
  11 IN: endian
  12
  13 SINGLETONS: big-endian little-endian ;
  14
  15 : compute-native-endianness ( -- class )
  16     1 int <ref> char deref 0 = big-endian little-endian ? ; foldable
  17
  18 <PRIVATE
  19
  20 : slow-be> ( seq -- x ) 0 [ [ 8 shift ] dip + ] reduce ;
  21
  22 : slow-le> ( seq -- x ) 0 [ 8 * shift + ] reduce-index ;
  23
  24 ERROR: bad-length bytes n ;
  25
  26 : check-length ( bytes n -- bytes n )
  27     2dup [ length ] dip > [ bad-length ] when ; inline
  28
  29 <<
  30 : be-range ( n -- range )
  31     1 - 8 * 0 -8 <range> ; inline
  32
  33 : le-range ( n -- range )
  34     1 - 8 * 0 swap 8 <range> ; inline
  35
  36 : reassemble-bytes ( range -- quot )
  37     [ [ [ ] ] [ '[ _ shift ] ] if-zero ] map
  38     '[ [ _ spread ] [ bitor ] reduce-outputs ] ; inline
  39
  40 MACRO: reassemble-be ( n -- quot ) be-range reassemble-bytes ;
  41
  42 MACRO: reassemble-le ( n -- quot ) le-range reassemble-bytes ;
  43 >>
  44
  45 :: n-be> ( bytes n -- x )
  46     bytes n check-length drop n firstn-unsafe n reassemble-be ; inline
  47
  48 :: n-le> ( bytes n -- x )
  49     bytes n check-length drop n firstn-unsafe n reassemble-le ; inline
  50
  51 ! HINTS: n-be> { byte-array object } ;
  52 ! HINTS: n-le> { byte-array object } ;
  53
  54 ! { >le >be } [
  55 !     { { fixnum fixnum } { bignum fixnum } }
  56 !     set-specializer
  57 ! ] each
  58
  59 ! { le> be> } [
  60 !     { byte-array } set-specializer
  61 ! ] each
  62
  63 : if-endian ( endian bytes-quot seq-quot -- )
  64     [
  65         compute-native-endianness =
  66         [ dup byte-array? ] [ f ] if
  67     ] 2dip if ; inline
  68
  69 : 2be> ( bytes -- x )
  70     big-endian [ uint16_t deref ] [ 2 n-be> ] if-endian ;
  71
  72 : 4be> ( bytes -- x )
  73     big-endian [ uint32_t deref ] [ 4 n-be> ] if-endian ;
  74
  75 : 8be> ( bytes -- x )
  76     big-endian [ uint64_t deref ] [ 8 n-be> ] if-endian ;
  77
  78 : 2le> ( bytes -- x )
  79     little-endian [ uint16_t deref ] [ 2 n-le> ] if-endian ;
  80
  81 : 4le> ( bytes -- x )
  82     little-endian [ uint32_t deref ] [ 4 n-le> ] if-endian ;
  83
  84 : 8le> ( bytes -- x )
  85     little-endian [ uint64_t deref ] [ 8 n-le> ] if-endian ;
  86
  87 PRIVATE>
  88
  89 : be> ( bytes -- x )
  90     dup length {
  91         { 2 [ 2be> ] }
  92         { 4 [ 4be> ] }
  93         { 8 [ 8be> ] }
  94         [ drop slow-be> ]
  95     } case ;
  96
  97 : le> ( bytes -- x )
  98     dup length {
  99         { 2 [ 2le> ] }
 100         { 4 [ 4le> ] }
 101         { 8 [ 8le> ] }
 102         [ drop slow-le> ]
 103     } case ;
 104
 105 <PRIVATE
 106
 107 : signed> ( x seq -- n )
 108     length 8 * 2dup 1 - bit? [ 2^ - ] [ drop ] if ; inline
 109
 110 : slow-signed-le> ( bytes -- x ) [ le> ] [ signed> ] bi ;
 111
 112 : slow-signed-be> ( bytes -- x ) [ be> ] [ signed> ] bi ;
 113
 114 PRIVATE>
 115
 116 : signed-be> ( bytes -- x )
 117     big-endian [
 118         dup length {
 119             { 2 [ int16_t deref ] }
 120             { 4 [ int32_t deref ] }
 121             { 8 [ int64_t deref ] }
 122             [ drop slow-signed-be> ]
 123         } case
 124     ] [ slow-signed-be> ] if-endian ;
 125
 126 : signed-le> ( bytes -- x )
 127     little-endian [
 128         dup length {
 129             { 2 [ int16_t deref ] }
 130             { 4 [ int32_t deref ] }
 131             { 8 [ int64_t deref ] }
 132             [ drop slow-signed-le> ]
 133         } case
 134     ] [ slow-signed-le> ] if-endian ;
 135
 136 : nth-byte ( x n -- b ) -8 * shift 0xff bitand ; inline
 137
 138 <PRIVATE
 139
 140 : map-bytes ( x seq -- byte-array )
 141     [ nth-byte ] with B{ } map-as ; inline
 142
 143 : >slow-be ( x n -- byte-array ) <iota> <reversed> map-bytes ;
 144
 145 : >slow-le ( x n -- byte-array ) <iota> map-bytes ;
 146
 147 PRIVATE>
 148
 149 : >le ( x n -- bytes )
 150     compute-native-endianness little-endian = [
 151         {
 152             { 2 [ int16_t <ref> ] }
 153             { 4 [ int32_t <ref> ] }
 154             { 8 [ int64_t <ref> ] }
 155             [ >slow-le ]
 156         } case
 157     ] [ >slow-le ] if ;
 158
 159 : >be ( x n -- bytes )
 160     compute-native-endianness big-endian = [
 161         {
 162             { 2 [ int16_t <ref> ] }
 163             { 4 [ int32_t <ref> ] }
 164             { 8 [ int64_t <ref> ] }
 165             [ >slow-be ]
 166         } case
 167     ] [ >slow-be ] if ;
 168
 169 SYMBOL: native-endianness
 170 native-endianness [ compute-native-endianness ] initialize
 171
 172 HOOK: >native-endian native-endianness ( obj n -- bytes )
 173
 174 M: big-endian >native-endian >be ;
 175
 176 M: little-endian >native-endian >le ;
 177
 178 HOOK: unsigned-native-endian> native-endianness ( obj -- bytes )
 179
 180 M: big-endian unsigned-native-endian> be> ;
 181
 182 M: little-endian unsigned-native-endian> le> ;
 183
 184 SYMBOL: endianness
 185 endianness [ native-endianness get-global ] initialize
 186
 187 : signed-native-endian> ( obj n -- n' )
 188     [ unsigned-native-endian> ] dip >signed ;
 189
 190 HOOK: >endian endianness ( obj n -- bytes )
 191
 192 M: big-endian >endian >be ;
 193
 194 M: little-endian >endian >le ;
 195
 196 HOOK: endian> endianness ( seq -- n )
 197
 198 M: big-endian endian> be> ;
 199
 200 M: little-endian endian> le> ;
 201
 202 HOOK: unsigned-endian> endianness ( obj -- bytes )
 203
 204 M: big-endian unsigned-endian> be> ;
 205
 206 M: little-endian unsigned-endian> le> ;
 207
 208 HOOK: signed-endian> endianness ( obj -- bytes )
 209
 210 M: big-endian signed-endian> signed-be> ;
 211
 212 M: little-endian signed-endian> signed-le> ;
 213
 214 : with-endianness ( endian quot -- )
 215     [ endianness ] dip with-variable ; inline
 216
 217 : with-big-endian ( quot -- )
 218     big-endian swap with-endianness ; inline
 219
 220 : with-little-endian ( quot -- )
 221     little-endian swap with-endianness ; inline
 222
 223 : with-native-endian ( quot -- )
 224     \ native-endianness get-global swap with-endianness ; inline
 225
 226 : seq>native-endianness ( seq n -- seq' )
 227     native-endianness get-global dup endianness get = [
 228         2drop
 229     ] [
 230         [ [ <groups> ] keep ] dip
 231         little-endian = [
 232             '[ be> _ >le ] map
 233         ] [
 234             '[ le> _ >be ] map
 235         ] if concat
 236     ] if ; inline
 237