--- /dev/null
+open Base
+open BytesIn
+open ExtString
+
+module type Inst = sig
+ type t
+ val of_bytes : int Stream.t -> t
+end
+
+module Make(Inst : Inst) = struct
+ open AbcType
+
+ let rec repeat n f stream =
+ if n <= 0 then
+ []
+ else
+ match stream with parser
+ [<c = f>] ->
+ c::repeat (n-1) f stream
+ | [<>] ->
+ raise (Stream.Error "invalid format")
+
+ let rec many parse stream =
+ match stream with parser
+ [< e = parse; s>] -> e::many parse s
+ | [<>] -> []
+
+ let array f stream =
+ let n =
+ u30 stream in
+ repeat n f stream
+
+ let carray f stream =
+ let n =
+ u30 stream in
+ repeat (n-1) f stream
+
+ (* constant pool *)
+ let string_info stream =
+ let cs =
+ List.map char_of_int @@ array u8 stream in
+ String.implode cs
+
+ let namespace_info stream =
+ let kind =
+ u8 stream in
+ let name =
+ u30 stream in
+ {kind=kind; namespace_name=name}
+(* TDOO *)
+(* match kind with
+ 0x08 ->
+ `Namespace name
+ | 0x16 ->
+ `PackageNamespace name
+ | 0x17 ->
+ `PackageInternaNs name
+ | 0x18 ->
+ `ProtectedNamespace name
+ | 0x19 ->
+ `ExplicitNamespace name
+ | 0x1A ->
+ `StaticProtectedNs name
+ | 0x05 ->
+ `PrivateNs name
+ | _ ->
+ failwith "must not happen"
+*)
+ let ns_set_info stream =
+ array u30 stream
+
+ let multiname_info stream =
+ let kind =
+ u8 stream in
+ match kind with
+ 0x07 ->
+ let ns =
+ u30 stream in
+ let name=
+ u30 stream in
+ QName (ns,name)
+ | 0x09 ->
+ let name =
+ u30 stream in
+ let ns_set =
+ u30 stream in
+ Multiname (name,ns_set)
+ | _ ->
+ failwith "invalid format"
+(* TODO *)
+(* match kind with
+ 0x07 ->
+ `QName { ns=u30 stream; name=u30 stream }
+ | 0x0D ->
+ `QNameA { ns=u30 stream; name=u30 stream }
+ | 0x0F ->
+ `RTQName { name=u30 stream }
+ | 0x10 ->
+ `RTQNameA { name=u30 stream }
+ | 0x11 ->
+ `RTQNameL
+ | 0x12 ->
+ `RTQNameLA
+ | 0x09 ->
+ `Multiname {name=u30 stream; ns_set=u30 stream}
+ | 0x0E ->
+ `MultinameA {name=u30 stream; ns_set=u30 stream}
+ | 0x1B ->
+ `MultinameL {ns_set=u30 stream}
+ | 0x1C ->
+ `MultinameLA {ns_set=u30 stream}
+ | _ ->
+ failwith "invalid format"
+*)
+
+ let constant_pool stream =
+ {
+ int = List.map (Int32.to_int) @@ carray s32 stream;
+ uint = List.map (Int32.to_int) @@ carray u32 stream;
+ double = carray d64 stream;
+ string = carray string_info stream;
+ namespace = carray namespace_info stream;
+ namespace_set = carray ns_set_info stream;
+ multiname = carray multiname_info stream
+ }
+
+ (* method info *)
+ let option_detail stream =
+ let value =
+ u30 stream in
+ match u8 stream with
+ 0x03 ->
+ `Int value
+ | 0x04 ->
+ `UInt value
+ | 0x06 ->
+ `Double value
+ | 0x01 ->
+ `String value
+ | 0x0B ->
+ `Bool true
+ | 0x0A ->
+ `Bool false
+ | 0x0C ->
+ `Null
+ | 0x00 ->
+ `Undefined
+ | 0x08 | 0x16 | 0x17 | 0x18 | 0x19 | 0x1A | 0x05 ->
+ `Namespace value
+ | _ ->
+ failwith "invalid format"
+
+ let option_info stream =
+ array option_detail stream
+
+ let has x y =
+ x land y = y
+
+ let method_info stream =
+ let param_count =
+ u30 stream in
+ let return_type =
+ u30 stream in
+ let param_types =
+ repeat param_count u30 stream in
+ let name =
+ u30 stream in
+ let flags =
+ u8 stream in
+(* let options =
+ if has flags 0x08 then
+ Some (option_info stream )
+ else
+ None in
+ let param_names =
+ if has flags 0x80 then
+ Some (repeat param_count u30 stream)
+ else
+ None in*)
+ { params = param_types;
+ return = return_type;
+ method_name = name;
+ method_flags = flags
+ (* need_arguments = has flags 0x01;
+ need_activation = has flags 0x02;
+ need_rest = has flags 0x04;
+ set_dxns = has flags 0x40;
+ options = options;
+ param_names = param_names*)
+ }
+
+ (* metadata *)
+ let item_info stream =
+ let key=u30 stream in
+ let value=u30 stream in
+ (key,value)
+
+ let metadata_info stream =
+ {
+ metadata_name = u30 stream;
+ items = array item_info stream
+ }
+
+ (* 4.8 Traits *)
+ let trait_info stream =
+ let name =
+ u30 stream in
+ let kind =
+ u8 stream in
+ let data =
+ match kind land 0x0F with
+ 0 | 6 ->
+ let slot_id =
+ u30 stream in
+ let type_name =
+ u30 stream in
+ let vindex =
+ u30 stream in
+ let vkind =
+ if vindex = 0 then
+ 0
+ else
+ u8 stream in
+ if kind = 0 then
+ SlotTrait(slot_id,type_name,vindex,vkind)
+ else
+ ConstTrait(slot_id,type_name,vindex,vkind)
+ | 4 ->
+ let id =
+ u30 stream in
+ let classi =
+ u30 stream in
+ ClassTrait(id,classi)
+ | 5 ->
+ let slot_id=
+ u30 stream in
+ let functioni=
+ u30 stream in
+ FunctionTrait (slot_id,functioni)
+ | 1 | 2 | 3 as k ->
+ let disp_id=
+ u30 stream in
+ let methodi=
+ u30 stream in
+ let flag =
+ kind lsr 4 in
+ let attrs = List.concat [
+ if has flag 0x01 then [ATTR_Final] else [];
+ if has flag 0x02 then [ATTR_Override] else [];
+ if has flag 0x04 then [ATTR_Medadata] else [];
+ ] in
+ begin match k with
+ 1 -> MethodTrait (disp_id,methodi,attrs)
+ | 2 -> GetterTrait (disp_id,methodi,attrs)
+ | 3 -> SetterTrait (disp_id,methodi,attrs)
+ | _ -> failwith "must not happen"
+ end
+ | _ ->
+ failwith "invalid format" in
+(* TODO *)
+(* let metadata =
+ if has attr 0x4 then
+ Some (array u30 stream)
+ else
+ None in*)
+ {
+ trait_name = name;
+ data = data;
+ }
+
+ (* 4.7 Instance *)
+ let instance_info stream =
+ let name =
+ u30 stream in
+ let super_name =
+ u30 stream in
+ let flags =
+ u8 stream in
+ let protectedNs =
+ if has flags 0x08 then
+ [ProtectedNs (u30 stream)]
+ else
+ [] in
+ let interface =
+ array u30 stream in
+ let iinit =
+ u30 stream in
+ let traits =
+ array trait_info stream in
+ { instance_name = name;
+ super_name = super_name;
+ interface = interface;
+ iinit = iinit;
+ instance_traits = traits;
+ instance_flags = List.concat [
+ if has flags 0x01 then [Sealed] else [];
+ if has flags 0x02 then [Final] else [];
+ if has flags 0x04 then [Interface] else [];
+ protectedNs]
+ }
+
+ (* 4.9 Class *)
+ let class_info stream =
+ { cinit = u30 stream; traits = array trait_info stream}
+
+ (* 4.10 Script*)
+ let script_info stream =
+ { init = u30 stream; traits = array trait_info stream }
+
+ (* 4.12 Exception *)
+ let exception_info stream =
+ { from_pos = u30 stream;
+ to_pos = u30 stream;
+ target = u30 stream;
+ exc_type = u30 stream;
+ var_name = u30 stream
+ }
+
+ (* 4.11 Method body *)
+ let method_body_info stream =
+ let methodi =
+ u30 stream in
+ let max_stack =
+ u30 stream in
+ let local_count =
+ u30 stream in
+ let init_scope_depth =
+ u30 stream in
+ let max_scope_depth =
+ u30 stream in
+ let code =
+ array u8 stream in
+ let exceptions =
+ array exception_info stream in
+ let traits =
+ array trait_info stream in
+ {
+ methodi = methodi;
+ max_stack = max_stack;
+ local_count = local_count;
+ init_scope_depth = init_scope_depth;
+ max_scope_depth = max_scope_depth;
+ code = many Inst.of_bytes @@ Stream.of_list code;
+ exceptions = exceptions;
+ traits = traits
+ }
+
+ (* 4.2 ABC File *)
+ let abcFile stream =
+ let minor_version =
+ u16 stream in
+ let major_version =
+ u16 stream in
+ let constant_pool =
+ constant_pool stream in
+ let methods =
+ array method_info stream in
+ let metadata =
+ array metadata_info stream in
+ let class_count =
+ u30 stream in
+ let instances =
+ repeat class_count instance_info stream in
+ let classes =
+ repeat class_count class_info stream in
+ let script =
+ array script_info stream in
+ let method_body =
+ array method_body_info stream in
+ {
+ minor_version = minor_version;
+ major_version = major_version;
+ constant_pool = constant_pool;
+ methods = methods;
+ metadata = metadata;
+ instances = instances;
+ classes = classes;
+ script = script;
+ method_body = method_body
+ }
+
+ let of_bytes stream =
+ abcFile stream
+end
--- /dev/null
+open Base
+open OUnit
+
+let ok x y =
+ OUnit.assert_equal ~printer:Std.dump x y
+
+let example name =
+ let ch =
+ open_in_bin @@ Printf.sprintf "example/%s.abc" name in
+ Abc.of_stream @@ Byte.of_channel ch
+
+let abc =
+ example "hello"
+
+let cpool =
+ abc#constant_pool
+
+let _ =
+ ("asm module test" >::: [
+ "major/minor version" >::
+ (fun () ->
+ ok 16 abc#minor_version;
+ ok 46 abc#major_version);
+ "cpool" >::: [
+ "integer" >::
+ (fun () -> ok [] cpool#integer);
+ "uinteger" >::
+ (fun () -> ok [] cpool#uinteger);
+ "double" >::
+ (fun () -> ok [] cpool#double);
+ "string" >::
+ (fun () -> ok [""; "Hello,world!!";"print"] cpool#string);
+ "namespace" >::
+ (fun () ->
+ match cpool#namespace with
+ [ns] ->
+ ok (`Namespace 1l) ns
+ | _ ->
+ assert_failure "list size is over");
+ "namespace set" >::
+ (fun () ->
+ ok [] cpool#ns_set);
+ "multiname" >::
+ (fun () ->
+ match cpool#multiname with
+ [`QName x;`QName y] ->
+ ok 1 (Int32.to_int x#ns);
+ ok 1 (Int32.to_int x#name);
+ ok 1 (Int32.to_int y#ns);
+ ok 3 (Int32.to_int y#name);
+ | _ ->
+ assert_failure "not qname")
+ ];
+ "method signature" >::
+ (fun () ->
+ match abc#methods with
+ [m] ->
+ ok [] m#param_types;
+ ok 0l m#return_type;
+ ok 1l m#name;
+ ok false m#need_activation;
+ ok false m#need_arguments;
+ ok false m#need_rest;
+ ok false m#set_dxns;
+ ok None m#options;
+ ok None m#param_names
+ | _ ->
+ assert_failure "over size");
+ "metadata test" >::
+ (fun () ->
+ ok [] abc#metadata);
+ "class and instance size has same size" >::
+ (fun () ->
+ ok (List.length abc#instances) (List.length abc#classes));
+ "instance" >::
+ (fun () ->
+ ok [] abc#instances);
+ "class" >::
+ (fun () ->
+ ok [] abc#classes);
+ "script" >::
+ (fun () ->
+ match abc#script with
+ [s] ->
+ ok 0l s#init;
+ ok [] s#traits
+ | _ ->
+ assert_failure "error");
+ "method body" >::
+ (fun () ->
+ match abc#method_body with
+ [m] ->
+ ok 0l m#methodi;
+ ok [] m#exceptions;
+ ok 1l m#local_count;
+ ok 0l m#init_scope_depth;
+ ok 1l m#max_scope_depth;
+ ok 2l m#max_stack;
+ ok [] m#traits;
+ flip ok m#code [
+ `GetLocal_0;
+ `PushScope;
+ `FindPropStrict 2l;
+ `PushString 2l;
+ `CallPropLex (2l,1l);
+ `Pop;
+ `ReturnVoid ]
+ | _ ->
+ assert_failure "error");
+ ]) +> run_test_tt_main
OSDN Git Service
