+++ /dev/null
-open Base
-
-module type Writer = sig
- type t
- val write : t -> Bytes.t list
-end
-
-module Make(Writer : Writer) = struct
- open Bytes
- open AbcType
-
- let dummy _ = [u30 0]
-
- let array f xs =
- let ys =
- HList.concat_map f xs in
- (u30 (List.length xs))::ys
-
- (* Constant Pool *)
- let empty_cpool =
- { int=[]; uint=[]; double=[]; string=[]; namespace=[]; namespace_set=[]; multiname=[]}
-
- 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;namespace_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;
- ]
-
- (* Trait *)
- let of_trait_attrs attrs =
- let of_attr attr = List.assoc attr [ATTR_Final ,0x01;
- ATTR_Override,0x02;
- ATTR_Medadata,0x04] in
- List.fold_left (lor) 0 @@ List.map of_attr attrs
-
- (* kind field contains two four-bit fields. The lower four bits determine the kind of this trait.
- The upper four bits comprise a bit vector providing attributes of the trait. *)
- let kind attr kind =
- u8 @@ ((of_trait_attrs attr) lsl 4) lor kind
-
- 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,attrs) ->
- [kind attrs 1;u30 disp_id; u30 meth]
- | GetterTrait (disp_id,meth,attrs) ->
- [kind attrs 2;u30 disp_id; u30 meth]
- | SetterTrait (disp_id,meth,attrs) ->
- [kind attrs 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 {trait_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.method_name;
- u8 info.method_flags]]
-
- let of_script {init=init; script_traits=traits} =
- (u30 init)::array of_trait traits
-
- let of_method_body body =
- let t =
- Label.make () in
- List.concat [
- [ u30 body.method_sig;
- u30 body.max_stack;
- u30 body.local_count;
- u30 body.init_scope_depth;
- u30 body.max_scope_depth];
- [backpatch 0 (fun addr map -> to_int_list [u30 (find map t - addr)])];
- body.code;
- [label t];
- dummy body.exceptions;
- array of_trait body.method_traits]
-
- let of_class {cinit=init; class_traits=traits} =
- List.concat [
- [u30 init];
- array of_trait traits]
-
- let of_instance {instance_name = name;
- super_name = sname;
- instance_flags = flags;
- interface = inf;
- iinit = init;
- instance_traits = 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 =
- flags
- +> HList.concat_map begin function
- ProtectedNs ns -> [u30 ns]
- | Sealed | Final | Interface -> []
- end
- +> function [] -> [] | x::_ -> [x] 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;
- scripts=scripts;
- method_bodies=bodies; } =
- List.concat [
- [ u16 16; u16 46; ];
- of_cpool cpool;
- array of_method_info info;
- dummy metadata;
- array of_instance instances;
- HList.concat_map of_class classes;
- array of_script scripts;
- array of_method_body bodies
- ]
-end
open Base
+open AbcType
open OUnit
-open ISpec
-open Asm
open Bytes
-(* start prefix *)
-let test_cases = ref []
-let test name body =
- test_cases := (name >:: body)::!test_cases;;
+module A = Asm.Make(struct
+ type t = int
+ let to_bytes _ = []
+ end)
+open A
+
+let cpool =
+ { empty_cpool with
+ int = [~-1;42];
+ uint = [42];
+ string = ["abc"];
+ namespace = [{kind=0x08; namespace_name=1}];
+ namespace_set = [[1;2]];
+ multiname=[QName (0,1);Multiname (2,3)] }
+
+let info =
+ { params=[]; return=1; method_name=2; method_flags=3 }
+
+let body =
+ { method_sig=1;
+ max_stack=2;
+ local_count=3;
+ init_scope_depth=4;
+ max_scope_depth=5;
+ code=[];
+ exceptions=[];
+ method_traits=[] }
+
+let script =
+ {init=0x7F; script_traits=[]}
+
+let ok x y =
+ OUnit.assert_equal ~printer:(Std.dump) (to_int_list x) (to_int_list y)
-let ok =
- OUnit.assert_equal
-
-(* test util *)
-let empty_method =
-{ ISpec.method_attrs = [];
- method_name = `QName (`Namespace "","");
- params = [];
- return = 0;
- method_flags = 0;
- instructions = [];
- traits = [];
- exceptions = [];
- fun_scope = `Global
-}
-
-let insts insts =
- {empty_method with instructions=insts}
-
-(* stub module *)
-module Inst = struct
- type t =
- [ `OpOnly1 | `OpOnly2
- | `OpOnly3 | `OpOnly4
- | `WithArgs | `WithPrefix
- | `String | `Int
- | `StackAdd | `StackDel
- | `ScopeAdd | `ScopeDel
- | `Meth
- | `Class ]
-
- let default : t ISpec.t = {
- op=0;
- args=const [];
- prefix=const [];
- const=[];
- method_ = None;
- class_ = None;
- stack=0;
- scope=0;
- count=0;
- }
-
- let spec =
- function
- `OpOnly1 ->
- {default with op=101}
- | `OpOnly2 ->
- {default with op=102}
- | `OpOnly3 ->
- {default with op=103}
- | `OpOnly4 ->
- {default with op=104}
- | `WithArgs ->
- {default with args=const [u8 1]}
- | `WithPrefix ->
- {default with prefix=const [u8 2]}
- | `String ->
- {default with const=[`String "foo"]}
- | `Int ->
- {default with const=[`Int 42]}
- | `StackAdd ->
- {default with stack=1}
- | `StackDel ->
- {default with stack= -1}
- | `ScopeAdd ->
- {default with scope=1}
- | `ScopeDel ->
- {default with scope= -1}
- | `Meth ->
- {default with method_ =
- Some {(insts [`OpOnly1]) with
- method_name = `QName (`Namespace "","f")}}
- | `Class ->
- {default with class_ = Some {
- class_name = `QName (`Namespace "","Foo");
- super = `QName (`Namespace "","Object");
- class_flags= [`Sealed];
- cinit = insts [`OpOnly1];
- iinit = insts [`OpOnly2];
- interface = [];
- instance_methods = [insts [`OpOnly3]];
- static_methods = [insts [`OpOnly4]];
- attributes = [];
- }
- }
-end
-
-module A = Asm.Make(Inst)
-
-let _ = test "Instruction" begin
- fun () ->
- let {method_info=mi;
- method_body=mb} =
- A.assemble_method @@ insts [`OpOnly1; `OpOnly2] in
- ok 1 @@ List.length mi;
- ok 1 @@ List.length mb;
- ok 0 @@ (List.hd mb).Abc.method_sig;
- ok [u8 101; u8 102] @@ (List.hd mb).Abc.code
-end
-
-let _ = test "args/prefix" begin
- fun () ->
- let {method_info=mi;
- method_body=mb} =
- A.assemble_method @@ insts [`WithArgs; `WithPrefix] in
- ok 1 @@ List.length mi;
- ok 1 @@ List.length mb;
- ok 0 @@ (List.hd mb).Abc.method_sig;
- ok [u8 0; u8 1;
- u8 2; u8 0] @@ (List.hd mb).Abc.code
-end
-
-let _ = test "constant" begin
- fun () ->
- let {cpool=cpool} =
- A.assemble_method @@ insts [`String; `Int; `Meth] in
- let cpool' =
- List.fold_left (flip Cpool.add) Cpool.empty [
- `String "foo";
- `Int 42;
- `QName (`Namespace "","f");
- `QName (`Namespace "","");
- ] in
- ok cpool' cpool
-end
-
-let _ = test "stack" begin
- fun () ->
- let {method_info=mi;
- method_body=mb} =
- A.assemble_method @@ insts [`StackAdd; `StackAdd; `StackDel] in
- ok 1 @@ List.length mi;
- ok 1 @@ List.length mb;
- ok 2 @@ (List.hd mb).Abc.max_stack;
-end
-
-let _ = test "scope" begin
- fun () ->
- let {method_info=mi;
- method_body=mb} =
- A.assemble_method @@ insts [`ScopeAdd; `ScopeAdd; `ScopeDel] in
- ok 1 @@ List.length mi;
- ok 1 @@ List.length mb;
- ok 2 @@ (List.hd mb).Abc.max_scope_depth;
- ok 0 @@ (List.hd mb).Abc.init_scope_depth
-end
-
-let _ = test "method" begin
- fun () ->
- let {method_info=mi;
- method_body=mb} =
- A.assemble_method @@ insts [`Meth] in
- ok 2 @@ List.length mi;
- ok 2 @@ List.length mb;
- ok 0 @@ (List.nth mb 0).Abc.method_sig;
- ok 1 @@ (List.nth mb 1).Abc.method_sig;
- ok [u8 101] @@ (List.nth mb 0).Abc.code;
- ok [u8 0] @@ (List.nth mb 1).Abc.code;
-end
-
-let _ = test "method dup" begin
- (* same method should NOT be unified for AVM2 restriction *)
- fun () ->
- let {method_info=mi;
- method_body=mb} =
- A.assemble_method @@ insts [`Meth; `Meth] in
- ok 3 @@ List.length mi;
- ok 3 @@ List.length mb
-end
-
-let method_trait { Abc.trait_name = name; data = data} =
- open Abc in
- match data with
- | MethodTrait (0,i,[]) ->
- (name,i)
- | MethodTrait _ | SlotTrait _
- | GetterTrait _ | SetterTrait _
- | ClassTrait _ | FunctionTrait _
- | ConstTrait _ ->
- failwith "munt not happen"
-
-let _ = test "class" begin
- fun () ->
- let {method_info = mi;
- method_body = mb;
- instance_info = ii;
- class_info = ci;
- cpool = cp } =
- A.assemble_method @@ insts [`Class] in
- let nth_method i =
- (List.nth mb i).Abc.code in
- ok 1 @@ List.length ci;
- ok 1 @@ List.length ii;
- ok 5 @@ List.length mi;
- ok 5 @@ List.length mb;
- let assert_cpool expect acutal =
- ok (Cpool.index expect cp) @@ acutal in
- let c =
- List.hd ci in
- let i =
- List.hd ii in
- (* class info *)
- ok [u8 101] @@ nth_method c.Abc.cinit;
- begin match c.Abc.class_traits with
- [t] ->
- let (name,method_i) =
- method_trait t in
- ok [u8 104] @@ nth_method method_i;
- assert_cpool (`QName (`Namespace "","")) @@ name
- | _::_ | [] ->
- assert_failure "must not happen" end;
- (* instance info *)
- assert_cpool (`QName (`Namespace "","Foo")) @@ i.Abc.instance_name;
- assert_cpool (`QName (`Namespace "","Object")) @@ i.Abc.super_name;
- ok [Abc.Sealed] @@ i.Abc.instance_flags;
- ok [u8 102] @@ (List.nth mb i.Abc.iinit).Abc.code;
- begin match i.Abc.instance_traits with
- [t] ->
- let (name,method_i) =
- method_trait t in
- ok [u8 103] @@ nth_method method_i;
- assert_cpool (`QName (`Namespace "","")) @@ name
- | _::_ | [] ->
- assert_failure "must not happen" end;
-end
-
-(* end prefix *)
let _ =
- run_test_tt_main ("asm.ml" >::: !test_cases)
+ ("abc.ml" >:::
+ ["of_script test" >::
+ (fun () ->
+ ok [u30 0x7F; u30 0] @@ of_script script);
+ "of_trait test" >::
+ (fun () ->
+ ok [u30 1;u8 0; u30 1; u30 2; u30 3; u8 4; ] @@
+ of_trait {trait_name=1; data=SlotTrait (1,2,3,4)};
+ ok [u30 1;u8 0; u30 1; u30 2; u30 0] @@
+ of_trait {trait_name=1; data=SlotTrait (1,2,0,4)};
+ ok [u30 1;u8 1; u30 1; u30 2] @@
+ of_trait {trait_name=1; data=MethodTrait (1,2,[])};
+ ok [u30 1;u8 2; u30 1; u30 2] @@
+ of_trait {trait_name=1; data=GetterTrait (1,2,[])};
+ ok [u30 1;u8 3; u30 1; u30 2] @@
+ of_trait {trait_name=1; data=SetterTrait (1,2,[])};
+ ok [u30 1;u8 4; u30 1; u30 2] @@
+ of_trait {trait_name=1; data=ClassTrait (1,2)};
+ ok [u30 1;u8 5; u30 1; u30 2] @@
+ of_trait {trait_name=1; data=FunctionTrait (1,2)};
+ ok [u30 1;u8 6; u30 1; u30 2; u30 3; u8 4] @@
+ of_trait {trait_name=1; data=ConstTrait (1,2,3,4)};
+ ok [u30 1;u8 6; u30 1; u30 2; u30 0] @@
+ of_trait {trait_name=1; data=ConstTrait (1,2,0,4)});
+ "of_method_info test" >::
+ (fun () ->
+ ok
+ [u30 0; u30 1; u30 2; u8 3] @@
+ of_method_info info);
+ "of_method_body test" >::
+ (fun () ->
+ ok [u30 1;
+ u30 2;
+ u30 3;
+ u30 4;
+ u30 5;
+ u30 0;
+ u30 0;
+ u30 0] @@
+ of_method_body body);
+ "of_cpool test" >::
+ (fun () ->
+ ok [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;
+ ok [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);
+ "of_class test" >::
+ (fun () ->
+ ok [u30 10; u30 0] @@
+ of_class {cinit=10; class_traits=[]});
+ "of_instance test" >::
+ (fun () ->
+ ok [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 *) ] @@
+ of_instance {
+ instance_name=1;
+ super_name=2;
+ instance_flags=[Sealed;Final];
+ interface=[1;2;3;4];
+ iinit=5;
+ instance_traits=[]});
+ "of_instance protected ns" >::
+ (fun () ->
+ ok [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 *) ] @@
+ of_instance {
+ instance_name=1;
+ super_name=2;
+ instance_flags=[ProtectedNs 1];
+ interface=[1;2;3;4];
+ iinit=5;
+ instance_traits=[]});
+ "spimle abc" >::
+ (fun () ->
+ ok [u16 16; u16 46;(* version *)
+ u30 1; u30 1; u30 1; u30 1; u30 1; u30 1; u30 1;
+ (* cpool *)
+ u30 0; (* info *)
+ u30 0; (* meta *)
+ u30 0; (* class *)
+ u30 0; (* script *)
+ u30 0; (* body *) ] @@
+ to_bytes {
+ cpool = empty_cpool;
+ method_info = [];
+ metadata = [];
+ classes = [];
+ instances = [];
+ scripts = [];
+ method_bodies = []});
+ "full abc" >::
+ (fun () ->
+ ok (List.concat [
+ (* version *) [ u16 16; u16 46];
+ (* cpool *) of_cpool {empty_cpool with string=["foo"] };
+ (* info *) [ u30 1]; of_method_info info;
+ (* meta *) [u30 0];
+ (* class *) [u30 0];
+ (* script *) [u30 1]; of_script script;
+ (* body *) [u30 1]; [u30 1;
+ u30 2;
+ u30 3;
+ u30 4;
+ u30 5;
+ u30 0;
+ u30 0;
+ u30 0] ]) @@
+ to_bytes {
+ cpool = {empty_cpool with string=["foo"] } ;
+ method_info = [info];
+ metadata = [];
+ classes = [];
+ instances = [];
+ scripts = [script];
+ method_bodies = [body]})
+ ] ) +> run_test_tt_main
OSDN Git Service
