implements highInst

diff --git a/swflib/OMakefile b/swflib/OMakefile
index 9fa6a67..dc9139f 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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