swflib/bytesOut.ml

   1 open Base
   2 exception Out_of_range
   3
   4 type address = int
   5 type map = (Label.t * address) list
   6
   7 type base = [
   8   `U8  of int
   9 | `U16 of int
  10 | `S24 of int
  11 | `U30 of int32
  12 | `U32 of int32
  13 | `S32 of int32
  14 | `D64 of float ]
  15
  16 type label = [
  17 | `Backpatch   of int * (address -> map -> int list) (* (size,fun current_address map -> [...]) *)
  18 | `Label of Label.t ]
  19
  20 type t = [ base | label ]
  21
  22 let u8 n =
  23   if 0 <=n && n <= 0xFF then
  24     `U8 n
  25   else
  26     raise Out_of_range
  27
  28 let u16 n =
  29   if 0 <= n && n <= 0xFFFF then
  30     `U16 n
  31       else
  32     raise Out_of_range
  33
  34 let u30 n =
  35   `U30 (Int32.of_int n)
  36 let u32 n =
  37   `U30 (Int32.of_int n)
  38 let s32 n =
  39   `S32 (Int32.of_int n)
  40 let s24 n =
  41   `S24 n
  42 let d64 f =
  43   `D64 f
  44
  45 let label x =
  46   `Label x
  47
  48 let backpatch size f =
  49   `Backpatch (size,f)
  50
  51 (** encode "base" to bytes *)
  52 let (&/) = Int32.logand
  53 let (|/) = Int32.logor
  54 let (>>) = Int32.shift_right_logical
  55
  56 let split_byte nth value size =
  57   List.map (fun i-> nth value (i*8)) @@ range 0 size
  58
  59 let split_byte_int =
  60   split_byte (fun n i-> (n lsr i) land 0xFF)
  61
  62 let split_byte_int64 value size =
  63   List.map Int64.to_int @@
  64     split_byte
  65        (fun n i->(Int64.logand (Int64.shift_right_logical n i) 0xFFL))
  66        value size
  67
  68 let rec of_base : base -> int list =
  69   function
  70       `U8  x ->
  71         split_byte_int x 1
  72     | `U16 x ->
  73         split_byte_int x 2
  74     | `S24 x ->
  75         split_byte_int x 3
  76     | `D64 f ->
  77         split_byte_int64 (Int64.bits_of_float f) 8
  78     | `U30 x | `U32 x | `S32 x ->
  79         if x = 0l then
  80           [0]
  81         else
  82           unfold
  83             (fun x ->
  84                if x = 0l then
  85                  None
  86                else if 0l < x && x <= 0x7Fl then
  87                  Some (Int32.to_int (x &/ 0x7Fl),0l)
  88                else
  89                  let next =
  90                    x >> 7 in
  91                  let current =
  92                    Int32.to_int ((x &/ 0x7Fl) |/ 0x80l) in
  93                    Some (current,next)) x
  94
  95 let rec of_label addr map =
  96   function
  97       [] ->
  98         (fun _ -> []),map
  99     | `Label t::xs ->
 100         let f,map' =
 101           of_label addr ((t,addr)::map) xs in
 102           f,map'
 103     | `Backpatch (size, patch)::xs ->
 104         let f,map' =
 105           of_label (addr+size) map xs in
 106           (fun m -> patch addr m @ f m),map'
 107     | #base as base::xs ->
 108         let bytes =
 109           of_base base in
 110         let f,map' =
 111           of_label (addr + List.length bytes) map xs in
 112           (fun m -> bytes @ f m),map'
 113
 114 let find : map -> Label.t -> address  = flip List.assoc
 115
 116 let label_ref label =
 117   backpatch 3 (fun addr m -> of_base @@ `S24 (find m label - (addr + 3)))
 118
 119 let to_int_list xs =
 120   let f,map =
 121     of_label 0 [] xs in
 122     f map
 123
 124 let rec output_bytes ch bytes =
 125   bytes
 126   +> to_int_list
 127   +> List.iter (output_byte ch)