Commits

camlspotter committed efe7f18

more precise redundant open analysis with more diffs

Comments (0)

Files changed (1)

   | Env_cltype of summary * Ident.t * cltype_declaration
   | Env_open of summary * Path.t
 
+type 'a with_open = 'a * Path.t option
+
 type t = {
-  values: (Path.t * value_description) Ident.tbl;
-  annotations: (Path.t * Annot.ident) Ident.tbl;
-  constrs: (Path.t * constructor_description) Ident.tbl;
-  labels: (Path.t * label_description) Ident.tbl;
-  types: (Path.t * type_declaration) Ident.tbl;
-  modules: (Path.t * module_type) Ident.tbl;
-  modtypes: (Path.t * modtype_declaration) Ident.tbl;
-  components: (Path.t * module_components) Ident.tbl;
-  classes: (Path.t * class_declaration) Ident.tbl;
-  cltypes: (Path.t * cltype_declaration) Ident.tbl;
+  values: (Path.t * value_description) with_open Ident.tbl;
+  annotations: (Path.t * Annot.ident) with_open Ident.tbl;
+  constrs: constructor_description with_open Ident.tbl;
+  labels: label_description with_open Ident.tbl;
+  types: (Path.t * type_declaration) with_open Ident.tbl;
+  modules: (Path.t * module_type) with_open Ident.tbl;
+  modtypes: (Path.t * modtype_declaration) with_open Ident.tbl;
+  components: (Path.t * module_components) with_open Ident.tbl;
+  classes: (Path.t * class_declaration) with_open Ident.tbl;
+  cltypes: (Path.t * cltype_declaration) with_open Ident.tbl;
   summary: summary
 }
 
     Pident _ -> true
   | Pdot _ | Papply _ -> false
 
-let is_local (p, _) = is_ident p
+let is_local ((p, _),_) = is_ident p
 
 let is_local_exn = function
-    (_, {cstr_tag = Cstr_exception p}) -> is_ident p
+    ({cstr_tag = Cstr_exception p}, _) -> is_ident p
   | _ -> false
 
 let diff env1 env2 =
   match path with
     Pident id ->
       begin try
-        let (p, desc) = Ident.find_same id env.components
+        let (p, desc),_ = Ident.find_same id env.components
         in desc
       with Not_found ->
         if Ident.persistent id
 let find proj1 proj2 path env =
   match path with
     Pident id ->
-      let (p, data) = Ident.find_same id (proj1 env)
+      let (p, data),_ = Ident.find_same id (proj1 env)
       in data
   | Pdot(p, s, pos) ->
       begin match Lazy.force(find_module_descr p env) with
   match path with
     Pident id ->
       begin try
-        let (p, data) = Ident.find_same id env.modules
+        let (p, data),_ = Ident.find_same id env.modules
         in data
       with Not_found ->
         if Ident.persistent id then
 
 (* Lookup by name *)
 
+let modules_opened_but_not_used_yet = Hashtbl.create 103
+(* CR jfuruse: not sure about the place. debugger/Makefile.shared required additional modules for this *)
+let check_modules_opened_but_not_used_yet () =
+  Hashtbl.iter (fun k _ ->
+    match k with
+    | Pident id when Ident.name id = "Pervasives" -> () (* CR jfuruse: this is bogus *)
+    | _ -> 
+        Location.prerr_warning Location.none (Warnings.Opened_module_is_never_used (Path.name k))) 
+    modules_opened_but_not_used_yet;
+  Hashtbl.clear modules_opened_but_not_used_yet
+
+let mark_opened_module (v, open_info) =
+  begin match open_info with
+  | None -> ()
+  | Some p -> Hashtbl.remove modules_opened_but_not_used_yet p
+  end;
+  v
+
 let rec lookup_module_descr lid env =
   match lid with
     Lident s ->
       begin try
-        Ident.find_name s env.components
+        mark_opened_module (Ident.find_name s env.components)
       with Not_found ->
         if s = !current_unit then raise Not_found;
         let ps = find_pers_struct s in
   match lid with
     Lident s ->
       begin try
-        Ident.find_name s env.modules
+        mark_opened_module (Ident.find_name s env.modules)
       with Not_found ->
         if s = !current_unit then raise Not_found;
         let ps = find_pers_struct s in
           raise Not_found
       end
 
-let modules_opened_but_not_used_yet = Hashtbl.create 103
-(* CR jfuruse: not sure about the place. debugger/Makefile.shared required additional modules for this *)
-let check_modules_opened_but_not_used_yet () =
-  Hashtbl.iter (fun k _ ->
-    match k with
-    | Pident id when Ident.name id = "Pervasives" -> () (* CR jfuruse: this is bogus *)
-    | _ -> 
-        Location.prerr_warning Location.none (Warnings.Opened_module_is_never_used (Path.name k))) 
-    modules_opened_but_not_used_yet;
-  Hashtbl.clear modules_opened_but_not_used_yet
-
 (* CR jfuruse: copied from Printtyp.longident *)
 let format_longident ppf lid = 
   let open Format in
 
 let lookup proj1 proj2 lid env =
   match lid with
-    Lident s -> Ident.find_name s (proj1 env)
+    Lident s -> mark_opened_module (Ident.find_name s (proj1 env))
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr l env in
       begin match Lazy.force desc with
   | Lapply(l1, l2) ->
       raise Not_found
 
-let lookup proj1 proj2 lid env =
-  let (p, d) = lookup proj1 proj2 lid env in
-  (* jfuruse Format.eprintf "%a %s@." format_longident lid (Path.unique_name p); *)
-  begin match p with
-  | Pdot (t, _, _) -> Hashtbl.remove modules_opened_but_not_used_yet t
-  | Pident _ | Papply _ -> ()
-  end;
-  p, d
-
 let lookup_simple proj1 proj2 lid env =
   match lid with
     Lident s ->
-      Ident.find_name s (proj1 env)
+      mark_opened_module (Ident.find_name s (proj1 env))
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr l env in
       begin match Lazy.force desc with
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
 let lookup_annot id e =
   lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
-and lookup_constructor lid env =
-  snd (lookup (fun env -> env.constrs) (fun sc -> sc.comp_constrs) lid env)
-and lookup_label lid env =
-  snd (lookup (fun env -> env.labels) (fun sc -> sc.comp_labels) lid env)
+and lookup_constructor =
+  lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+and lookup_label =
+  lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
 and lookup_type =
   lookup (fun env -> env.types) (fun sc -> sc.comp_types)
 and lookup_modtype =
 
 (* Insertion of bindings by identifier + path *)
 
-and store_value id path decl env =
+and store_value ?opened id path decl env =
   { env with
-    values = Ident.add id (path, decl) env.values;
+    values = Ident.add id ((path, decl), opened) env.values;
     summary = Env_value(env.summary, id, decl) }
 
-and store_annot id path annot env =
+and store_annot ?opened id path annot env =
   if !Clflags.annotations then
     { env with
-      annotations = Ident.add id (path, annot) env.annotations }
+      annotations = Ident.add id ((path, annot), opened) env.annotations }
   else env
 
-and store_type id path info env =
+and store_type ?opened id path info env =
   { env with
     constrs =
       List.fold_right
         (fun (name, descr) constrs ->
-          Ident.add (Ident.create name) (path, descr) constrs)
+          Ident.add (Ident.create name) (descr, opened) constrs)
         (constructors_of_type path info)
         env.constrs;
     labels =
       List.fold_right
         (fun (name, descr) labels ->
-          Ident.add (Ident.create name) (path, descr) labels)
+          Ident.add (Ident.create name) (descr, opened) labels)
         (labels_of_type path info)
         env.labels;
-    types = Ident.add id (path, info) env.types;
+    types = Ident.add id ((path, info), opened) env.types;
     summary = Env_type(env.summary, id, info) }
 
-and store_type_infos id path info env =
+and store_type_infos ?opened id path info env =
   (* Simplified version of store_type that doesn't compute and store
      constructor and label infos, but simply record the arity and
      manifest-ness of the type.  Used in components_of_module to
      keep track of type abbreviations (e.g. type t = float) in the
      computation of label representations. *)
   { env with
-    types = Ident.add id (path, info) env.types;
+    types = Ident.add id ((path, info), opened) env.types;
     summary = Env_type(env.summary, id, info) }
 
-and store_exception id path decl env =
+and store_exception ?opened id path decl env =
   { env with
-    constrs = Ident.add id (path, Datarepr.exception_descr path decl) env.constrs;
+    constrs = Ident.add id (Datarepr.exception_descr path decl, opened) env.constrs;
     summary = Env_exception(env.summary, id, decl) }
 
-and store_module id path mty env =
+and store_module ?opened id path mty env =
   { env with
-    modules = Ident.add id (path, mty) env.modules;
+    modules = Ident.add id ((path, mty), opened) env.modules;
     components =
-      Ident.add id (path, components_of_module env Subst.identity path mty)
+      Ident.add id ((path, components_of_module env Subst.identity path mty), opened)
                    env.components;
     summary = Env_module(env.summary, id, mty) }
 
-and store_modtype id path info env =
+and store_modtype ?opened id path info env =
   { env with
-    modtypes = Ident.add id (path, info) env.modtypes;
+    modtypes = Ident.add id ((path, info), opened) env.modtypes;
     summary = Env_modtype(env.summary, id, info) }
 
-and store_class id path desc env =
+and store_class ?opened id path desc env =
   { env with
-    classes = Ident.add id (path, desc) env.classes;
+    classes = Ident.add id ((path, desc), opened) env.classes;
     summary = Env_class(env.summary, id, desc) }
 
-and store_cltype id path desc env =
+and store_cltype ?opened id path desc env =
   { env with
-    cltypes = Ident.add id (path, desc) env.cltypes;
+    cltypes = Ident.add id ((path, desc), opened) env.cltypes;
     summary = Env_cltype(env.summary, id, desc) }
 
 (* Compute the components of a functor application in a path. *)
       (fun env item p ->
         match item with
           Tsig_value(id, decl) ->
-            let e1 = store_value (Ident.hide id) p
+            let e1 = store_value ~opened:root (Ident.hide id) p
                         (Subst.value_description sub decl) env
             in store_annot (Ident.hide id) p (Annot.Iref_external) e1
         | Tsig_type(id, decl, _) ->
-            store_type (Ident.hide id) p
+            store_type ~opened:root (Ident.hide id) p
                        (Subst.type_declaration sub decl) env
         | Tsig_exception(id, decl) ->
-            store_exception (Ident.hide id) p
+            store_exception ~opened:root (Ident.hide id) p
                             (Subst.exception_declaration sub decl) env
         | Tsig_module(id, mty, _) ->
-            store_module (Ident.hide id) p (Subst.modtype sub mty) env
+            store_module ~opened:root (Ident.hide id) p (Subst.modtype sub mty) env
         | Tsig_modtype(id, decl) ->
-            store_modtype (Ident.hide id) p
+            store_modtype ~opened:root (Ident.hide id) p
                           (Subst.modtype_declaration sub decl) env
         | Tsig_class(id, decl, _) ->
-            store_class (Ident.hide id) p
+            store_class ~opened:root (Ident.hide id) p
                         (Subst.class_declaration sub decl) env
         | Tsig_cltype(id, decl, _) ->
-            store_cltype (Ident.hide id) p
+            store_cltype ~opened:root (Ident.hide id) p
                          (Subst.cltype_declaration sub decl) env)
       env sg pl in
   { newenv with summary = Env_open(env.summary, root) }