scm/interCode.ml

   1 open Base
   2
   3 type entry = {
   4   symbols : (string list * string) list;
   5   methods : string list;
   6   modules : string list list;
   7   program : Ast.program
   8 }
   9
  10 let module_ name program : Ast.stmt' =
  11   `Module {Ast.module_name = Node.ghost name;
  12            exports         = `All;
  13            stmts           = program}
  14
  15 class t = object
  16   val entries = [] with reader
  17
  18   method mem_symbol (ns,name) =
  19     let file, sym =
  20       match ns with
  21           [] ->
  22             "stub",([],name)
  23         | x::xs ->
  24             x,(xs,name) in
  25       try
  26         let lazy {symbols=symbols} =
  27           List.assoc file entries in
  28           List.mem sym symbols
  29       with Not_found ->
  30         false
  31
  32   method mem_method meth =
  33     List.exists (fun (_,lazy {methods=methods}) ->
  34                    List.mem meth methods) entries
  35
  36   method mem_module name =
  37     match name with
  38         [] ->
  39           failwith "empty list"
  40       | file::ns ->
  41           try
  42             let lazy {modules=modules} =
  43               List.assoc file entries in
  44               List.mem ns modules
  45           with Not_found ->
  46             false
  47
  48   method to_ast =
  49     List.map (fun (name,lazy {program=program}) -> module_ name program) entries
  50
  51   method add name entry =
  52     {< entries = entries @ [name,entry] >}
  53 end
  54
  55 (* program -> table *)
  56 let empty =
  57   new t
  58
  59 let to_entry program= {
  60   symbols =
  61     program
  62     +> HList.concat_map Ast.public_symbols
  63     +> List.map Node.value;
  64   methods=
  65     program
  66     +> HList.concat_map Ast.public_methods
  67     +> List.map Node.value;
  68   modules =
  69     program
  70     +> HList.concat_map Ast.public_modules
  71     +> List.map Node.value;
  72   program =
  73     program
  74 }
  75
  76 let chop_suffix name suffix =
  77   if Filename.check_suffix name suffix then
  78     Filename.chop_suffix name suffix
  79   else
  80     name
  81
  82 let version = 2
  83
  84 let add name program table =
  85   table#add name @@ (lazy (to_entry program))
  86
  87 let input name path table =
  88   let entry _ =
  89     open_in_with path begin fun ch ->
  90     let version' =
  91       input_value ch in
  92       if version' = version then
  93         let symbols = input_value ch in
  94         let methods = input_value ch in
  95         let modules = input_value ch in
  96         let program = input_value ch in
  97           { symbols = symbols;
  98             methods = methods;
  99             modules = modules;
 100             program = program }
 101       else
 102         failwith ("invalid format:"^path)
 103     end in
 104     table#add name (lazy (entry ()))
 105
 106 let output name path table =
 107   table#entries
 108   +> List.assoc name
 109   +> (fun (lazy entry) ->
 110         open_out_with path begin fun ch ->
 111           output_value ch version;
 112           output_value ch entry.symbols;
 113           output_value ch entry.methods;
 114           output_value ch entry.modules;
 115           output_value ch entry.program
 116         end)