extra/pack/pack.factor

   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 ;
   5 IN: pack
   6
   7 SYMBOL: big-endian
   8
   9 : big-endian? ( -- ? )
  10     1 <int> *char zero? ;
  11
  12 : >endian ( obj n -- str )
  13     big-endian get [ >be ] [ >le ] if ; inline
  14
  15 : endian> ( obj -- str )
  16     big-endian get [ be> ] [ le> ] if ; inline
  17
  18 GENERIC: b, ( n obj -- )
  19 M: integer b, ( m n -- ) >endian % ;
  20
  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> ;
  24
  25 ! Portable
  26 : s8, ( n -- ) 1 b, ;
  27 : u8, ( n -- ) 1 b, ;
  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, ;
  41
  42 : (>128-ber) ( n -- )
  43     dup 0 > [
  44         [ HEX: 7f bitand HEX: 80 bitor , ] keep -7 shift
  45         (>128-ber)
  46     ] [
  47         drop
  48     ] if ;
  49
  50 : >128-ber ( n -- str )
  51     [
  52         [ HEX: 7f bitand , ] keep -7 shift
  53         (>128-ber)
  54     ] { } make reverse ;
  55
  56 : >signed ( x n -- y )
  57     2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
  58
  59 : read-signed ( n -- str )
  60     dup read endian> swap 8 * >signed ;
  61
  62 : read-unsigned ( n -- m ) read endian> ;
  63
  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 ;
  76
  77 : read-float ( -- n )
  78     4 read endian> bits>float ;
  79
  80 : read-double ( -- n )
  81     8 read endian> bits>double ;
  82
  83 : read-c-string ( -- str/f )
  84     "\0" read-until [ drop f ] unless ;
  85
  86 : read-c-string* ( n -- str/f )
  87     read [ zero? ] trim-right dup empty? [ drop f ] when ;
  88
  89 : (read-128-ber) ( n -- n )
  90     read1
  91     [ >r 7 shift r> 7 clear-bit bitor ] keep
  92     7 bit? [ (read-128-ber) ] when ;
  93
  94 : read-128-ber ( -- n )
  95     0 (read-128-ber) ;
  96
  97 : pack-table ( -- hash )
  98     H{
  99         { CHAR: c s8, }
 100         { CHAR: C u8, }
 101         { CHAR: s s16, }
 102         { CHAR: S u16, }
 103         { CHAR: t s24, }
 104         { CHAR: T u24, }
 105         { CHAR: i s32, }
 106         { CHAR: I u32, }
 107         { CHAR: q s64, }
 108         { CHAR: Q u64, }
 109         { CHAR: f float, }
 110         { CHAR: F float, }
 111         { CHAR: d double, }
 112         { CHAR: D double, }
 113     } ;
 114
 115 : unpack-table ( -- hash )
 116     H{
 117         { CHAR: c read-s8 }
 118         { CHAR: C read-u8 }
 119         { CHAR: s read-s16 }
 120         { CHAR: S read-u16 }
 121         { CHAR: t read-s24 }
 122         { CHAR: T read-u24 }
 123         { CHAR: i read-s32 }
 124         { CHAR: I read-u32 }
 125         { CHAR: q read-s64 }
 126         { CHAR: Q read-u64 }
 127         { CHAR: f read-float }
 128         { CHAR: F read-float }
 129         { CHAR: d read-double }
 130         { CHAR: D read-double }
 131     } ;
 132
 133 MACRO: (pack) ( seq str -- quot )
 134     [
 135         [
 136             [
 137                 swap , pack-table at ,
 138             ] 2each
 139         ] [ ] make 1quotation %
 140        [ B{ } make ] %
 141     ] [ ] make ;
 142
 143 : pack-native ( seq str -- seq )
 144     [
 145         big-endian? big-endian set (pack)
 146     ] with-scope ;
 147
 148 : pack-be ( seq str -- seq )
 149     [ big-endian on (pack) ] with-scope ;
 150
 151 : pack-le ( seq str -- seq )
 152     [ big-endian off (pack) ] with-scope ;
 153
 154
 155 MACRO: (unpack) ( str -- quot )
 156     [
 157         [
 158             [ unpack-table at , \ , , ] each
 159         ] [ ] make
 160         1quotation [ { } make ] append
 161         1quotation %
 162         \ with-string-reader ,
 163     ] [ ] make ;
 164
 165 : unpack-native ( seq str -- seq )
 166     [
 167         big-endian? big-endian set (unpack)
 168     ] with-scope ;
 169
 170 : unpack-be ( seq str -- seq )
 171     [ big-endian on (unpack) ] with-scope ;
 172
 173 : unpack-le ( seq str -- seq )
 174     [ big-endian off (unpack) ] with-scope ;