swflib/methodOutTest.ml

   1 open Base
   2 open OUnit
   3 open AbcType
   4 open MethodType
   5 open AbcOut
   6 open BytesOut
   7 open MethodOut
   8
   9 (* start prefix *)
  10 let test_cases = ref []
  11 let test name body =
  12   test_cases := (name >:: body)::!test_cases;;
  13
  14 let ok x y =
  15   OUnit.assert_equal ~printer:Std.dump x y
  16
  17 (* test util*)
  18 let empty_method =
  19 { method_attrs = [];
  20   method_name        = `QName (`Namespace "","");
  21   params             = [];
  22   return             = 0;
  23   method_flags       = [];
  24   code = [];
  25   traits             = [];
  26   exceptions         = [];
  27   fun_scope          = `Global
  28 }
  29
  30 let insts insts =
  31    {empty_method with code=insts}
  32
  33 module Inst = struct
  34   type s =
  35       [ `OpOnly1  | `OpOnly2
  36       | `OpOnly3  | `OpOnly4
  37       | `String   | `Int
  38       | `StackAdd | `StackDel
  39       | `ScopeAdd | `ScopeDel
  40       | `Meth
  41       | `Class
  42       | `Script of s method_ ]
  43   type t = int
  44
  45   let class_ =
  46     function
  47         `Class ->
  48           Some {
  49             class_name = `QName (`Namespace "","Foo");
  50             super      = `QName (`Namespace "","Object");
  51             class_flags= [`Sealed];
  52             cinit      = insts [`OpOnly1];
  53             iinit      = insts [`OpOnly2];
  54             interface  = [];
  55             instance_methods = [insts [`OpOnly3]];
  56             static_methods   = [insts [`OpOnly4]];
  57             attrs = [];
  58           }
  59       | _ ->
  60           None
  61
  62   let method_ =
  63       function
  64           `Meth ->
  65             Some {(insts [`OpOnly1]) with
  66                     method_name = `QName (`Namespace "","f")}
  67         | _ ->
  68             None
  69
  70   let scope =
  71     function
  72         `ScopeAdd ->
  73           1
  74       | `ScopeDel ->
  75           -1
  76       | _ ->
  77           0
  78
  79   let stack =
  80     function
  81         `StackAdd ->
  82           1
  83       | `StackDel ->
  84           -1
  85       | _ ->
  86           0
  87
  88   let const =
  89     function
  90         `String ->
  91           ([`String "foo"] :> Cpool.entry list)
  92       | `Int ->
  93           ([`Int 42] :> Cpool.entry list)
  94       | _ ->
  95           []
  96
  97   let inst _ =
  98     function
  99         `OpOnly1 ->
 100           101
 101       | `OpOnly2 ->
 102           102
 103       | `OpOnly3 ->
 104           103
 105       | `OpOnly4 ->
 106           104
 107       | _ ->
 108           0
 109 end
 110
 111 module C = MethodOut.Make(Inst)
 112
 113 let to_abc xs =
 114   C.to_abc [] @@ insts xs
 115
 116 let to_cpool xs =
 117   C.__to_cpool @@ insts xs
 118
 119 let _ = test "Instruction" begin
 120   fun () ->
 121     let {method_info=mi;
 122          method_bodies=mb} =
 123       to_abc [`OpOnly1; `OpOnly2] in
 124       ok 1 @@ List.length mi;
 125       ok 1 @@ List.length mb;
 126       ok 0 @@ (List.hd mb).method_sig;
 127       ok [101; 102] @@ (List.hd mb).AbcType.code
 128 end
 129
 130 let _ = test "constant" begin
 131   fun () ->
 132     let cpool =
 133       to_cpool [`String; `Int; `Meth; `Class] in
 134       List.iter
 135         (ignore $ Cpool.index cpool ) [
 136           `String "foo";
 137           `String "f";
 138           `String "Foo";
 139           `String "Object";
 140           `String "";
 141           `Int    42;
 142           `QName (`Namespace "","f");
 143           `QName (`Namespace "","");
 144           `QName (`Namespace "","Foo");
 145           `QName (`Namespace "","Object");
 146         ]
 147 end
 148
 149 let _ = test "stack" begin
 150   fun () ->
 151     let {method_info=mi;
 152          method_bodies=mb} =
 153       to_abc [`StackAdd; `StackAdd; `StackDel] in
 154       ok 1 @@ List.length mi;
 155       ok 1 @@ List.length mb;
 156       ok 2 @@ (List.hd mb).max_stack;
 157 end
 158
 159 let _ = test "scope" begin
 160   fun () ->
 161     let {method_info=mi;
 162          method_bodies=mb} =
 163       to_abc [`ScopeAdd; `ScopeAdd; `ScopeDel] in
 164       ok 1 @@ List.length mi;
 165       ok 1 @@ List.length mb;
 166       ok 2 @@ (List.hd mb).max_scope_depth;
 167       ok 0 @@ (List.hd mb).init_scope_depth
 168 end
 169
 170 let _ = test "method" begin
 171   fun () ->
 172     let {method_info=mi;
 173          method_bodies=mb} =
 174       to_abc [`Meth] in
 175       ok 2 @@ List.length mi;
 176       ok 2 @@ List.length mb;
 177       ok 0 @@ (List.nth mb 0).method_sig;
 178       ok 1 @@ (List.nth mb 1).method_sig;
 179       ok [101] @@ (List.nth mb 0).AbcType.code;
 180       ok [0]   @@ (List.nth mb 1).AbcType.code;
 181 end
 182
 183 let _ = test "method dup" begin
 184   (* same method should NOT be unified for AVM2 restriction *)
 185   fun () ->
 186     let {method_info=mi;
 187          method_bodies=mb} =
 188       to_abc [`Meth; `Meth] in
 189       ok 3 @@ List.length mi;
 190       ok 3 @@ List.length mb
 191 end
 192
 193 let method_trait { trait_name = name; data = data} =
 194   match data with
 195     | MethodTrait (0,i,[]) ->
 196         (name,i)
 197     | MethodTrait _  | SlotTrait _
 198     | GetterTrait _  | SetterTrait _
 199     | ClassTrait _   | FunctionTrait _
 200     | ConstTrait _ ->
 201         failwith "munt not happen"
 202
 203 let _ = test "class" begin
 204   fun () ->
 205     let {method_info   = mi;
 206          method_bodies = mb;
 207          instances = ii;
 208          classes    = ci} =
 209       to_abc [`Class] in
 210     let cp =
 211       to_cpool [`Class] in
 212     let nth_method i =
 213       (List.nth mb i).AbcType.code in
 214       ok 1 @@ List.length ci;
 215       ok 1 @@ List.length ii;
 216       ok 5 @@ List.length mi;
 217       ok 5 @@ List.length mb;
 218       let assert_cpool expect acutal =
 219         ok (Cpool.index cp expect) @@ acutal in
 220       let c =
 221         List.hd ci in
 222       let i =
 223         List.hd ii in
 224         (* class info *)
 225         ok [101] @@ nth_method c.AbcType.cinit;
 226         begin match c.class_traits with
 227             [t] ->
 228               let (name,method_i) =
 229                 method_trait t in
 230                 ok [104] @@ nth_method method_i;
 231                 assert_cpool (`QName (`Namespace "","")) @@ name
 232           | _::_ | [] ->
 233               assert_failure "must not happen" end;
 234         (* instance info *)
 235         assert_cpool (`QName (`Namespace "","Foo")) @@ i.instance_name;
 236         assert_cpool (`QName (`Namespace "","Object")) @@ i.super_name;
 237         ok [Sealed] @@ i.instance_flags;
 238         ok [102] @@ (List.nth mb i.AbcType.iinit).AbcType.code;
 239         begin match i.instance_traits with
 240             [t] ->
 241               let (name,method_i) =
 242                 method_trait t in
 243                 ok [103] @@ nth_method method_i;
 244                 assert_cpool (`QName (`Namespace "","")) @@ name
 245           | _::_ | [] ->
 246               assert_failure "must not happen" end;
 247 end
 248
 249 (* end prefix *)
 250 let _ =
 251   run_test_tt_main ("compile.ml" >::: !test_cases)