swflib/gen_typemap.ml

   1 open Base
   2 open Printf
   3
   4 let print_type name ocaml =
   5   if name <> ocaml then
   6     printf "type %s = %s\n" name ocaml
   7
   8 let print_let  prefix name body =
   9   printf "let %s_%s = %s\n" prefix name body
  10
  11 type map = (string*string) list
  12
  13 type t = {
  14   name:string;
  15   types:map;
  16   funs:map;
  17 }
  18
  19 let (=>) a b = (a,b)
  20 let map = ref []
  21 let regist name ~low ~high ~funs =
  22   map := {
  23     name  = name;
  24     types = ["low",low;"high",high];
  25     funs  = funs
  26   }::!map;;
  27
  28 let none =
  29   "fun _ -> None"
  30
  31 let cpool name ~high ~entry =
  32   regist name ~low:"int" ~high
  33     ~funs:[
  34       "byte"  => "BytesOut.u30";
  35       "read"  => "BytesIn.u30";
  36       "const" => sprintf "fun x -> Some ((%s x) :> Cpool.entry)" entry;
  37       "arg"   => sprintf "fun ctx x -> Cpool.index ctx#cpool (%s x)" entry;
  38       "class" => none;
  39       "method"=> none;
  40     ];;
  41
  42 let literal name =
  43   regist name ~low:"int" ~high:"int"
  44     ~funs:[
  45       "byte"  => sprintf "BytesOut.%s" name;
  46       "read"  => sprintf "BytesIn.%s"  name;
  47       "const" => none;
  48       "arg"   => "fun _ -> id";
  49       "class" => none;
  50       "method"=> none;
  51     ];;
  52
  53 (* type regist *)
  54 regist "method_" ~low:"int" ~high:"method_"
  55     ~funs:[
  56       "byte" => "BytesOut.u30";
  57       "read" => "BytesIn.u30";
  58       "const"  => none;
  59       "method" => "fun x -> Some x";
  60       "class"  => none;
  61       "arg"    => "fun ctx x -> index x ctx#methods"
  62     ];;
  63
  64 regist "class_" ~low:"int" ~high:"class_"
  65   ~funs:[
  66     "byte" => "BytesOut.u30";
  67     "read" => "BytesIn.u30";
  68     "const"  => none;
  69     "method" => none;
  70     "class"  => "fun x -> Some x";
  71     "arg"    => "fun ctx x -> index x ctx#classes"
  72   ];;
  73
  74 literal "u8";;
  75 literal "u30";;
  76 regist "label" ~low:"(Label.t,int) either" ~high:"Label.t"
  77   ~funs:[
  78     "byte" => "function
  79                    Left  label   -> label_ref label
  80                  | Right address -> s24 address";
  81     "read"   => "fun s -> Right (BytesIn.s24 s)";
  82     "const"  => none;
  83     "method" => none;
  84     "class"  => none;
  85     "arg"    => "fun _ x -> Left x"
  86   ];;
  87
  88 regist "label_def" ~low:"Label.t" ~high:"Label.t"
  89   ~funs:[
  90     "byte" => "fun l ->label l";
  91     "read"   => "fun _ -> Label.make()";
  92     "const"  => none;
  93     "method" => none;
  94     "class"  => none;
  95     "arg"    => "fun _ -> id"
  96   ];;
  97
  98 cpool "c_int"     ~high:"int"             ~entry:"`Int";;
  99 cpool "c_uint"    ~high:"int"             ~entry:"`UInt";;
 100 cpool "c_string"  ~high:"string"          ~entry:"`String";;
 101 cpool "c_float"   ~high:"float"           ~entry:"`Double";;
 102 cpool "namespace" ~high:"Cpool.namespace" ~entry:"";;
 103 cpool "multiname" ~high:"Cpool.multiname" ~entry:"";;
 104
 105 let print_field t fs =
 106   ListLabels.iter !map ~f:begin fun {name;types;funs}->
 107     print_type name @@ List.assoc t types;
 108     List.iter (fun f -> print_let f name @@ List.assoc f funs) fs
 109   end
 110
 111 let _ =
 112   match Sys.argv.(1) with
 113       "-low" ->
 114         print_field "low" ["byte";"read"]
 115     | "-high" ->
 116         print_field "high" ["const";
 117                             "arg";
 118                             "class";
 119                             "method"]
 120     | _ ->
 121         failwith "usage: gen_typemap TYPE"
 122
 123