basis/pack/pack.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types ascii assocs combinators combinators.smart
   4 endian fry io kernel macros math math.statistics math.vectors
   5 sequences strings ;
   6 IN: pack
   7
   8 GENERIC: >n-byte-array ( obj n -- byte-array )
   9
  10 M: integer >n-byte-array ( m n -- byte-array ) >endian ;
  11
  12 ! for doing native, platform-dependent sized values
  13 M: string >n-byte-array ( n string -- byte-array ) heap-size >n-byte-array ;
  14
  15 : s8>byte-array ( n -- byte-array ) 1 >n-byte-array ;
  16 : u8>byte-array ( n -- byte-array ) 1 >n-byte-array ;
  17 : s16>byte-array ( n -- byte-array ) 2 >n-byte-array ;
  18 : u16>byte-array ( n -- byte-array ) 2 >n-byte-array ;
  19 : s24>byte-array ( n -- byte-array ) 3 >n-byte-array ;
  20 : u24>byte-array ( n -- byte-array ) 3 >n-byte-array ;
  21 : s32>byte-array ( n -- byte-array ) 4 >n-byte-array ;
  22 : u32>byte-array ( n -- byte-array ) 4 >n-byte-array ;
  23 : s64>byte-array ( n -- byte-array ) 8 >n-byte-array ;
  24 : u64>byte-array ( n -- byte-array ) 8 >n-byte-array ;
  25 : s128>byte-array ( n -- byte-array ) 16 >n-byte-array ;
  26 : u128>byte-array ( n -- byte-array ) 16 >n-byte-array ;
  27 : write-float ( n -- byte-array ) float>bits 4 >n-byte-array ;
  28 : write-double ( n -- byte-array ) double>bits 8 >n-byte-array ;
  29 : write-c-string ( byte-array -- byte-array ) { 0 } B{ } append-as ;
  30
  31 <PRIVATE
  32
  33 : expand-pack-format ( str -- str' )
  34     f swap [
  35         dup digit?
  36         [ [ 0 or 10 * ] [ CHAR: 0 - ] bi* + f ]
  37         [ [ 1 or ] [ <string> ] bi* f swap ] if
  38     ] { } map-as "" concat-as nip ; foldable
  39
  40 CONSTANT: pack-table
  41     H{
  42         { CHAR: c s8>byte-array }
  43         { CHAR: C u8>byte-array }
  44         { CHAR: s s16>byte-array }
  45         { CHAR: S u16>byte-array }
  46         { CHAR: t s24>byte-array }
  47         { CHAR: T u24>byte-array }
  48         { CHAR: i s32>byte-array }
  49         { CHAR: I u32>byte-array }
  50         { CHAR: q s64>byte-array }
  51         { CHAR: Q u64>byte-array }
  52         { CHAR: f write-float }
  53         { CHAR: F write-float }
  54         { CHAR: d write-double }
  55         { CHAR: D write-double }
  56     }
  57
  58 CONSTANT: unpack-table
  59     H{
  60         { CHAR: c [ 8 signed-endian> ] }
  61         { CHAR: C [ unsigned-endian> ] }
  62         { CHAR: s [ 16 signed-endian> ] }
  63         { CHAR: S [ unsigned-endian> ] }
  64         { CHAR: t [ 24 signed-endian> ] }
  65         { CHAR: T [ unsigned-endian> ] }
  66         { CHAR: i [ 32 signed-endian> ] }
  67         { CHAR: I [ unsigned-endian> ] }
  68         { CHAR: q [ 64 signed-endian> ] }
  69         { CHAR: Q [ unsigned-endian> ] }
  70         { CHAR: f [ unsigned-endian> bits>float ] }
  71         { CHAR: F [ unsigned-endian> bits>float ] }
  72         { CHAR: d [ unsigned-endian> bits>double ] }
  73         { CHAR: D [ unsigned-endian> bits>double ] }
  74     }
  75
  76 CONSTANT: packed-length-table
  77     H{
  78         { CHAR: c 1 }
  79         { CHAR: C 1 }
  80         { CHAR: s 2 }
  81         { CHAR: S 2 }
  82         { CHAR: t 3 }
  83         { CHAR: T 3 }
  84         { CHAR: i 4 }
  85         { CHAR: I 4 }
  86         { CHAR: q 8 }
  87         { CHAR: Q 8 }
  88         { CHAR: f 4 }
  89         { CHAR: F 4 }
  90         { CHAR: d 8 }
  91         { CHAR: D 8 }
  92     }
  93
  94 PRIVATE>
  95
  96 MACRO: pack ( str -- quot )
  97     expand-pack-format
  98     [ pack-table at '[ _ execute ] ] { } map-as
  99     '[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ;
 100
 101 : ch>packed-length ( ch -- n )
 102     packed-length-table at ; inline
 103
 104 : packed-length ( str -- n )
 105     [ ch>packed-length ] map-sum ;
 106
 107 : pack-native ( seq str -- seq )
 108     '[ _ _ pack ] with-native-endian ; inline
 109
 110 : pack-be ( seq str -- seq )
 111     '[ _ _ pack ] with-big-endian ; inline
 112
 113 : pack-le ( seq str -- seq )
 114     '[ _ _ pack ] with-little-endian ; inline
 115
 116 <PRIVATE
 117
 118 : start/end ( seq -- seq1 seq2 )
 119     [ cum-sum0 dup ] keep v+ ; inline
 120
 121 PRIVATE>
 122
 123 MACRO: unpack ( str -- quot )
 124     expand-pack-format
 125     [ [ ch>packed-length ] { } map-as start/end ]
 126     [ [ unpack-table at '[ @ ] ] { } map-as ] bi
 127     [ '[ [ _ _ ] dip <slice> @ ] ] 3map
 128     '[ [ _ cleave ] output>array ] ;
 129
 130 : unpack-native ( seq str -- seq )
 131     '[ _ _ unpack ] with-native-endian ; inline
 132
 133 : unpack-be ( seq str -- seq )
 134     '[ _ _ unpack ] with-big-endian ; inline
 135
 136 : unpack-le ( seq str -- seq )
 137     '[ _ _ unpack ] with-little-endian ; inline
 138
 139 ERROR: packed-read-fail str bytes ;
 140
 141 <PRIVATE
 142
 143 : read-packed-bytes ( str -- bytes )
 144     dup packed-length [ read dup length ] keep =
 145     [ nip ] [ packed-read-fail ] if ; inline
 146
 147 PRIVATE>
 148
 149 : read-packed ( str quot -- seq )
 150     [ read-packed-bytes ] swap bi ; inline
 151
 152 : read-packed-le ( str -- seq )
 153     [ unpack-le ] read-packed ; inline
 154
 155 : read-packed-be ( str -- seq )
 156     [ unpack-be ] read-packed ; inline
 157
 158 : read-packed-native ( str -- seq )
 159     [ unpack-native ] read-packed ; inline