From: mzp Date: Thu, 10 Sep 2009 23:00:45 +0000 (+0900) Subject: add compiler test X-Git-Url: http://git.osdn.net/view?a=commitdiff_plain;h=901a9d68e0c95fd986992880689d97d24f816cff;p=happyabc%2Fhappyabc.git add compiler test --- diff --git a/swflib/OMakefile b/swflib/OMakefile index 67afcf2..d030dcd 100644 --- a/swflib/OMakefile +++ b/swflib/OMakefile @@ -11,6 +11,7 @@ FILES[] = abcType lowInst asm + cpool compile @@ -31,9 +32,9 @@ OUnitTest(label , label) 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 diff --git a/swflib/asm.mli b/swflib/asm.mli index bb960ba..ace62aa 100644 --- a/swflib/asm.mli +++ b/swflib/asm.mli @@ -19,4 +19,3 @@ module Make : functor (S : Inst) -> sig val of_class : class_info -> Bytes.t list val of_instance : instance_info -> Bytes.t list end - diff --git a/swflib/compile.ml b/swflib/compile.ml new file mode 100644 index 0000000..c744b00 --- /dev/null +++ b/swflib/compile.ml @@ -0,0 +1,65 @@ +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 diff --git a/swflib/compileTest.ml b/swflib/compileTest.ml new file mode 100644 index 0000000..84db3a6 --- /dev/null +++ b/swflib/compileTest.ml @@ -0,0 +1,254 @@ +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) diff --git a/swflib/cpool.ml b/swflib/cpool.ml new file mode 100644 index 0000000..6f953dd --- /dev/null +++ b/swflib/cpool.ml @@ -0,0 +1,182 @@ +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) + } diff --git a/swflib/cpool.mli b/swflib/cpool.mli new file mode 100644 index 0000000..798d394 --- /dev/null +++ b/swflib/cpool.mli @@ -0,0 +1,39 @@ +(** + 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 diff --git a/swflib/cpoolTest.ml b/swflib/cpoolTest.ml new file mode 100644 index 0000000..c2f25a8 --- /dev/null +++ b/swflib/cpoolTest.ml @@ -0,0 +1,77 @@ +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 diff --git a/swflib/revList.ml b/swflib/revList.ml new file mode 100644 index 0000000..a92ea1a --- /dev/null +++ b/swflib/revList.ml @@ -0,0 +1,33 @@ +(** +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 diff --git a/swflib/revList.mli b/swflib/revList.mli new file mode 100644 index 0000000..ff1604f --- /dev/null +++ b/swflib/revList.mli @@ -0,0 +1,7 @@ +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 diff --git a/swflib/revListTest.ml b/swflib/revListTest.ml new file mode 100644 index 0000000..37b5a46 --- /dev/null +++ b/swflib/revListTest.ml @@ -0,0 +1,37 @@ +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