refactoring gen_typemap

diff --git a/swflib/gTree.ml b/swflib/gTree.ml
deleted file mode 100644 (file)
index d994073..0000000
--- a/swflib/gTree.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open Base
-
-module type S = sig
-  type 'a t
-  val is_leaf : 'a t -> bool
-  val subtree : 'a t -> 'a t list
-end
-
-module Make(S : S) = struct
-  open S
-
-  type 'a t = 'a S.t
-  let rec map ~leaf ~branch tree =
-    if is_leaf tree then
-      leaf tree
-    else
-      branch tree @@ List.map (map ~leaf ~branch) @@ subtree tree
-
-  let rec fold ~leaf ~branch init tree =
-    if is_leaf tree then
-      leaf init tree
-    else
-      branch tree @@ List.fold_left (fold ~leaf ~branch) init @@ subtree tree
-end

diff --git a/swflib/gTree.mli b/swflib/gTree.mli
deleted file mode 100644 (file)
index 07d5242..0000000
--- a/swflib/gTree.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-module type S =
-sig
-  type 'a t
-  val is_leaf : 'a t -> bool
-  val subtree : 'a t -> 'a t list
-end
-
-module Make :
-  functor (S : S) ->
-sig
-  type 'a t = 'a S.t
-
-  val map :
-    leaf:('a t -> 'b) ->
-    branch:('a t -> 'b list -> 'b) -> 'a t -> 'b
-  val fold :
-    leaf:('a -> 'b t -> 'a) ->
-    branch:('b t -> 'a -> 'a) -> 'a -> 'b t -> 'a
-end

diff --git a/swflib/gTreeTest.ml b/swflib/gTreeTest.ml
deleted file mode 100644 (file)
index 9ac656f..0000000
--- a/swflib/gTreeTest.ml
+++ /dev/null
@@ -1,59 +0,0 @@
-open OUnit
-open Base
-
-type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree
-
-module T = GTree.Make(
-  struct
-    type 'a t = 'a tree
-
-    let is_leaf =
-      function
-         Leaf _ -> true
-       | Branch _ -> false
-
-    let subtree =
-      function
-         Leaf _ -> []
-       | Branch (l,r) -> [l;r]
-
-  end)
-
-let ok =
-  assert_equal
-
-let _ =
-  ("gTree.ml" >:::[
-     "map/leaf" >::
-       (fun () ->
-         let leaf =
-           function
-               Leaf _ -> Leaf 42
-             | Branch _ as x -> x in
-         let branch tree xs =
-           match tree,xs with
-               Branch _ ,[l;r] ->
-                 Branch (l,r)
-             | Branch _,_ | Leaf _,_ ->
-                 failwith "must not happen" in
-           assert_equal (Leaf 42) @@
-             T.map ~leaf ~branch @@
-             Leaf 1;
-           assert_equal (Branch (Leaf 42,Leaf 42)) @@
-             T.map ~leaf ~branch @@
-             Branch (Leaf 1,Leaf 0));
-     "fold" >::
-       (fun () ->
-         let tree =
-           Branch (Leaf 0,Branch (Leaf 1,Leaf 2)) in
-         let leaf x =
-           function
-               Leaf n -> x+n
-             | Branch _ -> failwith "must not happen" in
-         let branch tree subtree =
-           match tree,subtree with
-             | Branch _, xs -> 1+xs
-             | Leaf _ ,_  -> failwith "must not happen" in
-           assert_equal 5 @@
-             T.fold ~leaf ~branch 0 tree)
-   ]) +> run_test_tt_main

diff --git a/swflib/gen_inst.ml b/swflib/gen_inst.ml
index 5949b45..7914304 100644 (file)
--- a/swflib/gen_inst.ml
+++ b/swflib/gen_inst.ml
@@ -126,12 +126,12 @@ let cmds = [
        match assoc "prefix" extra with
           Some "true" ->
             sprintf "[%s; u8 0x%x]"
-              (call_args "write" args)
+              (call_args "byte" args)
               opcode
         | Some _ | None ->
             sprintf "[u8 0x%x; %s]"
               opcode
-              (call_args "write" args) in
+              (call_args "byte" args) in
        sprintf "| %s -> %s" pat record
   end;
 

diff --git a/swflib/gen_typemap.ml b/swflib/gen_typemap.ml
index 13f3436..427c9c5 100644 (file)
--- a/swflib/gen_typemap.ml
+++ b/swflib/gen_typemap.ml
@@ -1,68 +1,117 @@
 open Base
-open Str
-open ExtList
 open Printf
 
-let write name ~ocaml ~byte =
-  printf "type %s = %s\n" name ocaml;
-  printf "let write_%s= %s\n" name byte
+let print_type name ocaml =
+  if name <> ocaml then
+    printf "type %s = %s\n" name ocaml
 
-let u30 name =
-  write name ~ocaml:"int" ~byte:"u30"
+let print_let  prefix name body =
+  printf "let %s_%s = %s\n" prefix name body
 
-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
+type map = (string*string) list
 
-let high name ~ocaml ~cpool ~arg =
-  printf "type %s = %s\n" name ocaml;
-  base name ~cpool ~arg ~clas:"None" ~meth:"None"
+type t = {
+  name:string;
+  types:map;
+  funs:map;
+}
 
-let lit name ~ocaml =
-  high name ~ocaml ~cpool:"None" ~arg:"_x"
+let (=>) a b = (a,b)
+let map = ref []
+let regist name ~low ~high ~funs =
+  map := {
+    name  = name;
+    types = ["low",low;"high",high];
+    funs  = funs
+  }::!map;;
 
-let cpool name ~ocaml ~entry =
-  high name ~ocaml
-    ~cpool:(sprintf "Some (%s _x)" entry)
-    ~arg:(sprintf "Cpool.index _ctx#cpool (%s _x)" entry)
+let none =
+  "fun _ -> None"
+
+let cpool name ~high ~entry =
+  regist name ~low:"int" ~high
+    ~funs:[
+      "byte"  => "u30";
+      "const" => sprintf "fun x -> Some (%s x)" entry;
+      "arg"   => sprintf "fun ctx x -> Cpool.index ctx#cpool (%s x)" entry;
+      "class" => none;
+      "method"=> none;
+    ];;
+
+let literal name =
+  regist name ~low:"int" ~high:"int"
+    ~funs:[
+      "byte"  => name;
+      "const" => none;
+      "arg"   => "fun _ -> id";
+      "class" => none;
+      "method"=> none;
+    ];;
+
+(* type regist *)
+regist "method_" ~low:"int" ~high:"method_"
+    ~funs:[
+      "byte" => "u30";
+      "const"  => none;
+      "method" => "fun x -> Some x";
+      "class"  => none;
+      "arg"    => "fun ctx x -> index x ctx#methods"
+    ];;
+
+regist "class_" ~low:"int" ~high:"class_"
+  ~funs:[
+    "byte" => "u30";
+    "const"  => none;
+    "method" => none;
+    "class"  => "fun x -> Some x";
+    "arg"    => "fun ctx x -> index x ctx#classes"
+  ];;
+
+literal "u8";;
+literal "u30";;
+regist "label" ~low:"(Label.t,int) either" ~high:"Label.t"
+  ~funs:[
+    "byte" => "function
+                   Left  label   -> label_ref label
+                 | Right address -> s24 address";
+    "const"  => none;
+    "method" => none;
+    "class"  => none;
+    "arg"    => "fun _ x -> Left x"
+  ];;
+
+regist "label_def" ~low:"Label.t" ~high:"Label.t"
+  ~funs:[
+    "byte" => "fun l ->label l";
+    "const"  => none;
+    "method" => none;
+    "class"  => none;
+    "arg"    => "fun _ -> id"
+  ];;
+
+cpool "c_int"     ~high:"int"             ~entry:"`Int";;
+cpool "c_uint"    ~high:"int"             ~entry:"`UInt";;
+cpool "c_string"  ~high:"string"          ~entry:"`String";;
+cpool "c_float"   ~high:"float"           ~entry:"`Double";;
+cpool "namespace" ~high:"Cpool.namespace" ~entry:"";;
+cpool "multiname" ~high:"Cpool.multiname" ~entry:"";;
+
+let print_field t fs =
+  ListLabels.iter !map ~f:begin fun {name;types;funs}->
+    print_type name @@ List.assoc t types;
+    List.iter (fun f -> print_let f name @@ List.assoc f funs) fs
+  end
 
 let _ =
   match Sys.argv.(1) with
       "-low" ->
-       u30 "method_";
-       u30 "class_";
-       u30 "c_int";
-       u30 "c_uint";
-       u30 "c_string";
-       u30 "c_float";
-       u30 "namespace";
-       u30 "multiname";
-       u30 "u30";
-       write "u8" ~ocaml:"int" ~byte:"u8";
-       write "label"
-         ~ocaml:"(Label.t,int) either"
-         ~byte:"function
-                   Left  label   -> label_ref label
-                 | Right address -> s24 address";
-       write "label_def"
-         ~ocaml:"Label.t"
-         ~byte:"fun l ->label l"
+       print_field "low" ["byte"]
     | "-high" ->
-       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";
-       high "label" ~ocaml:"Label.t" ~cpool:"None" ~arg:"Left _x";
-       high "label_def" ~ocaml:"Label.t" ~cpool:"None" ~arg:"_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";
+       print_field "high" ["const";
+                           "arg";
+                           "class";
+                           "method"]
     | _ ->
-       exit 1
+       failwith "usage: gen_typemap TYPE"
+
+