From: mzp Date: Sun, 13 Sep 2009 06:47:46 +0000 (+0900) Subject: implements highInst X-Git-Url: http://git.osdn.net/view?a=commitdiff_plain;h=32b6baa5f541ef9772933395b335cd71b9c8946a;p=happyabc%2Fhappyabc.git implements highInst --- diff --git a/swflib/OMakefile b/swflib/OMakefile index 9fa6a67..dc9139f 100644 --- a/swflib/OMakefile +++ b/swflib/OMakefile @@ -35,7 +35,7 @@ OCamlProgram(gen_typemap,gen_typemap) OUnitTest(label , label) OUnitTest(bytes , bytes label) OUnitTest(lowInst , lowInst bytes) -OUnitTest(highInst , highInst label) +OUnitTest(highInst , highInst label cpool revList) OUnitTest(asm , asm label bytes) OUnitTest(compile , compile cpool bytes label revList) OUnitTest(revList , revList) @@ -52,6 +52,12 @@ OCamlLibrary(swflib, $(FILES)) %.inst.h: gen_inst$(EXE) instruction.txt ./gen_inst$(EXE) -$> < instruction.txt > $@ +%.pat.h: gen_inst$(EXE) instruction.txt + ./gen_inst$(EXE) -pat $> < instruction.txt > $@ + +%.extra.h: gen_inst$(EXE) instruction.txt + ./gen_inst$(EXE) -extra $> < instruction.txt > $@ + .SCANNER: %.ml : %.mlp (grep "#include \"" $<;true) | sed 's/.*"\(.*\)".*/'$@': \1/' diff --git a/swflib/abc.ml b/swflib/abc.ml index c22853f..43f64d9 100644 --- a/swflib/abc.ml +++ b/swflib/abc.ml @@ -1,2 +1,2 @@ module A = Asm.Make(LowInst) -(*module C = Compile.Make(HighInst)*) +module C = Compile.Make(HighInst) diff --git a/swflib/gen_inst.ml b/swflib/gen_inst.ml index cdc2f38..677c76b 100644 --- a/swflib/gen_inst.ml +++ b/swflib/gen_inst.ml @@ -19,7 +19,7 @@ type decl = { name : string; opcode : int; args : string list; - extra : string + extra : (string*string) list } (* @@ -41,7 +41,7 @@ let parse_entry entry = name = matched_group 1 entry; args = []; opcode = of_hex @@ matched_group 2 entry; - extra = "" + extra = [] } else if string_match args entry 0 then let name,args,opcode = @@ -52,23 +52,28 @@ let parse_entry entry = name = name; args = split (regexp " *\\* *") args; opcode = of_hex @@ opcode; - extra = "" + extra = [] } else failwith ("Invalid entry: " ^ entry) +let split2 sep s = + match bounded_split (regexp sep) s 2 with + [a;b]-> + (a,b) + | [a] -> + (a,"") + | [] | _::_ -> + failwith ("Invalid format: " ^ s) + let parse_line s = if string_match (regexp "^#\\|^$") s 0 then None else - match bounded_split (regexp " *-> *") s 2 with - [entry; extra] -> - Some {parse_entry entry with - extra = extra} - | [entry] -> - Some (parse_entry entry) - | [] | _::_ -> - failwith ("Invalid format: " ^ s) + let (entry,extra) = + split2 " *-> *" s in + Some {parse_entry entry with + extra = List.map (split2 " *= *") @@ split (regexp " *; *") extra} let parse ch = let decls = @@ -95,20 +100,20 @@ let make_pat name args = [] -> "" | _::_ -> sprintf "(%s)" @@ - concat_mapi "," (fun _ i -> sprintf "arg%d" i) args) + concat_mapi "," (fun _ i -> sprintf "_%d" i) args) -let call_args prefix args = - concat_mapi ";" (sprintf "%s_%s arg%d" prefix) args +let call_args prefix args = + concat_mapi ";" (sprintf "%s_%s _%d" prefix) args let cmds = [ - begin "-type",fun {name=name; args=args}-> + begin "-type",fun {name; args}-> if args = [] then sprintf "| `%s" name else sprintf "| `%s of %s" name @@ String.concat "*" args end; - begin "-asm",fun {name=name; opcode=opcode; args=args} -> + begin "-asm",fun {name; opcode; args} -> let pat = make_pat name args in let record = @@ -118,11 +123,29 @@ let cmds = [ sprintf "| %s -> %s" pat record end; - begin "-const",fun {name=name; args=args} -> + begin "-compile",fun {name;args}-> + let pat = + make_pat name args in + let args' = + if args = [] then + "" + else + sprintf "(%s)" @@ concat_mapi "," (sprintf "arg_%s ctx _%d") args in + sprintf "| %s -> `%s %s" pat name args' + end; + begin "-pat",fun {name; args} -> + let pat = + make_pat name args in + sprintf "| %s -> [%s]" pat @@ + call_args Sys.argv.(2) args + end; + begin "-extra",fun {name; args;extra} -> let pat = make_pat name args in - sprintf "| %s -> some_only [%s]" pat @@ - call_args "c" args + try + sprintf "| %s -> %s" pat @@ List.assoc Sys.argv.(2) extra + with Not_found -> + sprintf "| %s -> default" pat end ] diff --git a/swflib/gen_typemap.ml b/swflib/gen_typemap.ml index 29ec44b..838ca47 100644 --- a/swflib/gen_typemap.ml +++ b/swflib/gen_typemap.ml @@ -10,18 +10,23 @@ let write name ~ocaml ~byte = let u30 name = write name ~ocaml:"int" ~byte:"u30" -let base name ~cpool= - printf "let c_%s _x = %s\n" name cpool +let base name ~cpool ~arg ~clas ~meth = + printf "let const_%s _x = (%s :> Cpool.entry option)\n" name cpool; + printf "let arg_%s _ctx _x = %s\n" name arg; + printf "let class_%s _x = %s\n" name clas; + printf "let method_%s _x = %s\n" name meth -let high name ~ocaml ~cpool = +let high name ~ocaml ~cpool ~arg = printf "type %s = %s\n" name ocaml; - base name ~cpool + base name ~cpool ~arg ~clas:"None" ~meth:"None" let lit name ~ocaml = - high name ~ocaml ~cpool:"None" + high name ~ocaml ~cpool:"None" ~arg:"_x" let cpool name ~ocaml ~entry = - high name ~ocaml ~cpool:(sprintf "Some (`%s _x)" entry) + high name ~ocaml + ~cpool:(sprintf "Some (%s _x)" entry) + ~arg:(sprintf "Cpool.index _ctx#cpool (%s _x)" entry) let _ = match Sys.argv.(1) with @@ -42,17 +47,18 @@ let _ = Left label -> label_ref label | Right address -> s24 address" | "-high" -> - cpool "c_int" ~ocaml:"int" ~entry:"Int"; - cpool "c_uint" ~ocaml:"int" ~entry:"Int"; - cpool "c_string" ~ocaml:"string" ~entry:"String"; - cpool "c_float" ~ocaml:"float" ~entry:"Double"; - cpool "namespace" ~ocaml:"Cpool.namespace" ~entry:"Namespace"; - cpool "multiname" ~ocaml:"Cpool.multiname" ~entry:"Multiname"; - lit "label" ~ocaml:"Label.t"; + cpool "c_int" ~ocaml:"int" ~entry:"`Int"; + cpool "c_uint" ~ocaml:"int" ~entry:"`UInt"; + cpool "c_string" ~ocaml:"string" ~entry:"`String"; + cpool "c_float" ~ocaml:"float" ~entry:"`Double"; + cpool "namespace" ~ocaml:"Cpool.namespace" ~entry:""; + cpool "multiname" ~ocaml:"Cpool.multiname" ~entry:""; lit "u30" ~ocaml:"int"; lit "u8" ~ocaml:"int"; - base "label" ~cpool:"None"; - base "method_" ~cpool:"None"; - base "class_" ~cpool:"None"; + high "label" ~ocaml:"Label.t" ~cpool:"None" ~arg:"Left _x"; + base "method_" ~cpool:"None" ~arg:"index _x _ctx#methods" + ~clas:"None" ~meth:"Some _x"; + base "class_" ~cpool:"None" ~arg:"index _x _ctx#classes" + ~clas:"Some _x" ~meth:"None"; | _ -> exit 1 diff --git a/swflib/highInst.mlp b/swflib/highInst.mlp index 7ccc3db..3ad226e 100644 --- a/swflib/highInst.mlp +++ b/swflib/highInst.mlp @@ -20,6 +20,33 @@ let rec some_only = | Some x::xs -> x::some_only xs -let const = -function -#include "const.inst.h" +let option_of_list = + function + [] -> None + | x::_ -> Some x + +let inst ctx : s -> t = + function +#include "compile.inst.h" + +let const inst = + some_only @@ match inst with +#include "const.pat.h" + +let default = 0 + +let stack = + function +#include "stack.extra.h" + +let scope = + function +#include "scope.extra.h" + +let method_ inst = + option_of_list @@ some_only @@ match inst with +#include "method.pat.h" + +let class_ inst = + option_of_list @@ some_only @@ match inst with +#include "class.pat.h" diff --git a/swflib/highInstTest.ml b/swflib/highInstTest.ml index 100462a..600369c 100644 --- a/swflib/highInstTest.ml +++ b/swflib/highInstTest.ml @@ -2,10 +2,60 @@ open Base open OUnit open HighInst +let ctx = {| + cpool = Cpool.add_list Cpool.empty [ + `Int 42; + ]; + methods = []; + classes = [] +|};; + +let m = { + MethodType.method_attrs = []; + method_name = `QName (`Namespace "",""); + params = []; + return = 0; + method_flags = 0; + code = []; + traits = []; + exceptions = []; + fun_scope = `Global +} + +let c = { + MethodType.class_name = `QName (`Namespace "","Foo"); + super = `QName (`Namespace "","Object"); + class_flags= [`Sealed]; + cinit = m; + iinit = m; + interface = []; + instance_methods = []; + static_methods = []; + attrs = []; +} let _ = ("highInst.ml" >::: [ + "inst" >:: + (fun () -> + assert_equal (`PushInt 1) @@ inst ctx (`PushInt 42)); "const" >:: (fun () -> - assert_equal [`Int 42] (HighInst.const (`PushInt 42)); - assert_equal [`String "foo"] (HighInst.const (`PushString "foo"))) + assert_equal [`Int 42] @@ const (`PushInt 42); + assert_equal [`String "foo"] @@ const (`PushString "foo")); + "stack" >:: + (fun () -> + assert_equal 1 @@ stack (`PushInt 42); + assert_equal 0 @@ stack `Nop); + "scope" >:: + (fun () -> + assert_equal 1 @@ scope `PushScope; + assert_equal 0 @@ scope `Nop); + "method" >:: + (fun () -> + assert_equal (Some m) @@ method_ (`NewFunction m); + assert_equal None @@ method_ (`Nop)); + "class" >:: + (fun () -> + assert_equal (Some c) @@ class_ (`NewClass c); + assert_equal None @@ class_ `Nop); ]) +> run_test_tt_main diff --git a/swflib/instruction.txt b/swflib/instruction.txt index 2bcfa85..6a7b2b0 100644 --- a/swflib/instruction.txt +++ b/swflib/instruction.txt @@ -1,4 +1,4 @@ -NewFunction of method_(0x40) -> stack=1; method_=Some arg0 +NewFunction of method_(0x40) -> stack=1; method_=Some _0 NewClass of class_(0x58) # Conversion @@ -31,7 +31,7 @@ GreaterThan(0xaf) -> stack= ~-1 GreaterEquals(0xb0) -> stack= ~-1 # Jump/Conditonal Jump -Label of label(0x09) -> prefix=const [label arg0];args=const [] +Label of label(0x09) -> prefix=const [label _0];_s=const [] IfNlt of label(0x0c) -> stack= ~-1 IfNle of label(0x0d) -> stack= ~-1 IfNgt of label(0x0e) -> stack= ~-1 @@ -73,7 +73,7 @@ GetLocal_0(0xD0) -> stack=1;count=1 GetLocal_1(0xD1) -> stack=1;count=2 GetLocal_2(0xD2) -> stack=1;count=3 GetLocal_3(0xD3) -> stack=1;count=4 -GetLocal of u30(0x62) -> stack=1;count=(arg0+1) +GetLocal of u30(0x62) -> stack=1;count=(_0+1) SetLocal_0(0xD4) -> stack=1 SetLocal_1(0xD5) -> stack=1 SetLocal_2(0xD6) -> stack=1 @@ -95,19 +95,19 @@ InitProperty of multiname(0x68) -> stack= ~-2 ReturnVoid(0x47) ReturnValue(0x48) -> stack= ~-1 FindPropStrict of multiname(0x5D) -> stack=1 -CallProperty of multiname * u30(0x46) -> stack= 1-arg1 -CallPropLex of multiname * u30(0x4c) -> stack= 1-arg1 -Call of u30(0x41) -> stack= 1-(2+arg0) +CallProperty of multiname * u30(0x46) -> stack= 1-_1 +CallPropLex of multiname * u30(0x4c) -> stack= 1-_1 +Call of u30(0x41) -> stack= 1-(2+_0) Pop(0x29) -> stack= ~-1 Swap(0x2b) PopScope(0x1d) -> scope= ~-1 -NewObject of u30(0x55) -> stack=1-arg0 +NewObject of u30(0x55) -> stack=1-_0 NewArray of u30(0x56) NewActivation(0x57) -> stack=1 Dup(0x2a) -> stack= 2 Nop(0x02) # Class -ConstructSuper of u30(0x49) -> stack= ~-(arg0+1) -ConstructProp of multiname*u30(0x4a) -> stack= ~-arg1 +ConstructSuper of u30(0x49) -> stack= ~-(_0+1) +ConstructProp of multiname*u30(0x4a) -> stack= ~-_1