Merge pull request ocaml#2217 from gasche/refactoring

Minor refactoring of the `Consistbl.Inconsistency` exception

asmcomp/asmlink.ml

@@ -59,7 +59,11 @@ let check_consistency file_name unit crc =
             then Cmi_consistbl.set crc_interfaces name crc file_name
             else Cmi_consistbl.check crc_interfaces name crc file_name)
       unit.ui_imports_cmi
-  with Cmi_consistbl.Inconsistency(name, user, auth) ->
+  with Cmi_consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = user;
+      original_source = auth;
+    } ->
     raise(Error(Inconsistent_interface(name, user, auth)))
   end;
   begin try
@@ -73,7 +77,11 @@ let check_consistency file_name unit crc =
           | Some crc ->
               Cmx_consistbl.check crc_implementations name crc file_name)
       unit.ui_imports_cmx
-  with Cmx_consistbl.Inconsistency(name, user, auth) ->
+  with Cmx_consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = user;
+      original_source = auth;
+    } ->
     raise(Error(Inconsistent_implementation(name, user, auth)))
   end;
   begin try

bytecomp/bytelink.ml

@@ -178,7 +178,11 @@ let check_consistency file_name cu =
             then Consistbl.set crc_interfaces name crc file_name
             else Consistbl.check crc_interfaces name crc file_name)
       cu.cu_imports
-  with Consistbl.Inconsistency(name, user, auth) ->
+  with Consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = user;
+      original_source = auth;
+    } ->
     raise(Error(Inconsistent_import(name, user, auth)))
   end;
   begin try

file_formats/cmi_format.ml

@@ -28,17 +28,24 @@ type error =
 
 exception Error of error
 
+(* these type abbreviations are not exported;
+   they are used to provide consistency across
+   input_value and output_value usage. *)
+type signature = Types.signature_item list
+type flags = pers_flags list
+type header = modname * signature
+
 type cmi_infos = {
-    cmi_name : Misc.modname;
-    cmi_sign : Types.signature_item list;
+    cmi_name : modname;
+    cmi_sign : signature;
     cmi_crcs : crcs;
-    cmi_flags : pers_flags list;
+    cmi_flags : flags;
 }
 
 let input_cmi ic =
-  let (name, sign) = input_value ic in
-  let crcs = input_value ic in
-  let flags = input_value ic in
+  let (name, sign) = (input_value ic : header) in
+  let crcs = (input_value ic : crcs) in
+  let flags = (input_value ic : flags) in
   {
       cmi_name = name;
       cmi_sign = sign;
@@ -78,12 +85,12 @@ let read_cmi filename =
 let output_cmi filename oc cmi =
 (* beware: the provided signature must have been substituted for saving *)
   output_string oc Config.cmi_magic_number;
-  output_value oc (cmi.cmi_name, cmi.cmi_sign);
+  output_value oc ((cmi.cmi_name, cmi.cmi_sign) : header);
   flush oc;
   let crc = Digest.file filename in
   let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in
-  output_value oc crcs;
-  output_value oc cmi.cmi_flags;
+  output_value oc (crcs : crcs);
+  output_value oc (cmi.cmi_flags : flags);
   crc
 
 (* Error report *)

toplevel/topdirs.ml

@@ -119,7 +119,11 @@ exception Load_failed
 
 let check_consistency ppf filename cu =
   try Env.import_crcs ~source:filename cu.cu_imports
-  with Persistent_env.Consistbl.Inconsistency(name, user, auth) ->
+  with Persistent_env.Consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = user;
+      original_source = auth;
+    } ->
     fprintf ppf "@[<hv 0>The files %s@ and %s@ \
                  disagree over interface %s@]@."
             user auth name;

typing/persistent_env.ml

@@ -125,7 +125,11 @@ let import_crcs penv ~source crcs =
 
 let check_consistency penv ps =
   try import_crcs penv ~source:ps.ps_filename ps.ps_crcs
-  with Consistbl.Inconsistency(name, source, auth) ->
+  with Consistbl.Inconsistency {
+      unit_name = name;
+      inconsistent_source = source;
+      original_source = auth;
+    } ->
     error (Inconsistent_import(name, auth, source))
 
 let can_load_cmis penv =

utils/consistbl.ml

@@ -30,21 +30,29 @@ end) = struct
 
   let clear = Module_name.Tbl.clear
 
-  exception Inconsistency of Module_name.t * filepath * filepath
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
 
   exception Not_available of Module_name.t
 
+  let check_ tbl name crc source =
+    let (old_crc, old_source) = Module_name.Tbl.find tbl name in
+    if crc <> old_crc then raise(Inconsistency {
+        unit_name = name;
+        inconsistent_source = source;
+        original_source = old_source;
+      })
+
   let check tbl name crc source =
-    try
-      let (old_crc, old_source) = Module_name.Tbl.find tbl name in
-      if crc <> old_crc then raise(Inconsistency(name, source, old_source))
+    try check_ tbl name crc source
     with Not_found ->
       Module_name.Tbl.add tbl name (crc, source)
 
   let check_noadd tbl name crc source =
-    try
-      let (old_crc, old_source) = Module_name.Tbl.find tbl name in
-      if crc <> old_crc then raise(Inconsistency(name, source, old_source))
+    try check_ tbl name crc source
     with Not_found ->
       raise (Not_available name)
 

utils/consistbl.mli

@@ -69,11 +69,12 @@ end) : sig
         (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs
            such that [pred name] is [false]. *)
 
-  exception Inconsistency of Module_name.t * filepath * filepath
-        (* Raised by [check] when a CRC mismatch is detected.
-           First string is the name of the compilation unit.
-           Second string is the source that caused the inconsistency.
-           Third string is the source that set the CRC. *)
+  exception Inconsistency of {
+    unit_name : Module_name.t;
+    inconsistent_source : string;
+    original_source : string;
+  }
+  (* Raised by [check] when a CRC mismatch is detected. *)
 
   exception Not_available of Module_name.t
         (* Raised by [check_noadd] when a name doesn't have an associated