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)
%.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/'
module A = Asm.Make(LowInst)
-(*module C = Compile.Make(HighInst)*)
+module C = Compile.Make(HighInst)
name : string;
opcode : int;
args : string list;
- extra : string
+ extra : (string*string) list
}
(*
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 =
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 =
[] -> ""
| _::_ ->
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 =
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
]
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
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
| 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"
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
-NewFunction of method_(0x40) -> stack=1; method_=Some arg0
+NewFunction of method_(0x40) -> stack=1; method_=Some _0
NewClass of class_(0x58)
# Conversion
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
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
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