gen_typemap
lowInst.ml
highInst.ml
-*.h
\ No newline at end of file
+*.h
+tagOut.ml
\ No newline at end of file
| `RGBA of int * int * int * int
]
+type s = [ byte | compose ]
+
type backpatch = [
`Ui32Size
+| `Size of (int -> s list) * s list
]
-type t = [ byte | compose | backpatch ]
+type t = [ s | backpatch ]
let rec g_si mask shift n value =
unfold begin fun (n,value) ->
List.fold_left ~f:bits ~init:BitsOut.empty xs
+> BitsOut.to_list
-let to_byte = function
+let to_byte : compose -> byte list = function
`Fixed x ->
let int =
floor x in
| `RGBA(r,g,b,a) ->
[`Ui8 r; `Ui8 g; `Ui8 b; `Ui8 a]
-let backpatch xs =
+let int_of_compose x =
+ match x with
+ #compose as c -> HList.concat_map to_int @@ to_byte c
+ | #byte as b -> to_int b
+
+let backpatch (xs : [byte | backpatch] list) : int list =
let (f,size) =
List.fold_right xs ~init:(const [],0) ~f:begin fun x (f,size) ->
match x with
(* same as Ui30 *)
size + 4 in
((fun size -> to_int (`Ui32 (Int32.of_int size)) @ f size), size')
+ | `Size(g, xs) ->
+ let ints =
+ HList.concat_map int_of_compose xs in
+ let size' =
+ size + List.length ints in
+ let i =
+ HList.concat_map int_of_compose @@ g size' in
+ ((fun ctx -> i @ ints @ f ctx), List.length i + size')
end in
f size
-let rec to_list (xs : t list) =
+let rec to_list xs =
xs
+> HList.concat_map begin function
#byte as b -> [b]
- | #compose as c -> to_byte c
+ | #compose as c -> (to_byte c :> [ byte | backpatch] list )
| #backpatch as bp -> [bp]
end
+> backpatch
SB of int * int
| UB of int * int
-type t = [
+type s = [
`Si8 of int
| `Si16 of int
| `Si24 of int
| `Ui24 of int
| `Ui32 of int32
| `Ui64 of int64
+| `EUi32 of int32
+| `Bits of bit list
| `Fixed of float
| `Fixed8 of float
| `Float32 of float
| `Float64 of float
-| `EUi32 of int32
-| `Bits of bit list
| `Rect of int*int*int*int
| `RGB of int * int * int
| `RGBA of int * int * int * int
+]
+
+type backpatch = [
| `Ui32Size
+| `Size of (int -> s list) * s list
]
+type t = [ s | backpatch ]
+
val to_list : t list -> int list
ok_b [ `Bits [UB(5,2); SB(2,0); SB(2,0); SB(2,1); SB(2,1)]] @@ [`Rect (0,0,1,1)];
ok_b [ `Bits [UB(5,11); SB(11,127); SB(11,260); SB(11,15); SB(11,514)]] @@ [`Rect (127,260,15,514)]
end;
- "size" >:: begin fun () ->
+ "whole size" >:: begin fun () ->
ok_b [`Ui32 4l] [`Ui32Size];
ok_b [`Ui32 6l; `EUi32 0xFFl] [`Ui32Size; `EUi32 0xFFl;];
end;
+ "size" >:: begin fun () ->
+ ok_b [`Ui8 2; `Ui8 0; `Ui8 0] [`Size ((fun n -> [`Ui8 n]),[`Ui8 0; `Ui8 0])];
+ ok_b [`Ui32 6l; `Ui8 0; `Ui8 0] [`Ui32Size; `Size ((fun _ -> [`Ui8 0;`Ui8 0]),[])]
+ end;
"rgb" >:: begin fun () ->
ok_b [`Ui8 1; `Ui8 2; `Ui8 3] [`RGB (1,2,3)];
ok_b [`Ui8 1; `Ui8 2; `Ui8 3; `Ui8 4] [`RGBA (1,2,3,4)]
module type TagType = sig
type t
- val to_base : t -> int * SwfBaseOut.t list
+ val to_base : t -> int * SwfBaseOut.s list
end
module Make(Tag : TagType) = struct
let of_tag tag =
let make_type t size =
- `Ui16 ((t lsl 6) lor size) in
- let tag,data' =
- Tag.to_base tag in
- let size =
- List.length @@ SwfBaseOut.to_list data' in
if size < 0x3F then
- make_type tag size :: data'
+ [`Ui16 ((t lsl 6) lor size)]
else
- make_type tag 0x3F :: `Si32 (Int32.of_int size) :: data'
+ [`Ui16 ((t lsl 6) lor 0x3F); `Si32 (Int32.of_int size)] in
+ let t,data' =
+ Tag.to_base tag in
+ [`Size(make_type t, data')]
- let to_base t = [
+ let to_base t : SwfBaseOut.t list = [
(* signature *)
char 'F'; char 'W'; char 'S';
(* version *)
module type TagType = sig
type t
- val to_base : t -> int * SwfBaseOut.t list
+ val to_base : t -> int * SwfBaseOut.s list
end
open OUnit
module M = SwfOut.Make(struct
- type t = int * SwfBaseOut.t list
+ type t = int * SwfBaseOut.s list
let to_base x = x
end)
open M
let ok ?msg f x y =
assert_equal ?msg y (f x)
+let ok_b ?msg f x y =
+ assert_equal ?msg (SwfBaseOut.to_list y) (SwfBaseOut.to_list (f x))
+
let _ = begin "swfOut.ml" >::: [
"header" >:: begin fun () ->
let swf = {
]
end;
"tag" >:: begin fun () ->
- ok ~msg:"size < 64" of_tag (1, [`Ui8 1;`Ui8 2; `Ui8 3])
+ ok_b ~msg:"size < 64" of_tag (1, [`Ui8 1;`Ui8 2; `Ui8 3])
[ `Ui16 0b0000000001_000011; `Ui8 1; `Ui8 2; `Ui8 3 ];
(* size >= 64*)
- ok ~msg:"size > 64" of_tag (1, HList.replicate 64 (`Ui8 1)) @@
+ ok_b ~msg:"size > 64" of_tag (1, HList.replicate 64 (`Ui8 1)) @@
[ `Ui16 0b0000000001_111111; `Si32 64l ] @ HList.replicate 64 (`Ui8 1)
end
] end +> run_test_tt_main