1 files changed, 79 insertions, 74 deletions
diff --git a/typing/env.ml b/typing/env.ml
index 9e825d87a..e72272dcd 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -26,6 +26,7 @@ type error =
     Not_an_interface of string
   | Corrupted_interface of string
   | Illegal_renaming of string * string
+  | Inconsistent_import of string * string * string
 
 exception Error of error
 
@@ -86,8 +87,7 @@ type pers_struct =
   { ps_name: string;
     ps_sig: signature;
     ps_comps: module_components;
-    ps_crc: Digest.t;
-    mutable ps_used: bool }
+    ps_crcs: (string * Digest.t) list }
 
 let persistent_structures =
   (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
@@ -102,15 +102,15 @@ let read_pers_struct modname filename =
       raise(Error(Not_an_interface filename))
     end;
     let (name, sign, comps) = input_value ic in
+    let crcs = input_value ic in
+    close_in ic;
     let ps = { ps_name = name;
                ps_sig = sign;
                ps_comps = comps;
-               ps_crc = Digest.input ic;
-               ps_used = false }
-    in
-    close_in ic;
+               ps_crcs = crcs } in
     if ps.ps_name <> modname then
       raise(Error(Illegal_renaming(ps.ps_name, filename)));
+    Hashtbl.add persistent_structures modname ps;
     ps
   with End_of_file | Failure _ ->
     close_in ic;
@@ -120,13 +120,8 @@ let find_pers_struct name =
   try
     Hashtbl.find persistent_structures name
   with Not_found ->
-    let ps =
-      read_pers_struct name
-        (find_in_path !load_path (String.uncapitalize name ^ ".cmi")) in
-    Hashtbl.add persistent_structures name ps;
-    ps
-
-let mark_used = function None -> () | Some ps -> ps.ps_used <- true
+    read_pers_struct name
+      (find_in_path !load_path (String.uncapitalize name ^ ".cmi"))
 
 let reset_cache() =
   Hashtbl.clear persistent_structures
@@ -149,66 +144,62 @@ let rec find_module_descr path env =
     Pident id ->
       begin try
         let (p, desc) = Ident.find_same id env.components
-        in (desc, None)
+        in desc
       with Not_found ->
-        if Ident.persistent id then
-          let ps = find_pers_struct (Ident.name id) in (ps.ps_comps, Some ps)
+        if Ident.persistent id
+        then (find_pers_struct (Ident.name id)).ps_comps
         else raise Not_found
       end
   | Pdot(p, s, pos) ->
       begin match find_module_descr p env with
-      	(Structure_comps c, ps) ->
+      	Structure_comps c ->
 	  let (descr, pos) = Tbl.find s c.comp_components in
-          (descr, ps)
-      | (Functor_comps f, _) ->
+          descr
+      | Functor_comps f ->
       	 raise Not_found
       end
   | Papply(p1, p2) ->
       begin match find_module_descr p1 env with
-      	(Functor_comps f, ps) ->
-          (!components_of_functor_appl f p1 p2, ps)
-      | (Structure_comps c, _) ->
+      	Functor_comps f ->
+          !components_of_functor_appl f p1 p2
+      | Structure_comps c ->
       	  raise Not_found
       end
 
-let find proj1 proj2 filter path env =
+let find proj1 proj2 path env =
   match path with
     Pident id ->
       let (p, data) = Ident.find_same id (proj1 env)
-      in filter data None
+      in data
   | Pdot(p, s, pos) ->
       begin match find_module_descr p env with
-        (Structure_comps c, ps) ->
-          let (data, pos) = Tbl.find s (proj2 c) in filter data ps
-      | (Functor_comps f, _) ->
+        Structure_comps c ->
+          let (data, pos) = Tbl.find s (proj2 c) in data
+      | Functor_comps f ->
           raise Not_found
       end
   | Papply(p1, p2) ->
       raise Not_found
 
-let strict_filter data ps =
-  mark_used ps; data
-
 let find_value =
-  find (fun env -> env.values) (fun sc -> sc.comp_values) strict_filter
+  find (fun env -> env.values) (fun sc -> sc.comp_values)
 and find_type =
-  find (fun env -> env.types) (fun sc -> sc.comp_types) strict_filter
-and find_modtype =
-  find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) strict_filter
-and find_class =
-  find (fun env -> env.classes) (fun sc -> sc.comp_classes) strict_filter
-and find_type_expansion =
   find (fun env -> env.types) (fun sc -> sc.comp_types)
-    (fun decl ps ->
-       match decl.type_manifest with
-         None      -> raise Not_found
-       | Some body -> mark_used ps; (decl.type_params, body))
-and find_modtype_expansion =
+and find_modtype =
   find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
-    (fun def ps ->
-       match def with
-         Tmodtype_abstract     -> raise Not_found
-       | Tmodtype_manifest mty -> mark_used ps; mty)
+and find_class =
+  find (fun env -> env.classes) (fun sc -> sc.comp_classes)
+
+let find_type_expansion path env =
+  let decl = find_type path env in
+  match decl.type_manifest with
+    None      -> raise Not_found
+  | Some body -> (decl.type_params, body)
+
+let find_modtype_expansion path env =
+  match find_modtype path env with
+    Tmodtype_abstract     -> raise Not_found
+  | Tmodtype_manifest mty -> mty
 
 let find_module path env =
   match path with
@@ -219,15 +210,14 @@ let find_module path env =
       with Not_found ->
         if Ident.persistent id then
           let ps = find_pers_struct (Ident.name id) in
-          ps.ps_used <- true; Tmty_signature(ps.ps_sig)
+          Tmty_signature(ps.ps_sig)
         else raise Not_found
       end
   | Pdot(p, s, pos) ->
       begin match find_module_descr p env with
-        (Structure_comps c, ps) ->
-          mark_used ps;
+        Structure_comps c ->
           let (data, pos) = Tbl.find s c.comp_modules in data
-      | (Functor_comps f, _) ->
+      | Functor_comps f ->
           raise Not_found
       end
   | Papply(p1, p2) ->
@@ -242,7 +232,6 @@ let rec lookup_module_descr lid env =
         Ident.find_name s env.components
       with Not_found ->
         let ps = find_pers_struct s in
-        ps.ps_used <- true;
         (Pident(Ident.create_persistent s), ps.ps_comps)
       end
   | Ldot(l, s) ->
@@ -272,7 +261,6 @@ and lookup_module lid env =
         Ident.find_name s env.modules
       with Not_found ->
         let ps = find_pers_struct s in
-        ps.ps_used <- true;
         (Pident(Ident.create_persistent s), Tmty_signature ps.ps_sig)
       end
   | Ldot(l, s) ->
@@ -684,47 +672,58 @@ let open_signature root sg env =
 
 let open_pers_signature name env =
   let ps = find_pers_struct name in
-  ps.ps_used <- true;
   open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env
 
 (* Read a signature from a file *)
 
 let read_signature modname filename =
-  let ps = read_pers_struct modname filename in (ps.ps_sig, ps.ps_crc)
+  let ps = read_pers_struct modname filename in ps.ps_sig
 
-(* Save a signature to a file *)
+(* Return the list of imported interfaces with their CRCs *)
 
-let dummy_crc = Digest.string ""
+let imported_units() =
+  let imported_units =
+    ref ([] : (string * Digest.t) list) in
+  let units_xref =
+    (Hashtbl.create 13 : (string, Digest.t * string) Hashtbl.t) in
+  let add_unit source (name, crc) =
+    try
+      let (oldcrc, oldsource) = Hashtbl.find units_xref name in
+      if oldcrc <> crc then
+        raise(Error(Inconsistent_import(name, oldsource, source)))
+    with Not_found ->
+      Hashtbl.add units_xref name (crc, source);
+      imported_units := (name, crc) :: !imported_units in
+  Hashtbl.iter
+    (fun name ps -> List.iter (add_unit ps.ps_name) ps.ps_crcs)
+    persistent_structures;
+  !imported_units
+
+(* Save a signature to a file *)
 
 let save_signature sg modname filename =
   Btype.cleanup_abbrev ();
   let oc = open_out_bin filename in
   output_string oc cmi_magic_number;
-  output_value oc
-    (modname, sg,
-     components_of_module empty Subst.identity
-       (Pident(Ident.create_persistent modname)) (Tmty_signature sg));
+  let comps =
+    components_of_module empty Subst.identity
+       (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in
+  output_value oc (modname, sg, comps);
   flush oc;
   let crc = Digest.file filename in
-  Digest.output oc crc;
+  let crcs = (modname, crc) :: imported_units() in
+  output_value oc crcs;
   close_out oc;
-  crc
+  (* Enter signature in persistent table so that imported_unit()
+     will also return its crc *)
+  let ps =
+    { ps_name = modname; ps_sig = sg; ps_comps = comps; ps_crcs = crcs } in
+  Hashtbl.add persistent_structures modname ps
 
 (* Make the initial environment *)
 
 let initial = Predef.build_initial_env add_type add_exception empty
 
-(* Return the list of imported interfaces with their CRCs *)
-
-let imported_units() =
-  let imported_units = ref [] in
-  Hashtbl.iter
-    (fun _ ps ->
-       if ps.ps_used then
-         imported_units := (ps.ps_name, ps.ps_crc) :: !imported_units)
-    persistent_structures;
-  !imported_units
-
 (* Return the environment summary *)
 
 let summary env = env.summary
@@ -743,4 +742,10 @@ let report_error = function
       print_string filename; print_space();
       print_string "contains the compiled interface for"; print_space();
       print_string modname
-
+  | Inconsistent_import(name, source1, source2) ->
+      open_hvbox 0;
+      print_string "The compiled interfaces for "; print_string source1;
+      print_string " and "; print_string source2; print_space();
+      print_string "make inconsistent assumptions over interface ";
+      print_string name;
+      close_box()