UPDATE: rename method

diff --git a/src/byteSerialize.ml b/src/byteSerialize.ml
new file mode 100644 (file)
index 0000000..bb98dd3
--- /dev/null
+++ b/src/byteSerialize.ml
@@ -0,0 +1,155 @@
+open Base
+open Abc
+open Bytes
+
+
+(** create dummy list *)
+let of_list _ = [u30 0]
+
+let array f xs = 
+  let ys = 
+    HList.concat_map f xs in
+    (u30 (List.length xs))::ys
+
+(** encode for cpool *)
+
+let cpool_map f xs = 
+  let ys = 
+    HList.concat_map f xs in
+  let size =
+    1+ List.length xs in
+    (u30 size)::ys
+
+let of_string str =
+  array (fun c -> [u8 (Char.code c)]) @@ ExtString.String.explode str
+
+let of_ns {kind=kind;ns_name=name} =
+  [u8 kind; u30 name]
+
+let of_ns_set =
+  array (fun ns->[u30 ns])
+
+let of_multiname =
+  function 
+      QName (ns,name) ->
+       [u8 0x07;u30 ns; u30 name]
+    | Multiname (name,ns_set) ->
+       [u8 0x09;u30 name; u30 ns_set]
+
+let of_cpool cpool = 
+  List.concat [
+    cpool_map (fun x->[s32 x]) cpool.int;
+    cpool_map (fun x->[u32 x]) cpool.uint;
+    cpool_map (fun x->[d64 x]) cpool.double;
+    cpool_map of_string    cpool.string;
+    cpool_map of_ns        cpool.namespace;
+    cpool_map of_ns_set    cpool.namespace_set;
+    cpool_map of_multiname cpool.multiname;
+  ]
+
+(* tairt *)
+let of_trait_body =
+  function
+    SlotTrait (slot_id,type_name,vindex,vkind) ->
+      if vindex = 0 then
+       [u8 0;u30 slot_id; u30 type_name;u30 0]
+      else
+       [u8 0;u30 slot_id; u30 type_name;u30 vindex;u8 vkind]
+  | MethodTrait (disp_id,meth) ->
+      [u8 1;u30 disp_id; u30 meth]
+  | GetterTrait (disp_id,meth) ->
+      [u8 2;u30 disp_id; u30 meth]
+  | SetterTrait (disp_id,meth) ->
+      [u8 3;u30 disp_id; u30 meth]
+  | ClassTrait  (slot_id,classi) ->
+      [u8 4; u30 slot_id; u30 classi]
+  | FunctionTrait (slot_id,func) ->
+      [u8 5;u30 slot_id; u30 func]
+  | ConstTrait (slot_id,type_name,vindex,vkind) ->
+      if vindex = 0 then
+       [u8 6;u30 slot_id; u30 type_name;u30 0]
+      else
+       [u8 6;u30 slot_id; u30 type_name;u30 vindex;u8 vkind]
+
+let of_trait {t_name=name; data=data} =
+  List.concat [[u30 name];
+              of_trait_body data]
+
+
+(* other *)
+let of_method_info info =
+  List.concat [[u30 (List.length info.params);
+               u30 info.return];
+              List.map u30 info.params;
+              [u30 info.name;
+               u8  info.flags]]
+
+let of_script script =
+  (u30 script.init)::array of_trait script.trait_s
+
+let of_method_body body = 
+  List.concat [
+    [ u30 body.method_sig;
+      u30 body.max_stack;
+      u30 body.local_count;
+      u30 body.init_scope_depth;
+      u30 body.max_scope_depth;
+      block body.code];
+    of_list body.exceptions;
+    array of_trait body.trait_m]
+
+let of_class  {cinit=init; trait_c=traits} =
+  List.concat [
+    [u30 init];
+    array of_trait traits]
+
+let of_instance {name_i      = name;
+                      super_name  = sname;
+                      flags_i     = flags;
+                      interface   = inf;
+                      iinit       = init;
+                      trait_i     = traits} =
+  let flag = function
+      Sealed        -> 0x01 
+    | Final         -> 0x02
+    | Interface     -> 0x04
+    | ProtectedNs _ -> 0x08 in
+  let flags' =
+    List.fold_left (fun x y -> x lor (flag y)) 0 flags in
+  let ns =
+    try
+      match List.find (function ProtectedNs _ -> true | _ -> false) flags with
+         ProtectedNs ns ->
+           [u30 ns]
+       | _ ->
+           failwith "must not happen"
+    with Not_found -> 
+      [] in
+    List.concat [
+      [u30 name;
+       u30 sname;
+       u8  flags'];
+      ns;
+      array (fun x -> [u30 x]) inf;
+      [u30 init];
+      array of_trait traits]
+
+
+let to_bytes { cpool=cpool;
+              method_info=info;
+              metadata=metadata;
+              classes=classes;
+              instances=instances;
+              script=script;
+              method_body=body; } =
+  List.concat [
+    [ u16 16; u16 46; ]; (* version *)
+    of_cpool cpool;
+    array of_method_info info;
+    of_list metadata;
+    (* todo: instances *)
+    array of_instance instances;
+    HList.concat_map of_class classes;
+    array of_script script;
+    array of_method_body body
+  ]

diff --git a/src/byteSerialize.mli b/src/byteSerialize.mli
new file mode 100644 (file)
index 0000000..4fcba38
--- /dev/null
+++ b/src/byteSerialize.mli
@@ -0,0 +1,15 @@
+(**
+   Byte serializer for {!Abc}.
+*)
+val to_bytes : Abc.abc -> Bytes.t list
+
+(**{6 Debug only}*)
+
+val of_cpool : Abc.cpool -> Bytes.t list
+val of_method_info : Abc.method_info -> Bytes.t list
+val of_script : Abc.script -> Bytes.t list
+val of_trait : Abc.trait -> Bytes.t list
+val of_method_body : Abc.method_body -> Bytes.t list
+
+val of_class : Abc.class_info -> Bytes.t list
+val of_instance : Abc.instance_info -> Bytes.t list

diff --git a/test/test_byteserialize.ml b/test/test_byteserialize.ml
new file mode 100644 (file)
index 0000000..35560fe
--- /dev/null
+++ b/test/test_byteserialize.ml
@@ -0,0 +1,161 @@
+open Base
+open Abc
+open Util
+open Bytes
+open ByteSerialize
+
+let cpool =
+  { empty_cpool with 
+      int = [~-1;42];
+      uint = [42];
+      string = ["abc"];
+      namespace = [{kind=0x08; ns_name=1}];
+      namespace_set = [[1;2]];
+      multiname=[QName (0,1);Multiname (2,3)] }
+
+let info =
+  { params=[]; return=1; name=2; flags=3 }
+
+let body =
+  { method_sig=1;
+    max_stack=2;
+    local_count=3;
+    init_scope_depth=4;
+    max_scope_depth=5;
+    code=[u8 1;u8 2;u8 3;s24 1];
+    exceptions=[];
+    trait_m=[] }
+
+let script =
+  {init=0x7F; trait_s=[]}
+
+test script =
+  assert_equal [u30 0x7F; u30 0] @@ of_script script
+
+test trait =
+  assert_equal ([u30 1;u8 0; u30 1; u30 2; u30 3; u8 4; ]) (of_trait {t_name=1; data=SlotTrait (1,2,3,4)});
+  assert_equal ([u30 1;u8 0; u30 1; u30 2; u30 0]) (of_trait {t_name=1; data=SlotTrait (1,2,0,4)});
+  assert_equal ([u30 1;u8 1; u30 1; u30 2]) (of_trait {t_name=1; data=MethodTrait (1,2)});
+  assert_equal ([u30 1;u8 2; u30 1; u30 2]) (of_trait {t_name=1; data=GetterTrait (1,2)});
+  assert_equal ([u30 1;u8 3; u30 1; u30 2]) (of_trait {t_name=1; data=SetterTrait (1,2)});
+  assert_equal ([u30 1;u8 4; u30 1; u30 2]) (of_trait {t_name=1; data=ClassTrait (1,2)});
+  assert_equal ([u30 1;u8 5; u30 1; u30 2]) (of_trait {t_name=1; data=FunctionTrait (1,2)});
+  assert_equal ([u30 1;u8 6; u30 1; u30 2; u30 3; u8 4]) (of_trait {t_name=1; data=ConstTrait (1,2,3,4)});
+  assert_equal ([u30 1;u8 6; u30 1; u30 2; u30 0;]) (of_trait {t_name=1; data=ConstTrait (1,2,0,4)});
+
+test method_info =
+  assert_equal [u30 0; u30 1; u30 2; u8 3] @@ 
+    of_method_info info
+
+test method_body =
+  let expect = [u30 1;
+               u30 2;
+               u30 3;
+               u30 4;
+               u30 5;
+               block [u8 1; u8 2; u8 3;s24 1];
+               u30 0;
+               u30 0] in
+  assert_equal expect @@ of_method_body body
+
+test cpool =
+  assert_equal [u30 1;(* int *)
+               u30 1;(* uint *)
+               u30 1;(* double*)
+               u30 1;(* string *)
+               u30 1;(* ns *)
+               u30 1;(* ns_set *)
+               u30 1 (* mname *)] @@ of_cpool empty_cpool;
+  assert_equal [u30 3; s32 ~-1; s32 42; (* int *)
+               u30 2; u32 42; (* uint *)
+               u30 1;(* double*)
+               u30 2; u30 3; u8 0x61; u8 0x62; u8 0x63; (* string *)
+               u30 2; u8 0x08; u30 1; (* ns *)
+               u30 2; u30 2; u30 1; u30 2; (* ns_set *)
+               u30 3; u8 0x07; u30 0; u30 1; u8 0x09; u30 2; u30 3; (* mname *)] @@ 
+    of_cpool cpool
+
+test of_class =
+  assert_equal [u30 10; u30 0;] @@ of_class {cinit=10; trait_c=[]}
+
+test of_instance =
+  let abc = [
+    u30 1; (* name *)
+    u30 2; (* super name *)
+    u8  3; (* flags *)
+    u30 4; (* interface count *)
+    u30 1; u30 2; u30 3; u30 4; (* interface *)
+    u30 5; (* iinit *)
+    u30 0; (* traits count *) ] in
+  let instance = {
+    name_i=1;
+    super_name=2;
+    flags_i=[Sealed;Final];
+    interface=[1;2;3;4];
+    iinit=5;
+    trait_i=[]} in
+    assert_equal abc (of_instance instance)
+
+test of_instance_protected =
+  let abc = [
+    u30 1; (* name *)
+    u30 2; (* super name *)
+    u8  8; (* flags *)
+    u30 1; (* protected ns *)
+    u30 4; (* interface count *)
+    u30 1; u30 2; u30 3; u30 4; (* interface *)
+    u30 5; (* iinit *)
+    u30 0; (* traits count *) ] in
+  let instance = {
+    name_i=1;
+    super_name=2;
+    flags_i=[ProtectedNs 1];
+    interface=[1;2;3;4];
+    iinit=5;
+    trait_i=[]} in
+    assert_equal abc (of_instance instance)
+
+test of_abc =
+  let abc =
+    {cpool=empty_cpool; method_info=[]; metadata=[]; classes=[]; instances=[]; 
+     script=[]; method_body=[]} in
+    assert_equal [
+      (* version *)
+      u16 16; u16 46;
+      (* cpool *)
+      u30 1; u30 1; u30 1; u30 1; u30 1; u30 1;        u30 1;
+      u30 0; (* info *)
+      u30 0; (* meta *)
+      u30 0; (* class *)
+      u30 0; (* script *)
+      u30 0; (* body *)
+    ] @@ to_bytes abc
+
+test complex_abc = 
+  let abc =
+    {cpool=empty_cpool; method_info=[]; metadata=[]; classes=[]; instances=[]; 
+     script=[]; method_body=[]} in
+  let cpool =
+    {empty_cpool with string=["foo"]; } in
+  let expect = [u30 1;
+               u30 2;
+               u30 3;
+               u30 4;
+               u30 5;
+               block [u8 1; u8 2; u8 3;s24 1];
+               u30 0;
+               u30 0] in
+    assert_equal (List.concat [
+      (* version *)
+      [ u16 16; u16 46];
+      (* cpool *)
+      of_cpool cpool;
+      [u30 1]; of_method_info info; (* info *)
+      [u30 0;  (* meta *) u30 0; (* class *)];
+      [u30 1]; of_script script; (* script *)
+      [u30 1]; expect; (* body *)
+    ]) @@ to_bytes {abc with 
+                     cpool=cpool;
+                     method_info=[info];
+                     method_body=[body];
+                     script=[script]}