mostly works, but:

* a strange bug in open
* spurious bindings in the lambda code


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

8 files changed, 125 insertions, 83 deletions

diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 8774e72b8..46e47ec08 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -255,12 +255,15 @@ let rec lam ppf = function
             fprintf ppf ")" in
       fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body
   | Llet(str, id, arg, body) ->
+      let kind = function
+        Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" in
       let rec letbody = function
         | Llet(str, id, arg, body) ->
-            fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
+            fprintf ppf "@ @[<2>%a =%s@ %a@]" Ident.print id (kind str) lam arg;
             letbody body
         | expr -> expr in
-      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s@ %a@]"
+        Ident.print id (kind str) lam arg;
       let expr = letbody body in
       fprintf ppf ")@]@ %a)@]" lam expr
   | Lletrec(id_arg_list, body) ->
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 189cf23ba..1dc89a1b5 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -35,10 +35,17 @@ let rec apply_coercion restr arg =
   match restr with
     Tcoerce_none ->
       arg
-  | Tcoerce_structure pos_cc_list ->
+  | Tcoerce_structure(pos_cc_list, id_pos_list) ->
       name_lambda arg (fun id ->
-        Lprim(Pmakeblock(0, Immutable),
-              List.map (apply_coercion_field id) pos_cc_list))
+        let lam =
+          Lprim(Pmakeblock(0, Immutable),
+                List.map (apply_coercion_field id) pos_cc_list) in
+        let fv = free_variables lam in
+        List.fold_left (fun lam (id',pos,c) ->
+          if IdentSet.mem id' fv then
+            Llet(Alias,id',apply_coercion c (Lprim(Pfield pos,[Lvar id])),lam)
+          else lam)
+          lam id_pos_list)
   | Tcoerce_functor(cc_arg, cc_res) ->
       let param = Ident.create "funarg" in
       name_lambda arg (fun id ->
@@ -62,19 +69,25 @@ let rec compose_coercions c1 c2 =
   match (c1, c2) with
     (Tcoerce_none, c2) -> c2
   | (c1, Tcoerce_none) -> c1
-  | (Tcoerce_structure pc1, Tcoerce_structure pc2) ->
+  | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) ->
       let v2 = Array.of_list pc2 in
+      let ids1 =
+        List.map (fun (id,pos1,c1) ->
+          let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2))
+          ids1
+      in
       Tcoerce_structure
         (List.map
           (function (p1, Tcoerce_primitive p) ->
                       (p1, Tcoerce_primitive p)
                   | (p1, c1) ->
                       let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2))
-             pc1)
+             pc1,
+         ids1 @ ids2)
   | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
       Tcoerce_functor(compose_coercions arg2 arg1,
                       compose_coercions res1 res2)
-  | (Tcoerce_alias (path, c1), c2) ->
+  | (c1, Tcoerce_alias (path, c2)) ->
       Tcoerce_alias (path, compose_coercions c1 c2)
   | (_, _) ->
       fatal_error "Translmod.compose_coercions"
@@ -292,15 +305,19 @@ and transl_structure fields cc rootpath = function
         Tcoerce_none ->
           Lprim(Pmakeblock(0, Immutable),
                 List.map (fun id -> Lvar id) (List.rev fields))
-      | Tcoerce_structure pos_cc_list ->
+      | Tcoerce_structure(pos_cc_list, id_pos_list) ->
+              (* ignore id_pos_list as the ids are already bound *)
           let v = Array.of_list (List.rev fields) in
-          Lprim(Pmakeblock(0, Immutable),
+          (*List.fold_left
+            (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*)
+            (Lprim(Pmakeblock(0, Immutable),
                 List.map
                   (fun (pos, cc) ->
                     match cc with
                       Tcoerce_primitive p -> transl_primitive Location.none p
                     | _ -> apply_coercion cc (Lvar v.(pos)))
-                  pos_cc_list)
+                  pos_cc_list))
+            (*id_pos_list*)
       | _ ->
           fatal_error "Translmod.transl_structure"
       end
@@ -326,6 +343,11 @@ and transl_structure fields cc rootpath = function
            transl_structure (id :: fields) cc rootpath rem)
   | Tstr_module mb ->
       let id = mb.mb_id in
+      (* let rec strict m =
+        match m.mod_desc with
+          Tmod_ident _ -> Alias
+        | Tmod_constraint (m,_,_,_) -> strict m
+        | _ -> Strict in *)
       Llet(Strict, id,
            transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr,
            transl_structure (id :: fields) cc rootpath rem)
@@ -621,7 +643,8 @@ let build_ident_map restr idlist more_ids =
     match restr with
         Tcoerce_none ->
           natural_map 0 Ident.empty [] idlist
-      | Tcoerce_structure pos_cc_list ->
+      | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
+              (* ignore _id_pos_list as the ids are already bound *)
         let idarray = Array.of_list idlist in
         let rec export_map pos map prims undef = function
         [] ->
@@ -773,7 +796,8 @@ let transl_package component_names target_name coercion =
     match coercion with
       Tcoerce_none ->
         List.map get_component component_names
-    | Tcoerce_structure pos_cc_list ->
+    | Tcoerce_structure (pos_cc_list, id_pos_list) ->
+              (* ignore id_pos_list as the ids are already bound *)
         let g = Array.of_list component_names in
         List.map
           (fun (pos, cc) -> apply_coercion cc (get_component g.(pos)))
@@ -796,7 +820,8 @@ let transl_store_package component_names target_name coercion =
                  [Lprim(Pgetglobal target_name, []);
                   get_component id]))
          0 component_names)
-  | Tcoerce_structure pos_cc_list ->
+  | Tcoerce_structure (pos_cc_list, id_pos_list) ->
+              (* ignore id_pos_list as the ids are already bound *)
       let id = Array.of_list component_names in
       (List.length pos_cc_list,
        make_sequence
diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml
index c96e02a35..36a5a4144 100644
--- a/testsuite/tests/typing-modules/aliases.ml
+++ b/testsuite/tests/typing-modules/aliases.ml
@@ -16,7 +16,8 @@ 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);;
 
 module F(X:sig end) = Char;;
-module C3 = F(struct end);;
+module C4 = F(struct end);;
+C4.chr 66;;
 
 module G(X:sig end) = X;; (* does not alias X *)
 module M = G(struct end);;
@@ -46,4 +47,31 @@ module F(X:sig end) = struct
   module N' = N
 end;;
 module G : functor(X:sig end) -> sig module N' : sig val x : int end end = F;;
-(* must fix *)
+module M5 = G(struct end);;
+M5.N'.x;;
+
+module M = struct
+  module D = struct let y = 3 end
+  module N = struct let x = 1 end
+  module N' = N
+end;;
+
+module M1 : sig module N : sig val x : int end module N' = N end = M;;
+M1.N'.x;;
+module M2 : sig module N' : sig val x : int end end =
+  (M : sig module N : sig val x : int end module N' = N end);;
+M2.N'.x;;
+
+open M;;
+N'.x;;
+
+module M = struct
+  module C = Char
+  module C' = C
+end;;
+module M1 : sig module C : sig val chr : int -> char end module C' = C end =
+  M;;
+M1.C'.chr 66;;
+module M2 : sig module C' : sig val chr : int -> char end end =
+  (M : sig module C : sig val chr : int -> char end module C' = C end);;
+M2.C'.chr 66;;
diff --git a/typing/env.ml b/typing/env.ml
index 651ec0a0b..f9be752c5 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -928,7 +928,7 @@ let rec scrape_alias env mty =
       begin try
         scrape_alias env (find_module path env)
       with Not_found ->
-        mty
+        assert false
       end      
   | _ -> mty
 
diff --git a/typing/includemod.ml b/typing/includemod.ml
index bb5558a62..24858e605 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -143,7 +143,7 @@ let is_runtime_component = function
 
 (* Simplify a structure coercion *)
 
-let simplify_structure_coercion cc =
+let simplify_structure_coercion cc id_pos_list =
   let rec is_identity_coercion pos = function
   | [] ->
       true
@@ -151,15 +151,15 @@ let simplify_structure_coercion cc =
       n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
   if is_identity_coercion 0 cc
   then Tcoerce_none
-  else Tcoerce_structure cc
+  else Tcoerce_structure (cc, id_pos_list)
 
 (* Inclusion between module types.
    Return the restriction that transforms a value of the smaller type
    into a value of the bigger type. *)
 
-let rec modtypes env cxt msubs subst mty1 mty2 =
+let rec modtypes env cxt subst mty1 mty2 =
   try
-    try_modtypes env cxt msubs subst mty1 mty2
+    try_modtypes env cxt subst mty1 mty2
   with
     Dont_match ->
       raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)])
@@ -167,37 +167,31 @@ let rec modtypes env cxt msubs subst mty1 mty2 =
       raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2))
                   :: reasons))
 
-and try_modtypes env cxt msubs subst mty1 mty2 =
+and try_modtypes env cxt subst mty1 mty2 =
   match (mty1, mty2) with
     (Mty_alias p1, Mty_alias p2) ->
       let p1 = normalize_module_path env cxt p1
-      and p2 = normalize_module_path env cxt p2 in
-      if Path.same p1 p2 then Tcoerce_none else raise Dont_match
+      and p2 = normalize_module_path env cxt (Subst.module_path subst p2) in
+      if Path.same p1 p2 then Tcoerce_none else
+      Printtyp.(Format.eprintf "%a %a@." path p1 path p2;
+      raise Dont_match)
   | (Mty_alias p1, _) ->
       let p1 = normalize_module_path env cxt p1 in
       let mty1 = expand_module_alias env cxt p1 in
-      let p1' = Mtype.normalize_path env p1 in
-      let msubs, p1'' =
-        match msubs with None -> Some (p1, Subst.identity), p1'
-        | Some (_, s) -> Some (p1, s), Subst.module_path s p1' in
-      Printtyp.(Format.eprintf "%a %a %a@." path p1 path p1' path p1'');
-      Tcoerce_alias (p1'', modtypes env cxt msubs subst mty1 mty2)
+      Tcoerce_alias (Mtype.normalize_path env p1,
+                     modtypes env cxt subst mty1 mty2)
   | (_, Mty_ident p2) ->
-      try_modtypes2 env cxt msubs mty1 (Subst.modtype subst mty2)
+      try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
   | (Mty_ident p1, _) ->
-      try_modtypes env cxt msubs subst (expand_module_path env cxt p1) mty2
+      try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
   | (Mty_signature sig1, Mty_signature sig2) ->
-      signatures env cxt msubs subst sig1 sig2
+      signatures env cxt subst sig1 sig2
   | (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) ->
       let arg2' = Subst.modtype subst arg2 in
-      let msubs =
-        match msubs with None -> Some (Pident param1, Subst.identity)
-        | Some (_, s) -> Some (Pident param1, Subst.identity) in
-      let cc_arg =
-        modtypes env (Arg param1::cxt) msubs Subst.identity arg2' arg1 in
+      let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
       let cc_res =
         modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
-          msubs (Subst.add_module param2 (Pident param1) subst) res1 res2 in
+          (Subst.add_module param2 (Pident param1) subst) res1 res2 in
       begin match (cc_arg, cc_res) with
           (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
         | _ -> Tcoerce_functor(cc_arg, cc_res)
@@ -205,37 +199,30 @@ and try_modtypes env cxt msubs subst mty1 mty2 =
   | (_, _) ->
       raise Dont_match
 
-and try_modtypes2 env cxt msubs mty1 mty2 =
+and try_modtypes2 env cxt mty1 mty2 =
   (* mty2 is an identifier *)
   match (mty1, mty2) with
     (Mty_ident p1, Mty_ident p2) when Path.same p1 p2 ->
       Tcoerce_none
   | (_, Mty_ident p2) ->
-      try_modtypes env cxt msubs Subst.identity mty1
-        (expand_module_path env cxt p2)
+      try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
   | (_, _) ->
       assert false
 
 (* Inclusion between signatures *)
 
-and signatures env cxt msubs subst sig1 sig2 =
+and signatures env cxt subst sig1 sig2 =
   (* Environment used to check inclusion of components *)
   let new_env =
     Env.add_signature sig1 (Env.in_signature env) in
-  (* Substitution used for module aliases *)
-  let msubs =
-    match msubs with
-      None -> msubs
-    | Some (pr, s) ->
-        let (s, pos) =
-          List.fold_left
-            (fun (s,pos) -> function
-                Sig_module (id, _, _) ->
-                (Subst.add_module id (Pdot (pr, Ident.name id, pos)) s, pos+1)
-              | item -> (s, if is_runtime_component item then pos+1 else pos))
-            (s, 0) sig1
-        in Some (pr, s)
-  in
+  (* Keep ids for module aliases *)
+  let (id_pos_list,_) =
+    List.fold_left
+      (fun (l,pos) -> function
+          Sig_module (id, _, _) ->
+            ((id,pos,Tcoerce_none)::l , pos+1)
+        | item -> (l, if is_runtime_component item then pos+1 else pos))
+      ([], 0) sig1 in
   (* Build a table of the components of sig1, along with their positions.
      The table is indexed by kind and name of component *)
   let rec build_component_table pos tbl = function
@@ -263,12 +250,12 @@ and signatures env cxt msubs subst sig1 sig2 =
         begin match unpaired with
             [] ->
               let cc =
-                signature_components new_env cxt msubs subst (List.rev paired)
+                signature_components new_env cxt subst (List.rev paired)
               in
               if len1 = len2 then (* see PR#5098 *)
-                simplify_structure_coercion cc
+                simplify_structure_coercion cc id_pos_list
               else
-                Tcoerce_structure cc
+                Tcoerce_structure (cc, id_pos_list)
           | _  -> raise(Error unpaired)
         end
     | item2 :: rem ->
@@ -309,39 +296,36 @@ and signatures env cxt msubs subst sig1 sig2 =
 
 (* Inclusion between signature components *)
 
-and signature_components env cxt msubs subst = function
+and signature_components env cxt subst = function
     [] -> []
   | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem ->
       let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
       begin match valdecl2.val_kind with
-        Val_prim p -> signature_components env cxt msubs subst rem
-      | _ -> (pos, cc) :: signature_components env cxt msubs subst rem
+        Val_prim p -> signature_components env cxt subst rem
+      | _ -> (pos, cc) :: signature_components env cxt subst rem
       end
   | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem ->
       type_declarations env cxt subst id1 tydecl1 tydecl2;
-      signature_components env cxt msubs subst rem
+      signature_components env cxt subst rem
   | (Sig_exception(id1, excdecl1), Sig_exception(id2, excdecl2), pos)
     :: rem ->
       exception_declarations env cxt subst id1 excdecl1 excdecl2;
-      (pos, Tcoerce_none) :: signature_components env cxt msubs subst rem
+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem ->
-      let msubs' =
-        match msubs with None -> Some (Pident id1, Subst.identity)
-        | Some (pr, s) -> Some (Pdot (pr, Ident.name id1, pos), s) in
       let cc =
-        modtypes env (Module id1::cxt) msubs' subst
+        modtypes env (Module id1::cxt) subst
           (Mtype.strengthen env mty1 (Pident id1)) mty2 in
-      (pos, cc) :: signature_components env cxt msubs subst rem
+      (pos, cc) :: signature_components env cxt subst rem
   | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem ->
       modtype_infos env cxt subst id1 info1 info2;
-      signature_components env cxt msubs subst rem
+      signature_components env cxt subst rem
   | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem ->
       class_declarations env cxt subst id1 decl1 decl2;
-      (pos, Tcoerce_none) :: signature_components env cxt msubs subst rem
+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Sig_class_type(id1, info1, _),
      Sig_class_type(id2, info2, _), pos) :: rem ->
       class_type_declarations env cxt subst id1 info1 info2;
-      signature_components env cxt msubs subst rem
+      signature_components env cxt subst rem
   | _ ->
       assert false
 
@@ -363,8 +347,8 @@ and modtype_infos env cxt subst id info1 info2 =
 
 and check_modtype_equiv env cxt mty1 mty2 =
   match
-    (modtypes env cxt None Subst.identity mty1 mty2,
-     modtypes env cxt None Subst.identity mty2 mty1)
+    (modtypes env cxt Subst.identity mty1 mty2,
+     modtypes env cxt Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
   | (_, _) -> raise(Error [cxt, env, Modtype_permutation])
@@ -373,7 +357,7 @@ and check_modtype_equiv env cxt mty1 mty2 =
 
 let check_modtype_inclusion env mty1 path1 mty2 =
   try
-    ignore(modtypes env [] None Subst.identity
+    ignore(modtypes env [] Subst.identity
                     (Mtype.strengthen env mty1 path1) mty2)
   with Error reasons ->
     raise Not_found
@@ -385,15 +369,15 @@ let _ = Env.check_modtype_inclusion := check_modtype_inclusion
 
 let compunit impl_name impl_sig intf_name intf_sig =
   try
-    signatures Env.initial [] None Subst.identity impl_sig intf_sig
+    signatures Env.initial [] Subst.identity impl_sig intf_sig
   with Error reasons ->
     raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name))
                 :: reasons))
 
 (* Hide the context and substitution parameters to the outside world *)
 
-let modtypes env mty1 mty2 = modtypes env [] None Subst.identity mty1 mty2
-let signatures env sig1 sig2 = signatures env [] None Subst.identity sig1 sig2
+let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
+let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
 let type_declarations env id decl1 decl2 =
   type_declarations env [] Subst.identity id decl1 decl2
 
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 6d26fe963..092f6c94f 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -238,7 +238,8 @@ and value_binding =
 
 and module_coercion =
     Tcoerce_none
-  | Tcoerce_structure of (int * module_coercion) list
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
   | Tcoerce_functor of module_coercion * module_coercion
   | Tcoerce_primitive of Primitive.description
   | Tcoerce_alias of Path.t * module_coercion
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 5c4346ccf..d8a3ed7e5 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -237,7 +237,8 @@ and value_binding =
 
 and module_coercion =
     Tcoerce_none
-  | Tcoerce_structure of (int * module_coercion) list
+  | Tcoerce_structure of (int * module_coercion) list *
+                         (Ident.t * int * module_coercion) list
   | Tcoerce_functor of module_coercion * module_coercion
   | Tcoerce_primitive of Primitive.description
   | Tcoerce_alias of Path.t * module_coercion
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 67ec78de4..d3aba0914 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -1215,7 +1215,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
 
 let type_toplevel_phrase env s =
   type_structure ~toplevel:true false None env s Location.none
-let type_module_alias = type_module ~alias:true true false None
+(*let type_module_alias = type_module ~alias:true true false None*)
 let type_module = type_module true false None
 let type_structure = type_structure false None
 
@@ -1303,7 +1303,7 @@ let type_package env m p nl tl =
   Ctype.begin_def ();
   Ident.set_current_time lv;
   let context = Typetexp.narrow () in
-  let modl = type_module_alias env m in
+  let modl = type_module env m in
   Ctype.init_def(Ident.current_time());
   Typetexp.widen context;
   let (mp, env) =