label
lowInst
abcType
+ abcWriter
asm
- abc
+
UseCamlp4(pa_openin pa_oo)
+++ /dev/null
-open Base
-
-include AbcType
-type 'a s = 'a t
-
-module A = Asm.Make(LowInst)
-
-let write ch insts =
- insts
- +> A.to_bytes
- +> Bytes.output_bytes ch
+++ /dev/null
-open Base
-open Abc
-open OUnit
-open Bytes
-
-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=[u8 1;u8 2;u8 3;s24 1];
- exceptions=[];
- method_traits=[] }
-
-let script =
- {init=0x7F; script_traits=[]}
-
-let ok x y =
- OUnit.assert_equal (to_int_list x) (to_int_list y)
-
-let _ =
- ("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 6; u8 1; u8 2; u8 3;s24 1;
- 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 6;u8 1; u8 2; u8 3;s24 1;
- u30 0;
- u30 0] ]) @@
- Abc.to_bytes {
- cpool = {empty_cpool with string=["foo"] } ;
- method_info = [info];
- metadata = [];
- classes = [];
- instances = [];
- scripts = [script];
- method_bodies = [body]})
- ] ) +> run_test_tt_main
+++ /dev/null
-open Base
-
-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
- {Abc.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} : multiname -> Abc.multiname =
- function
- `QName (ns,s) ->
- Abc.QName (rindex ns namespace, rindex s string)
- | `Multiname (s,nss) ->
- Abc.Multiname (rindex s string,rindex nss namespace_set)
-
-let to_abc cpool =
- { Abc.int = RevList.to_list cpool.int;
- Abc.uint = RevList.to_list cpool.uint;
- Abc.double = RevList.to_list cpool.double;
- Abc.string = RevList.to_list cpool.string;
- Abc.namespace = cpool.namespace
- +> RevList.to_list
- +> List.map (of_namespace cpool);
- Abc.namespace_set = cpool.namespace_set
- +> RevList.to_list
- +> List.map (of_namespace_set cpool);
- Abc.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 -> Abc.cpool
+++ /dev/null
-open Base
-open Cpool
-open Bytes
-open OUnit
-
-let empty_cpool =
- { Abc.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 Abc.string=["foobar"]} (`String "foobar");
- ok {empty_cpool with Abc.int=[30]} (`Int 30);
- ok {empty_cpool with Abc.int=[~-30]} (`Int ~-30);
- ok {empty_cpool with Abc.uint=[42]} (`UInt 42));
- "qname cpool" >::
- (fun () ->
- ok
- {empty_cpool with
- Abc.string = ["foobar"; "std"];
- namespace = [{Abc.kind=0x08; namespace_name=2}];
- multiname = [Abc.QName (1,1)]}
- (`QName (`Namespace "std","foobar")));
- "multiname cpool" >::
- (fun () ->
- ok
- {empty_cpool with
- Abc.string = ["std";"foobar"];
- namespace = [{Abc.kind=0x08; namespace_name=1}];
- namespace_set= [[1]];
- multiname=[Abc.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 Abc.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
-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
-}
-
-(*
- Because I want use structual subtyping, I use object as record.
-*)
-class type ['a] context = object
- method cpool: Cpool.t
- method methods: 'a method_ RevList.t
- method classes: 'a class_ RevList.t
-end
-
-type 'a t = {
- op: int;
- args: 'a context -> Bytes.t list;
- prefix: 'a context -> Bytes.t list;
- const: Cpool.entry list;
- method_: 'a method_ option;
- class_ : 'a class_ option;
- stack : int;
- scope : int;
- count : int;
-}
-
-let empty_method = {
- method_attrs = [];
- method_name = `QName (`Namespace "","");
- params = [];
- return = 0;
- method_flags = 0;
- instructions = [];
- traits= [];
- exceptions= [];
- fun_scope= `Global
-}
+++ /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
