serialize.ml 4.14 KB
Newer Older
1
(*
2 3 4 5 6 7
module Put = struct
  type t = { 
    buf : Buffer.t;
    mutable cur_byte : int; (* 0..255 *)
    mutable cur_bits : int; (* 0..7 *)
  }
8 9 10

  let pos t = t.cur_bits + 8 * Buffer.length t.buf

11 12
  type 'a f = t -> 'a -> unit

13 14 15 16
  type 'b property = (t * 'b) list ref

  let properties = ref []

17 18 19 20 21 22 23 24 25
  let get_property prop t = 
    match !prop with
      | (s,x) :: _ when t == s -> x
      | l ->
	  let x = List.assq t l in
	  prop := (t,x) :: (List.remove_assq t l);
	  x
	    (* Put in front of the list for quick access ... *)

26 27 28 29 30 31 32
  let mk_property init = 
    let prop = ref [] in
    properties := 
    ((fun t -> prop := (t, init t) :: !prop),
     (fun t -> prop := List.remove_assq t !prop)) :: !properties;
    prop

33 34
  let run f x =
    let t = { buf = Buffer.create 1024; cur_byte = 0; cur_bits = 0 } in
35
    List.iter (fun (f,_) -> f t) !properties;
36
    f t x;
37
    List.iter (fun (_,f) -> f t) !properties;
38 39 40 41 42 43 44 45 46 47 48 49
    if t.cur_bits > 0 then Buffer.add_char t.buf (Char.chr t.cur_byte); 
    Buffer.contents t.buf

  let bool t b =
    if b then t.cur_byte <- t.cur_byte lor (1 lsl t.cur_bits);
    if t.cur_bits = 7 then (
      Buffer.add_char t.buf (Char.chr t.cur_byte);
      t.cur_byte <- 0;
      t.cur_bits <- 0
    ) else
      t.cur_bits <- succ t.cur_bits
    
50 51
  let rec bits nb t i = (* TODO: opt *)
    if (nb > 0) then (bool t ((i land 1) <> 0); bits (pred nb) t (i lsr 1))
52 53

  let rec int t i =
54
    bits 4 t i;
55 56 57
    let i = i lsr 4 in
    if i <> 0 then (bool t true; int t i) else (bool t false)

58 59 60
  let substring t s pos len =
    int t len;
    for i = pos to pos + len - 1 do
61
      bits 8 t (Char.code (s.[i]))
62 63
    done

64 65 66
  let string t s =
    substring t s 0 (String.length s)

67 68 69 70 71
  let magic t s =
    for i = 0 to String.length s - 1 do
      bits 8 t (Char.code (s.[i]))
    done

72 73 74 75
  let rec list f t = function
    | [] -> bool t false
    | hd::tl -> bool t true; f t hd; list f t tl

76 77 78 79 80 81
  let array f t a =
    int t (Array.length a);
    for i = 0 to Array.length a - 1 do
      f t a.(i)
    done

82
  let pair f1 f2 t (x,y) = f1 t x; f2 t y
83

84 85 86 87
  let env f1 f2 it t arg =
    it (fun x y -> bool t true; f1 t x; f2 t y) arg;
    bool t false

88 89 90 91 92
end


module Get = struct
  type t = { buf : string; mutable idx : int; mutable idx_bits : int }
93 94 95

  let pos t = t.idx_bits + 8 * t.idx

96 97
  type 'a f = t -> 'a

98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
  type 'b property = (t * 'b) list ref

  let properties = ref []

  let get_property prop t = 
    match !prop with
      | (s,x) :: _ when t == s -> x
      | l ->
	  let x = List.assq t l in
	  prop := (t,x) :: (List.remove_assq t l);
	  x
	    (* Put in front of the list for quick access ... *)

  let mk_property init = 
    let prop = ref [] in
    properties := 
    ((fun t -> prop := (t, init t) :: !prop),
     (fun t -> prop := List.remove_assq t !prop)) :: !properties;
    prop



120
  let run f s =
121 122 123 124 125
    let t = { buf = s; idx = 0; idx_bits = 0 } in
    List.iter (fun (f,_) -> f t) !properties;
    let res = f t in
    List.iter (fun (_,f) -> f t) !properties;
    res
126 127 128 129 130 131 132

  let bool t =
    let b = ((Char.code t.buf.[t.idx]) lsr t.idx_bits) land 1 <> 0 in
    if t.idx_bits = 7 then (t.idx_bits <- 0; t.idx <- succ t.idx)
    else t.idx_bits <- succ t.idx_bits;
    b
    
133
  let rec bits nb t =
134 135
    if nb = 0 then 0 
    else if bool t 
136 137
    then succ (bits (pred nb) t lsl 1)
    else bits (pred nb) t lsl 1
138 139

  let rec int t =
140
    let i = bits 4 t in
141 142 143 144 145 146 147
    if bool t then i + (int t) lsl 4 
    else i

  let string t =
    let l = int t in
    let s = String.create l in
    for i = 0 to l - 1 do
148
      s.[i] <- Char.chr (bits 8 t)
149 150 151
    done;
    s

152 153 154 155 156 157
  let magic t s =
    for i = 0 to String.length s - 1 do
      let c = bits 8 t in
      if (Char.code (s.[i]) != c) then failwith "Invalid magic code."
    done

158 159 160 161
  let rec list f t =
    if bool t then let hd = f t in hd::(list f t)
    else []

162 163 164 165 166 167 168 169 170 171
  let array f t =
    let n = int t in
    if n = 0 then [| |]
    else
      let a = Array.create n (f t) in
      for i = 1 to Array.length a - 1 do
	a.(i) <- f t
      done;
      a

172 173 174 175
  let pair f1 f2 t =
    let x = f1 t in
    let y = f2 t in
    (x,y)
176 177 178 179 180 181 182 183

  let rec env f1 f2 add init t =
    if bool t then
      let x = f1 t in
      let y = f2 t in
      env f1 f2 add (add x y init) t
    else 
      init
184
end
185
*)