basis/pack/pack.factor

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