basis/endian/endian.factor

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