abcType
lowInst
asm
+ cpool
compile
OUnitTest(bytes , bytes label)
OUnitTest(lowInst , lowInst bytes)
OUnitTest(asm , asm label bytes)
-OUnitTest(compile , compile)
-#OUnitTest(revList , revList)
-#OUnitTest(cpool , cpool revList)
+OUnitTest(compile , compile cpool bytes label revList)
+OUnitTest(revList , revList)
+OUnitTest(cpool , cpool revList)
#OUnitTest(asm , bytes asm cpool revList)
# phony
val of_class : class_info -> Bytes.t list
val of_instance : instance_info -> Bytes.t list
end
-
--- /dev/null
+open Base
+open AbcType
+
+type 'a t = {
+ cpool: Cpool.t;
+ method_info: method_info list;
+ method_body: 'a method_body list;
+ class_info: class_info list;
+ instance_info: instance_info list
+}
+
+type function_scope =
+ [ `Global
+ | `Class of Cpool.multiname]
+
+type class_type =
+ [ `Sealed
+ | `Final
+ | `Interface
+ | `ProtectedNs of Cpool.namespace]
+
+type 'a method_ = {
+ method_name: Cpool.multiname;
+ params: int list;
+ return: int;
+ method_flags: int;
+ instructions: 'a list;
+ traits: int list;
+ exceptions: int list;
+ fun_scope: function_scope;
+ method_attrs : [`Override | `Final] list
+}
+type 'a class_ = {
+ class_name: Cpool.multiname;
+ super: Cpool.multiname;
+ class_flags: class_type list;
+ cinit: 'a method_;
+ iinit: 'a method_;
+ interface: 'a class_ list;
+ instance_methods: 'a method_ list;
+ static_methods: 'a method_ list;
+ attributes: Cpool.multiname list
+}
+
+class type ['a] context = object
+ method cpool: Cpool.t
+ method methods: 'a method_ RevList.t
+ method classes: 'a class_ RevList.t
+end
+
+module type Inst = sig
+ type s (* source *)
+ type t (* target *)
+
+ val inst : s -> t
+ val const : s -> Cpool.entry list
+ val stack : s -> int
+ val scope : s -> int
+ val method_ : s -> s method_ option
+ val class_ : s -> s class_ option
+end
+
+module Make(Inst : Inst) = struct
+ let to_abc _ = undefined
+end
--- /dev/null
+open Base
+open OUnit
+open AbcType
+open Asm
+open Bytes
+open Compile
+
+(* start prefix *)
+let test_cases = ref []
+let test name body =
+ test_cases := (name >:: body)::!test_cases;;
+
+let ok =
+ OUnit.assert_equal
+
+(* test util*)
+let empty_method =
+{ Compile.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}
+
+module Inst = struct
+ type s =
+ [ `OpOnly1 | `OpOnly2
+ | `OpOnly3 | `OpOnly4
+ | `WithArgs | `WithPrefix
+ | `String | `Int
+ | `StackAdd | `StackDel
+ | `ScopeAdd | `ScopeDel
+ | `Meth
+ | `Class ]
+ type t = int
+
+ let class_ =
+ function
+ `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 = [];
+ }
+ | _ ->
+ None
+
+ let method_ =
+ function
+ `Meth ->
+ Some {(insts [`OpOnly1]) with
+ method_name = `QName (`Namespace "","f")}
+
+ | _ ->
+ None
+
+ let scope =
+ function
+ `ScopeAdd ->
+ 1
+ | `ScopeDel ->
+ -1
+ | _ ->
+ 0
+
+ let stack =
+ function
+ `StackAdd ->
+ 1
+ | `StackDel ->
+ -1
+ | _ ->
+ 0
+
+ let const =
+ function
+ `String ->
+ ([`String "foo"] :> Cpool.entry list)
+ | `Int ->
+ ([`Int 42] :> Cpool.entry list)
+ | _ ->
+ []
+
+ let inst =
+ function
+ `OpOnly1 ->
+ 101
+ | `OpOnly2 ->
+ 102
+ | `OpOnly3 ->
+ 103
+ | `OpOnly4 ->
+ 104
+ | _ ->
+ 0
+end
+
+let insts _ =
+ undefined
+
+module C = Compile.Make(Inst)
+
+let _ = test "Instruction" begin
+ fun () ->
+ let {method_info=mi;
+ method_body=mb} =
+ C.to_abc @@ insts [`OpOnly1; `OpOnly2] in
+ ok 1 @@ List.length mi;
+ ok 1 @@ List.length mb;
+ ok 0 @@ (List.hd mb).method_sig;
+ ok [u8 101; u8 102] @@ (List.hd mb).code
+end
+
+let _ = test "args/prefix" begin
+ fun () ->
+ let {method_info=mi;
+ method_body=mb} =
+ C.to_abc @@ insts [`WithArgs; `WithPrefix] in
+ ok 1 @@ List.length mi;
+ ok 1 @@ List.length mb;
+ ok 0 @@ (List.hd mb).method_sig;
+ ok [u8 0; u8 1;
+ u8 2; u8 0] @@ (List.hd mb).code
+end
+
+let _ = test "constant" begin
+ fun () ->
+ let {cpool=cpool} =
+ C.to_abc @@ 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} =
+ C.to_abc @@ insts [`StackAdd; `StackAdd; `StackDel] in
+ ok 1 @@ List.length mi;
+ ok 1 @@ List.length mb;
+ ok 2 @@ (List.hd mb).max_stack;
+end
+
+let _ = test "scope" begin
+ fun () ->
+ let {method_info=mi;
+ method_body=mb} =
+ C.to_abc @@ insts [`ScopeAdd; `ScopeAdd; `ScopeDel] in
+ ok 1 @@ List.length mi;
+ ok 1 @@ List.length mb;
+ ok 2 @@ (List.hd mb).max_scope_depth;
+ ok 0 @@ (List.hd mb).init_scope_depth
+end
+
+let _ = test "method" begin
+ fun () ->
+ let {method_info=mi;
+ method_body=mb} =
+ C.to_abc @@ insts [`Meth] in
+ ok 2 @@ List.length mi;
+ ok 2 @@ List.length mb;
+ ok 0 @@ (List.nth mb 0).method_sig;
+ ok 1 @@ (List.nth mb 1).method_sig;
+ ok [u8 101] @@ (List.nth mb 0).code;
+ ok [u8 0] @@ (List.nth mb 1).code;
+end
+
+let _ = test "method dup" begin
+ (* same method should NOT be unified for AVM2 restriction *)
+ fun () ->
+ let {method_info=mi;
+ method_body=mb} =
+ C.to_abc @@ insts [`Meth; `Meth] in
+ ok 3 @@ List.length mi;
+ ok 3 @@ List.length mb
+end
+
+let method_trait { trait_name = name; data = data} =
+ 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 } =
+ C.to_abc @@ insts [`Class] in
+ let nth_method i =
+ (List.nth mb i).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.AbcType.cinit;
+ begin match c.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.instance_name;
+ assert_cpool (`QName (`Namespace "","Object")) @@ i.super_name;
+ ok [Sealed] @@ i.instance_flags;
+ ok [u8 102] @@ (List.nth mb i.AbcType.iinit).AbcType.code;
+ begin match i.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 ("compile.ml" >::: !test_cases)
--- /dev/null
+open Base
+open AbcType
+
+type namespace = [
+ `Namespace of string
+| `PackageNamespace of string
+| `PackageInternalNamespace of string
+| `ProtectedNamespace of string
+| `ExplicitNamespace of string
+| `StaticProtectedNamespace of string
+| `PrivateNamespace of string ]
+
+type namespace_set = namespace list
+
+type multiname = [
+ `QName of namespace * string
+| `Multiname of string * namespace_set
+]
+
+type entry = [
+| `Int of int
+| `UInt of int
+| `Double of float
+| `String of string
+| namespace
+| multiname
+]
+
+type t = {
+ int: int RevList.t;
+ uint: int RevList.t;
+ double: float RevList.t;
+ string: string RevList.t;
+ namespace: namespace RevList.t;
+ namespace_set: namespace_set RevList.t;
+ multiname: multiname RevList.t;
+}
+
+let empty =
+ {int = RevList.empty;
+ uint = RevList.empty;
+ double = RevList.empty;
+ string = RevList.empty;
+ namespace = RevList.empty;
+ namespace_set = RevList.empty;
+ multiname = RevList.empty}
+
+let ns_name =
+ function
+ `Namespace name
+ | `PackageNamespace name
+ | `PackageInternalNamespace name
+ | `ProtectedNamespace name
+ | `ExplicitNamespace name
+ | `StaticProtectedNamespace name
+ | `PrivateNamespace name ->
+ name
+
+let add x xs =
+ if RevList.mem x xs then
+ xs
+ else
+ RevList.add x xs
+
+let add_list xs ys =
+ RevList.add_list (List.filter (fun x -> not (RevList.mem x ys)) xs) ys
+
+let add_namespace ns cpool =
+ {cpool with
+ string = cpool.string
+ +> add (ns_name ns);
+ namespace = add ns cpool.namespace }
+
+let add_multiname name cpool =
+ match name with
+ `QName (ns,str) ->
+ let cpool =
+ {cpool with
+ string = cpool.string
+ +> add str;
+ multiname = add name cpool.multiname } in
+ add_namespace ns cpool
+ | `Multiname (str,ns_set) ->
+ {cpool with
+ string = cpool.string
+ +> add_list (List.map ns_name ns_set)
+ +> add str;
+ namespace = add_list ns_set cpool.namespace;
+ namespace_set = add ns_set cpool.namespace_set;
+ multiname = add name cpool.multiname }
+
+let add entry cpool =
+ match entry with
+ `Int n ->
+ { cpool with int= add n cpool.int }
+ | `UInt n ->
+ { cpool with uint= add n cpool.uint }
+ | `String s ->
+ { cpool with string = add s cpool.string }
+ | `Double d ->
+ { cpool with double = add d cpool.double }
+ | #namespace as ns ->
+ add_namespace ns cpool
+ | #multiname as m ->
+ add_multiname m cpool
+
+(* conversion *)
+(*
+ assumption:
+ - list has only unique element
+*)
+let rindex x set =
+ 1 + RevList.index x set
+
+let index entry cpool =
+ match entry with
+ `Int n ->
+ rindex n cpool.int
+ | `UInt n ->
+ rindex n cpool.uint
+ | `Double d ->
+ rindex d cpool.double
+ | `String s ->
+ rindex s cpool.string
+ | #namespace as ns ->
+ rindex ns cpool.namespace
+ | #multiname as m ->
+ rindex m cpool.multiname
+
+let of_namespace {string=string} (ns : namespace) =
+ let i =
+ rindex (ns_name ns) string in
+ let kind =
+ match ns with
+ `Namespace _ ->
+ 0x08
+ | `PackageNamespace _ ->
+ 0x16
+ | `PackageInternalNamespace _ ->
+ 0x17
+ | `ProtectedNamespace _ ->
+ 0x18
+ | `ExplicitNamespace _ ->
+ 0x19
+ | `StaticProtectedNamespace _ ->
+ 0x1A
+ | `PrivateNamespace _ ->
+ 0x05 in
+ {AbcType.kind=kind; namespace_name=i}
+
+let of_namespace_set {namespace=namespace} nss =
+ List.map (fun ns -> rindex ns namespace) nss
+
+let of_multiname {namespace=namespace; namespace_set=namespace_set; string=string} =
+ function
+ `QName (ns,s) ->
+ QName (rindex ns namespace, rindex s string)
+ | `Multiname (s,nss) ->
+ Multiname (rindex s string,rindex nss namespace_set)
+
+let to_abc cpool =
+ { AbcType.int =
+ RevList.to_list cpool.int;
+ uint =
+ RevList.to_list cpool.uint;
+ double =
+ RevList.to_list cpool.double;
+ string =
+ RevList.to_list cpool.string;
+ namespace =
+ cpool.namespace
+ +> RevList.to_list
+ +> List.map (of_namespace cpool);
+ namespace_set =
+ cpool.namespace_set
+ +> RevList.to_list
+ +> List.map (of_namespace_set cpool);
+ multiname =
+ cpool.multiname
+ +> RevList.to_list
+ +> List.map (of_multiname cpool)
+ }
--- /dev/null
+(**
+ Constant pool(CPool).
+
+ CPool create the map from a value to the index, or a list of the value.
+ *)
+
+(** A type of namespace *)
+type namespace = [
+ `Namespace of string
+| `PackageNamespace of string
+| `PackageInternalNamespace of string
+| `ProtectedNamespace of string
+| `ExplicitNamespace of string
+| `StaticProtectedNamespace of string
+| `PrivateNamespace of string ]
+
+type namespace_set = namespace list
+
+(** A type of multiname *)
+type multiname = [
+ `QName of namespace * string
+| `Multiname of string * namespace_set
+]
+
+type entry = [
+| `Int of int
+| `UInt of int
+| `Double of float
+| `String of string
+| namespace
+| multiname
+]
+
+type t
+
+val empty : t
+val add : [< entry] -> t -> t
+val index : [< entry] -> t -> int
+val to_abc : t -> AbcType.cpool
--- /dev/null
+open Base
+open Cpool
+open Bytes
+open OUnit
+open AbcType
+
+let empty_cpool =
+ { AbcType.int = [];
+ uint = [];
+ double = [];
+ string = [];
+ namespace = [];
+ namespace_set = [];
+ multiname = []}
+
+let test_index value =
+ let cpool =
+ Cpool.add value Cpool.empty in
+ assert_equal 1 (Cpool.index value cpool)
+
+let ok cpool value =
+ assert_equal cpool (to_abc @@ Cpool.add value Cpool.empty)
+
+let _ =
+ ("cpool.ml" >::: [
+ "int" >::
+ (fun () ->
+ test_index (`Int 42);
+ test_index (`Int ~-42));
+ "uint" >::
+ (fun () ->
+ test_index (`UInt 42));
+ "string" >::
+ (fun () ->
+ test_index (`String "foobar"));
+ "multiname" >::
+ (fun () ->
+ test_index (`QName ((`Namespace "std"),"print"));
+ test_index (`Multiname ("print",[]));
+ test_index (`Multiname ("print",[`Namespace "std"])));
+ "literal cpool" >::
+ (fun () ->
+ ok {empty_cpool with string=["foobar"]} (`String "foobar");
+ ok {empty_cpool with int=[30]} (`Int 30);
+ ok {empty_cpool with int=[~-30]} (`Int ~-30);
+ ok {empty_cpool with uint=[42]} (`UInt 42));
+ "qname cpool" >::
+ (fun () ->
+ ok
+ {empty_cpool with
+ string = ["foobar"; "std"];
+ namespace = [{kind=0x08; namespace_name=2}];
+ multiname = [QName (1,1)]}
+ (`QName (`Namespace "std","foobar")));
+ "multiname cpool" >::
+ (fun () ->
+ ok
+ {empty_cpool with
+ string = ["std";"foobar"];
+ namespace = [{kind=0x08; namespace_name=1}];
+ namespace_set= [[1]];
+ multiname=[Multiname (2,1)]}
+ (`Multiname ("foobar",[`Namespace "std"])));
+ "cpool entry should be unique" >::
+ (fun () ->
+ let cpool =
+ List.fold_left (flip Cpool.add) empty [`String "foo"; `String "bar"; `String "foo"] in
+ assert_equal 1 (Cpool.index (`String "foo") cpool);
+ assert_equal {empty_cpool with string=["foo";"bar"]} (to_abc cpool));
+ "index is not change" >::
+ (fun () ->
+ let cpool1 =
+ Cpool.add (`Int 42) empty in
+ let cpool2 =
+ Cpool.add (`Int 42) cpool1 in
+ assert_equal (Cpool.index (`Int 42) cpool1) (Cpool.index (`Int 42) cpool2))
+ ]) +> run_test_tt_main
--- /dev/null
+(**
+Index immutable Set.
+
+If you add some elements to a set, [index] is not change.
+*)
+open Base
+
+type 'a t = 'a list
+
+let empty =
+ []
+
+let add x xs =
+ x::xs
+
+let add_list xs ys =
+ List.fold_left (flip add) ys xs
+
+let rec index x =
+ function
+ [] ->
+ raise Not_found
+ | y::ys ->
+ if x = y then
+ List.length ys
+ else
+ index x ys
+
+let to_list xs =
+ List.rev xs
+
+let mem x xs =
+ List.mem x xs
--- /dev/null
+type 'a t
+val add : 'a -> 'a t -> 'a t
+val add_list : 'a list -> 'a t -> 'a t
+val index : 'a -> 'a t -> int
+val to_list : 'a t -> 'a list
+val empty : 'a t
+val mem : 'a -> 'a t -> bool
--- /dev/null
+open Base
+open RevList
+open OUnit
+
+let _ =
+ ("ISet" >::: [
+ "index is immutable" >::
+ (fun () ->
+ let set1 =
+ RevList.add 0 empty in
+ let set2 =
+ RevList.add 1 set1 in
+ assert_equal (index 0 set1) (RevList.index 0 set2));
+ "mem" >::
+ (fun () ->
+ assert_equal false (RevList.mem 0 empty);
+ assert_equal true (RevList.mem 0 (RevList.add 0 empty)));
+ "index" >::
+ (fun () ->
+ let set =
+ RevList.add 42 empty in
+ assert_equal 0 (RevList.index 42 set));
+ "to_list" >::
+ (fun () ->
+ let set1 =
+ RevList.add 42 empty in
+ let set2 =
+ RevList.add 0 set1 in
+ assert_equal [42;0] (RevList.to_list set2));
+ "add_list" >::
+ (fun () ->
+ let set1 =
+ RevList.add_list [1;2;3] empty in
+ let set2 =
+ RevList.add 3 (RevList.add 2 (RevList.add 1 empty)) in
+ assert_equal set1 set2)
+ ]) +> run_test_tt_main
OSDN Git Service
