Do not add module aliases to imports

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/module-alias@14219 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

10 files changed, 100 insertions, 52 deletions

diff --git a/testsuite/tests/typing-modules/a.mli b/testsuite/tests/typing-modules/a.mli
index 4431aa0f4d..ea15bf005b 100644
--- a/testsuite/tests/typing-modules/a.mli
+++ b/testsuite/tests/typing-modules/a.mli
@@ -1,2 +1,3 @@
 module L = List
 module S = String
+module D' = D
diff --git a/testsuite/tests/typing-modules/b.ml b/testsuite/tests/typing-modules/b.ml
index 7072ad479e..4c43e809fd 100644
--- a/testsuite/tests/typing-modules/b.ml
+++ b/testsuite/tests/typing-modules/b.ml
@@ -10,3 +10,9 @@ module C : sig module L : module type of List end = struct include A end
 (* The following introduces a (useless) dependency on A:
 module C : sig module L : module type of List end = A
 *)
+
+include D'
+(*
+let () =
+  print_endline (string_of_int D'.M.y)
+*)
diff --git a/testsuite/tests/typing-modules/b2.ml b/testsuite/tests/typing-modules/b2.ml
new file mode 100644
index 0000000000..034e432c34
--- /dev/null
+++ b/testsuite/tests/typing-modules/b2.ml
@@ -0,0 +1,14 @@
+open A
+let f =
+  L.map S.capitalize
+
+let () =
+  L.iter print_endline (f ["jacques"; "garrigue"])
+
+module C : sig module L : module type of List end = struct include A end
+
+(* The following introduces a (useless) dependency on A:
+module C : sig module L : module type of List end = A
+*)
+
+(* No dependency on D *)
diff --git a/testsuite/tests/typing-modules/b3.mli b/testsuite/tests/typing-modules/b3.mli
new file mode 100644
index 0000000000..04599abe34
--- /dev/null
+++ b/testsuite/tests/typing-modules/b3.mli
@@ -0,0 +1,4 @@
+open A
+(*module type S = module type of D'.M*)
+type t = Complex.t
+type s = String.t
diff --git a/testsuite/tests/typing-modules/d.ml b/testsuite/tests/typing-modules/d.ml
new file mode 100644
index 0000000000..55d311f408
--- /dev/null
+++ b/testsuite/tests/typing-modules/d.ml
@@ -0,0 +1,2 @@
+let x = 3
+module M = struct let y = 5 end
diff --git a/typing/env.ml b/typing/env.ml
index c5350f95f4..2f2ae897c7 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -283,7 +283,8 @@ type pers_struct =
     ps_comps: module_components;
     ps_crcs: (string * Digest.t) list;
     ps_filename: string;
-    ps_flags: pers_flags list }
+    ps_flags: pers_flags list;
+    mutable ps_crcs_checked: bool }
 
 let persistent_structures =
   (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)
@@ -292,17 +293,19 @@ let persistent_structures =
 
 let crc_units = Consistbl.create()
 
-let check_consistency filename crcs =
+let check_consistency ps =
+  if ps.ps_crcs_checked then () else
   try
     List.iter
-      (fun (name, crc) -> Consistbl.check crc_units name crc filename)
-      crcs
+      (fun (name, crc) -> Consistbl.check crc_units name crc ps.ps_filename)
+      ps.ps_crcs;
+    ps.ps_crcs_checked <- true
   with Consistbl.Inconsistency(name, source, auth) ->
     error (Inconsistent_import(name, auth, source))
 
 (* Reading persistent structures from .cmi files *)
 
-let read_pers_struct modname filename = (
+let read_pers_struct modname filename =
   let cmi = read_cmi filename in
   let name = cmi.cmi_name in
   let sign = cmi.cmi_sign in
@@ -311,35 +314,37 @@ let read_pers_struct modname filename = (
   let comps =
       !components_of_module' empty Subst.identity
                              (Pident(Ident.create_persistent name))
-                             (Mty_signature sign) in
-    let ps = { ps_name = name;
-               ps_sig = sign;
-               ps_comps = comps;
-               ps_crcs = crcs;
-               ps_filename = filename;
-               ps_flags = flags } in
-    if ps.ps_name <> modname then
-      error (Illegal_renaming(modname, ps.ps_name, filename));
-    check_consistency filename ps.ps_crcs;
-    List.iter
-      (function Rectypes ->
-        if not !Clflags.recursive_types then
-          error (Need_recursive_types(ps.ps_name, !current_unit)))
-      ps.ps_flags;
-    Hashtbl.add persistent_structures modname (Some ps);
-    ps
-)
-
-let find_pers_struct name =
+                             (Mty_signature sign)
+  in
+  let ps = { ps_name = name;
+             ps_sig = sign;
+             ps_comps = comps;
+             ps_crcs = crcs;
+             ps_crcs_checked = false;
+             ps_filename = filename;
+             ps_flags = flags } in
+  if ps.ps_name <> modname then
+    error (Illegal_renaming(modname, ps.ps_name, filename));
+  (*check_consistency filename ps.ps_crcs;*)
+  List.iter
+    (function Rectypes ->
+      if not !Clflags.recursive_types then
+        error (Need_recursive_types(ps.ps_name, !current_unit)))
+    ps.ps_flags;
+  Hashtbl.add persistent_structures modname (Some ps);
+  ps
+
+let find_pers_struct ?(check=true) name =
   if name = "*predef*" then raise Not_found;
   let r =
     try Some (Hashtbl.find persistent_structures name)
     with Not_found -> None
   in
-  match r with
-  | Some None -> raise Not_found
-  | Some (Some sg) -> sg
-  | None ->
+  let ps =
+    match r with
+    | Some None -> raise Not_found
+    | Some (Some sg) -> sg
+    | None ->
       let filename =
         try find_in_path_uncap !load_path (name ^ ".cmi")
         with Not_found ->
@@ -347,6 +352,9 @@ let find_pers_struct name =
           raise Not_found
       in
       read_pers_struct name filename
+  in
+  if check then check_consistency ps;
+  ps
 
 let reset_cache () =
   current_unit := "";
@@ -463,7 +471,16 @@ let find_module path env =
           raise Not_found
       end
   | Papply(p1, p2) ->
-      raise Not_found (* not right *)
+      let desc1 = find_module_descr p1 env in
+      begin match EnvLazy.force !components_of_module_maker' desc1 with
+        Functor_comps f ->
+          let mty =
+            Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst)
+              f.fcomp_res in
+          md mty
+      | Structure_comps c ->
+          raise Not_found
+      end
 
 let rec normalize_path lax env path =
   let path =
@@ -562,7 +579,8 @@ let rec lookup_module_descr lid env =
       end
   | Lapply(l1, l2) ->
       let (p1, desc1) = lookup_module_descr l1 env in
-      let (p2, {md_type=mty2}) = lookup_module l2 env in
+      let p2 = lookup_module l2 env in
+      let {md_type=mty2} = find_module p2 env in
       begin match EnvLazy.force !components_of_module_maker' desc1 with
         Functor_comps f ->
           !check_modtype_inclusion env mty2 p2 f.fcomp_arg;
@@ -571,45 +589,41 @@ let rec lookup_module_descr lid env =
           raise Not_found
       end
 
-and lookup_module lid env : Path.t * module_declaration =
+and lookup_module lid env : Path.t =
   match lid with
     Lident s ->
       begin try
-        let (_, {md_type}) as r = EnvTbl.find_name s env.modules in
+        let (p, {md_type}) as r = EnvTbl.find_name s env.modules in
         begin match md_type with
         | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" ->
           (* see #5965 *)
           raise Recmodule
         | _ -> ()
         end;
-        r
+        p
       with Not_found ->
         if s = !current_unit then raise Not_found;
-        let ps = find_pers_struct s in
-        (Pident(Ident.create_persistent s),
-         md (Mty_signature ps.ps_sig)
-        )
+        ignore (find_pers_struct ~check:false s);
+        Pident(Ident.create_persistent s)
       end
   | Ldot(l, s) ->
       let (p, descr) = lookup_module_descr l env in
       begin match EnvLazy.force !components_of_module_maker' descr with
         Structure_comps c ->
           let (data, pos) = Tbl.find s c.comp_modules in
-          (Pdot(p, s, pos), md (EnvLazy.force subst_modtype_maker data))
+          Pdot(p, s, pos)
       | Functor_comps f ->
           raise Not_found
       end
   | Lapply(l1, l2) ->
       let (p1, desc1) = lookup_module_descr l1 env in
-      let (p2, {md_type=mty2}) = lookup_module l2 env in
+      let p2 = lookup_module l2 env in
+      let {md_type=mty2} = find_module p2 env in
       let p = Papply(p1, p2) in
       begin match EnvLazy.force !components_of_module_maker' desc1 with
         Functor_comps f ->
           !check_modtype_inclusion env mty2 p2 f.fcomp_arg;
-          let mty =
-            Subst.modtype (Subst.add_module f.fcomp_param p2 f.fcomp_subst)
-              f.fcomp_res in
-          (p, md mty)
+          p
       | Structure_comps c ->
           raise Not_found
       end
@@ -1496,12 +1510,14 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
 (* Read a signature from a file *)
 
 let read_signature modname filename =
-  let ps = read_pers_struct modname filename in ps.ps_sig
+  let ps = read_pers_struct modname filename in
+  check_consistency ps;
+  ps.ps_sig
 
 (* Return the CRC of the interface of the given compilation unit *)
 
 let crc_of_unit name =
-  let ps = find_pers_struct name in
+  let ps = find_pers_struct ~check:false name in
   try
     List.assoc name ps.ps_crcs
   with Not_found ->
@@ -1515,6 +1531,8 @@ let imported_units() =
 (* Save a signature to a file *)
 
 let save_signature_with_imports sg modname filename imports =
+  (*prerr_endline filename;
+  List.iter (fun (name, crc) -> prerr_endline name) imports;*)
   Btype.cleanup_abbrev ();
   Subst.reset_for_saving ();
   let sg = Subst.signature (Subst.for_saving Subst.identity) sg in
@@ -1539,7 +1557,8 @@ let save_signature_with_imports sg modname filename imports =
         ps_comps = comps;
         ps_crcs = (cmi.cmi_name, crc) :: imports;
         ps_filename = filename;
-        ps_flags = cmi.cmi_flags } in
+        ps_flags = cmi.cmi_flags;
+        ps_crcs_checked = true } in
     Hashtbl.add persistent_structures modname (Some ps);
     Consistbl.set crc_units modname crc filename;
     sg
diff --git a/typing/env.mli b/typing/env.mli
index 7dd074b3d6..fe924be00b 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -82,7 +82,7 @@ val lookup_label: Longident.t -> t -> label_description
 val lookup_all_labels:
   Longident.t -> t -> (label_description * (unit -> unit)) list
 val lookup_type: Longident.t -> t -> Path.t * type_declaration
-val lookup_module: Longident.t -> t -> Path.t * module_declaration
+val lookup_module: Longident.t -> t -> Path.t
 val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
 val lookup_class: Longident.t -> t -> Path.t * class_declaration
 val lookup_cltype: Longident.t -> t -> Path.t * class_type_declaration
diff --git a/typing/includemod.ml b/typing/includemod.ml
index f8f0a47aa5..83998650e0 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -172,6 +172,7 @@ let rec modtypes env cxt subst mty1 mty2 =
 and try_modtypes env cxt subst mty1 mty2 =
   match (mty1, mty2) with
     (Mty_alias p1, Mty_alias p2) ->
+      if Path.same p1 p2 then Tcoerce_none else
       let p1 = Env.normalize_path None env p1
       and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
       (* Should actually be Tcoerce_ignore, if it existed *)
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 560bcec735..6d05cba9ab 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -137,10 +137,11 @@ let find_value env loc lid =
 
 let find_module env loc lid =
   let (path, decl) as r =
-    find_component Env.lookup_module (fun lid -> Unbound_module lid) env loc lid
+    find_component (fun lid env -> (Env.lookup_module lid env, ()))
+      (fun lid -> Unbound_module lid) env loc lid
   in
-  check_deprecated loc decl.md_attributes (Path.name path);
-  r
+  (* check_deprecated loc decl.md_attributes (Path.name path); *)
+  path
 
 let find_modtype =
   find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid)
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index a661e23fb5..da56e641f2 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -95,7 +95,7 @@ val find_value:
 val find_class:
     Env.t -> Location.t -> Longident.t -> Path.t * class_declaration
 val find_module:
-    Env.t -> Location.t -> Longident.t -> Path.t * module_declaration
+    Env.t -> Location.t -> Longident.t -> Path.t
 val find_modtype:
     Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration
 val find_class_type: