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 grouping io.binary kernel
   4 math.bitwise namespaces sequences ;
   5 IN: endian
   6
   7 SINGLETONS: big-endian little-endian ;
   8
   9 : compute-native-endianness ( -- class )
  10     1 int <ref> char deref 0 = big-endian little-endian ? ; foldable
  11
  12 SYMBOL: native-endianness
  13 native-endianness [ compute-native-endianness ] initialize
  14
  15 SYMBOL: endianness
  16 endianness [ native-endianness get-global ] initialize
  17
  18 HOOK: >native-endian native-endianness ( obj n -- bytes )
  19
  20 M: big-endian >native-endian >be ;
  21
  22 M: little-endian >native-endian >le ;
  23
  24 HOOK: unsigned-native-endian> native-endianness ( obj -- bytes )
  25
  26 M: big-endian unsigned-native-endian> be> ;
  27
  28 M: little-endian unsigned-native-endian> le> ;
  29
  30 : signed-native-endian> ( obj n -- n' )
  31     [ unsigned-native-endian> ] dip >signed ;
  32
  33 HOOK: >endian endianness ( obj n -- bytes )
  34
  35 M: big-endian >endian >be ;
  36
  37 M: little-endian >endian >le ;
  38
  39 HOOK: endian> endianness ( seq -- n )
  40
  41 M: big-endian endian> be> ;
  42
  43 M: little-endian endian> le> ;
  44
  45 HOOK: unsigned-endian> endianness ( obj -- bytes )
  46
  47 M: big-endian unsigned-endian> be> ;
  48
  49 M: little-endian unsigned-endian> le> ;
  50
  51 : signed-endian> ( obj n -- bytes )
  52     [ unsigned-endian> ] dip >signed ;
  53
  54 : with-endianness ( endian quot -- )
  55     [ endianness ] dip with-variable ; inline
  56
  57 : with-big-endian ( quot -- )
  58     big-endian swap with-endianness ; inline
  59
  60 : with-little-endian ( quot -- )
  61     little-endian swap with-endianness ; inline
  62
  63 : with-native-endian ( quot -- )
  64     \ native-endianness get-global swap with-endianness ; inline
  65
  66 : seq>native-endianness ( seq n -- seq' )
  67     native-endianness get-global dup endianness get = [
  68         2drop
  69     ] [
  70         [ [ <groups> ] keep ] dip
  71         little-endian = [
  72             '[ be> _ >le ] map
  73         ] [
  74             '[ le> _ >be ] map
  75         ] if concat
  76     ] if ; inline