do not alias functor parameters + some problems with coercions not fixed yet

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

8 files changed, 53 insertions, 18 deletions

diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 2987f9e097..189cf23ba4 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -251,7 +251,7 @@ let rec bound_value_identifiers = function
 
 let rec transl_module cc rootpath mexp =
   match mexp.mod_type with
-    Mty_alias _ -> lambda_unit
+    Mty_alias _ -> apply_coercion cc lambda_unit
   | _ ->
   match mexp.mod_desc with
     Tmod_ident (path,_) ->
diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml
index 65e1504e27..c393cc4667 100644
--- a/testsuite/tests/typing-modules/aliases.ml
+++ b/testsuite/tests/typing-modules/aliases.ml
@@ -1,12 +1,13 @@
 module C = Char;;
-
 C.chr 66;;
 
 module C' : module type of Char = C;;
+C'.chr 66;;
 
 module C'' : (module C) = C';; (* fails *)
 
 module C'' : (module Char) = C;;
+C''.chr 66;;
 
 let f x = let module M = struct module L = List end in M.L.length x;;
 let g x = let module L = List in L.length (L.map succ x);;
@@ -14,11 +15,14 @@ let g x = let module L = List in L.length (L.map succ x);;
 module F(X:sig end) = Char;;
 module C3 = F(struct end);;
 
-module G(X:sig end) = X;;
-module M = G(struct end);; (* must fix *)
+module G(X:sig end) = X;; (* does not alias X *)
+module M = G(struct end);;
 
 module M' = struct
   module N = struct let x = 1 end
   module N' = N
 end;;
 M'.N'.x;;
+
+module M'' : sig module N' : sig val x : int end end = M';; (* must fix *)
+M''.N'.x;;
diff --git a/typing/env.ml b/typing/env.ml
index 64351d6317..651ec0a0b5 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -111,6 +111,7 @@ type summary =
   | Env_class of summary * Ident.t * class_declaration
   | Env_cltype of summary * Ident.t * class_type_declaration
   | Env_open of summary * Path.t
+  | Env_functor_arg of summary * Ident.t
 
 module EnvTbl =
   struct
@@ -172,6 +173,7 @@ type t = {
   components: (Path.t * module_components) EnvTbl.t;
   classes: (Path.t * class_declaration) EnvTbl.t;
   cltypes: (Path.t * class_type_declaration) EnvTbl.t;
+  functor_args: unit Ident.tbl;
   summary: summary;
   local_constraints: bool;
   gadt_instances: (int * TypeSet.t ref) list;
@@ -218,6 +220,7 @@ let empty = {
   cltypes = EnvTbl.empty;
   summary = Env_empty; local_constraints = false; gadt_instances = [];
   in_signature = false;
+  functor_args = Ident.empty;
  }
 
 let in_signature env = {env with in_signature = true}
@@ -491,6 +494,11 @@ let find_module path env =
   | Papply(p1, p2) ->
       raise Not_found (* not right *)
 
+let is_functor_arg path env =
+  let id = Path.head path in
+  try Ident.find_same id env.functor_args; true
+  with Not_found -> false
+
 (* Lookup by name *)
 
 exception Recmodule
@@ -1289,6 +1297,12 @@ let _ =
 
 (* Insertion of bindings by identifier *)
 
+let add_functor_arg ?(arg=false) id env =
+  if not arg then env else
+  {env with
+   functor_args = Ident.add id () env.functor_args;
+   summary = Env_functor_arg (env.summary, id)}
+
 let add_value ?check id desc env =
   store_value None ?check id (Pident id) desc env env
 
@@ -1298,8 +1312,9 @@ let add_type ~check id info env =
 and add_exception ~check id decl env =
   store_exception ~check None id (Pident id) decl env env
 
-and add_module id mty env =
-  store_module None id (Pident id) mty env env
+and add_module ?arg id mty env =
+  let env = store_module None id (Pident id) mty env env in
+  add_functor_arg ?arg id env
 
 and add_modtype id info env =
   store_modtype None id (Pident id) info env env
@@ -1328,7 +1343,9 @@ let enter store_fun name data env =
 let enter_value ?check = enter (store_value ?check)
 and enter_type = enter (store_type ~check:true)
 and enter_exception = enter (store_exception ~check:true)
-and enter_module = enter store_module
+and enter_module ?arg name mty env =
+  let (id, env) = enter store_module name mty env in
+  (id, add_functor_arg ?arg id env)
 and enter_modtype = enter store_modtype
 and enter_class = enter store_class
 and enter_cltype = enter store_cltype
diff --git a/typing/env.mli b/typing/env.mli
index cfed8e3a24..03064c41a4 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -24,6 +24,7 @@ type summary =
   | Env_class of summary * Ident.t * class_declaration
   | Env_cltype of summary * Ident.t * class_type_declaration
   | Env_open of summary * Path.t
+  | Env_functor_arg of summary * Ident.t
 
 type t
 
@@ -59,6 +60,7 @@ val find_type_expansion_opt:
 (* Find the manifest type information associated to a type for the sake
    of the compiler's type-based optimisations. *)
 val find_modtype_expansion: Path.t -> t -> module_type
+val is_functor_arg: Path.t -> t -> bool
 
 val has_local_constraints: t -> bool
 val add_gadt_instance_level: int -> t -> t
@@ -92,7 +94,7 @@ val add_value:
     ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
 val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
 val add_exception: check:bool -> Ident.t -> exception_declaration -> t -> t
-val add_module: Ident.t -> module_type -> t -> t
+val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t
 val add_modtype: Ident.t -> modtype_declaration -> t -> t
 val add_class: Ident.t -> class_declaration -> t -> t
 val add_cltype: Ident.t -> class_type_declaration -> t -> t
@@ -118,7 +120,7 @@ val enter_value:
     string -> value_description -> t -> Ident.t * t
 val enter_type: string -> type_declaration -> t -> Ident.t * t
 val enter_exception: string -> exception_declaration -> t -> Ident.t * t
-val enter_module: string -> module_type -> t -> Ident.t * t
+val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t
 val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t
 val enter_class: string -> class_declaration -> t -> Ident.t * t
 val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t
diff --git a/typing/envaux.ml b/typing/envaux.ml
index a1582c6b9b..465c4ac6a4 100644
--- a/typing/envaux.ml
+++ b/typing/envaux.ml
@@ -73,6 +73,10 @@ let rec env_from_summary sum subst =
               raise (Error (Module_not_found path'))
           in
           Env.open_signature Asttypes.Override path' (extract_sig env mty) env
+      | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' ->
+          Env.add_module id (Subst.modtype subst desc) ~arg:true
+                         (env_from_summary s subst)
+      | Env_functor_arg _ -> assert false
     in
       Hashtbl.add env_cache (sum, subst) env;
       env
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 7903a6eabd..f717c54653 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -116,7 +116,7 @@ let nondep_supertype env mid mty =
         let var_inv =
           match va with Co -> Contra | Contra -> Co | Strict -> Strict in
         Mty_functor(param, nondep_mty env var_inv arg,
-                     nondep_mty (Env.add_module param arg env) va res)
+                    nondep_mty (Env.add_module ~arg:true param arg env) va res)
 
   and nondep_sig env va = function
     [] -> []
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 6a96b6f096..e4ad2be717 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -1114,7 +1114,8 @@ let rec tree_of_modtype = function
   | Mty_functor(param, ty_arg, ty_res) ->
       Omty_functor
         (Ident.name param, tree_of_modtype ty_arg,
-         wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res)
+         wrap_env (Env.add_module ~arg:true param ty_arg)
+           tree_of_modtype ty_res)
   | Mty_alias p ->
       Omty_alias (tree_of_path p)
 
diff --git a/typing/typemod.ml b/typing/typemod.ml
index ad271d4084..5bb7831eda 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -301,7 +301,7 @@ let rec approx_modtype env smty =
       Mty_signature(approx_sig env ssg)
   | Pmty_functor(param, sarg, sres) ->
       let arg = approx_modtype env sarg in
-      let (id, newenv) = Env.enter_module param.txt arg env in
+      let (id, newenv) = Env.enter_module ~arg:true param.txt arg env in
       let res = approx_modtype newenv sres in
       Mty_functor(id, arg, res)
   | Pmty_with(sbody, constraints) ->
@@ -469,7 +469,8 @@ let rec transl_modtype env smty =
         smty.pmty_attributes
   | Pmty_functor(param, sarg, sres) ->
       let arg = transl_modtype env sarg in
-      let (id, newenv) = Env.enter_module param.txt arg.mty_type env in
+      let (id, newenv) =
+        Env.enter_module ~arg:true param.txt arg.mty_type env in
       let res = transl_modtype newenv sres in
       mkmty (Tmty_functor (id, param, arg, res))
       (Mty_functor(id, arg.mty_type, res.mty_type)) env loc
@@ -920,9 +921,14 @@ let rec type_module sttn funct_body anchor env smod =
   match smod.pmod_desc with
     Pmod_ident lid ->
       let (path, mty) = Typetexp.find_module env smod.pmod_loc lid.txt in
+      let mty =
+        if sttn then
+          if Env.is_functor_arg path env
+          then Mtype.strengthen env mty path
+          else Mty_alias path
+        else mty in
       rm { mod_desc = Tmod_ident (path, lid);
-           mod_type = Mty_alias path;
-             (*if sttn then Mtype.strengthen env mty path else mty;*)
+           mod_type = mty;
            mod_env = env;
            mod_attributes = smod.pmod_attributes;
            mod_loc = smod.pmod_loc }
@@ -936,7 +942,7 @@ let rec type_module sttn funct_body anchor env smod =
            mod_loc = smod.pmod_loc }
   | Pmod_functor(name, smty, sbody) ->
       let mty = transl_modtype env smty in
-      let (id, newenv) = Env.enter_module name.txt mty.mty_type env in
+      let (id, newenv) = Env.enter_module ~arg:true name.txt mty.mty_type env in
       let body = type_module sttn true None newenv sbody in
       rm { mod_desc = Tmod_functor(id, name, mty, body);
            mod_type = Mty_functor(id, mty.mty_type, body.mod_type);
@@ -963,7 +969,8 @@ let rec type_module sttn funct_body anchor env smod =
             | None ->
                 try
                   Mtype.nondep_supertype
-                    (Env.add_module param arg.mod_type env) param mty_res
+                    (Env.add_module ~arg:true param arg.mod_type env)
+                    param mty_res
                 with Not_found ->
                   raise(Error(smod.pmod_loc, env,
                               Cannot_eliminate_dependency mty_functor))
@@ -1305,7 +1312,7 @@ let type_package env m p nl tl =
     match modl.mod_desc with
       Tmod_ident (mp,_) -> (mp, env)
     | _ ->
-      let (id, new_env) = Env.enter_module "%M" modl.mod_type env in
+      let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in
       (Pident id, new_env)
   in
   let rec mkpath mp = function