make path normalization safer; now Core not only compiles but works

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

19 files changed, 102 insertions, 66 deletions

diff --git a/.depend b/.depend
index ab2130dd42..8d35f6c938 100644
--- a/.depend
+++ b/.depend
@@ -182,11 +182,11 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
     typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \
     parsing/asttypes.cmi typing/env.cmi
 typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \
-    typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \
-    parsing/asttypes.cmi typing/envaux.cmi
+    typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/ident.cmi \
+    typing/env.cmi parsing/asttypes.cmi typing/envaux.cmi
 typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \
-    typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \
-    parsing/asttypes.cmi typing/envaux.cmi
+    typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/ident.cmx \
+    typing/env.cmx parsing/asttypes.cmi typing/envaux.cmi
 typing/ident.cmo : typing/ident.cmi
 typing/ident.cmx : typing/ident.cmi
 typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 01c55af550..1b6b805d04 100644
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -378,18 +378,18 @@ let rec patch_guarded patch = function
 
 (* Translate an access path *)
 
-let rec transl_path = function
+let rec transl_normal_path = function
     Pident id ->
       if Ident.global id then Lprim(Pgetglobal id, []) else Lvar id
   | Pdot(p, s, pos) ->
-      Lprim(Pfield pos, [transl_path p])
+      Lprim(Pfield pos, [transl_normal_path p])
   | Papply(p1, p2) ->
       fatal_error "Lambda.transl_path"
 
 (* Translation of value identifiers *)
 
-let transl_ident_path env path =
-  transl_path (Env.normalize_path env path) 
+let transl_path ?(loc=Location.none) env path =
+  transl_normal_path (Env.normalize_path (Some loc) env path) 
 
 (* Compile a sequence of expressions *)
 
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index 6538c6f5f1..7f5db69068 100644
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -210,8 +210,8 @@ module IdentSet: Set.S with type elt = Ident.t
 val free_variables: lambda -> IdentSet.t
 val free_methods: lambda -> IdentSet.t
 
-val transl_path: Path.t -> lambda
-val transl_ident_path: Env.t -> Path.t -> lambda
+val transl_normal_path: Path.t -> lambda   (* Path.t is already normal *)
+val transl_path: ?loc:Location.t -> Env.t -> Path.t -> lambda
 val make_sequence: ('a -> lambda) -> 'a list -> lambda
 
 val subst_lambda: lambda Ident.tbl -> lambda -> lambda
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 57270e35d8..3b06070d53 100644
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -2159,7 +2159,8 @@ let combine_constructor arg ex_pat cstr partial ctx def
           | Cstr_exception (path, _) ->
               Lifthenelse(Lprim(Pintcomp Ceq,
                                 [Lprim(Pfield 0, [arg]);
-                                 transl_ident_path ex_pat.pat_env path]),
+                                 transl_path ~loc:ex_pat.pat_loc
+                                   ex_pat.pat_env path]),
                           act, rem)
           | _ -> assert false)
         tests default in
@@ -2730,7 +2731,7 @@ let partial_function loc () =
   (* [Location.get_pos_info] is too expensive *)
   let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
   Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
-          [transl_path Predef.path_match_failure;
+          [transl_normal_path Predef.path_match_failure;
            Lconst(Const_block(0,
               [Const_base(Const_string (fname, None));
                Const_base(Const_int line);
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 2a9a164fc9..55ddab3bc8 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -115,6 +115,9 @@ let name_pattern default p =
   | Tpat_alias(p, id, _) -> id
   | _ -> Ident.create default
 
+let normalize_cl_path cl path =
+  Env.normalize_path (Some cl.cl_loc) cl.cl_env path  
+
 let rec build_object_init cl_table obj params inh_init obj_init cl =
   match cl.cl_desc with
     Tcl_ident ( path, _, _) ->
@@ -124,7 +127,8 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
         match envs with None -> []
         | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
       in
-      ((envs, (obj_init, Env.normalize_path cl.cl_env path)::inh_init),
+      ((envs, (obj_init, normalize_cl_path cl path)
+        ::inh_init),
        mkappl(Lvar obj_init, env @ [obj]))
   | Tcl_structure str ->
       create_object cl_table obj (fun obj ->
@@ -253,7 +257,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
     Tcl_ident ( path, _, _) ->
       begin match inh_init with
         (obj_init, path')::inh_init ->
-          let lpath = transl_ident_path cl.cl_env path in
+          let lpath = transl_path ~loc:cl.cl_loc cl.cl_env path in
           (inh_init,
            Llet (Strict, obj_init,
                  mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
@@ -331,8 +335,8 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
       let cl = ignore_cstrs cl in
       begin match cl.cl_desc, inh_init with
         Tcl_ident (path, _, _), (obj_init, path')::inh_init ->
-          assert (Path.same (Env.normalize_path cl.cl_env path) path');
-          let lpath = transl_ident_path cl.cl_env path in
+          assert (Path.same (normalize_cl_path cl path) path');
+          let lpath = transl_normal_path path' in
           let inh = Ident.create "inh"
           and ofs = List.length vals + 1
           and valids, methids = super in
@@ -398,7 +402,7 @@ let rec transl_class_rebind obj_init cl vf =
         try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
         with Not_found -> raise Exit
       end;
-      (Env.normalize_path cl.cl_env path, obj_init)
+      (normalize_cl_path cl path, obj_init)
   | Tcl_fun (_, pat, _, cl, partial) ->
       let path, obj_init = transl_class_rebind obj_init cl vf in
       let build params rem =
@@ -446,7 +450,7 @@ let transl_class_rebind ids cl vf =
     if not (Translcore.check_recursive_lambda ids obj_init') then
       raise(Error(cl.cl_loc, Illegal_class_expr));
     let id = (obj_init' = lfunction [self] obj_init0) in
-    if id then transl_path path else
+    if id then transl_normal_path path else
 
     let cla = Ident.create "class"
     and new_init = Ident.create "new_init"
@@ -456,7 +460,7 @@ let transl_class_rebind ids cl vf =
     Llet(
     Strict, new_init, lfunction [obj_init] obj_init',
     Llet(
-    Alias, cla, transl_path path,
+    Alias, cla, transl_normal_path path,
     Lprim(Pmakeblock(0, Immutable),
           [mkappl(Lvar new_init, [lfield cla 0]);
            lfunction [table]
@@ -741,7 +745,7 @@ let transl_class ids cl_id pub_meths cl vflag =
     Lprim(Pmakeblock(0, Immutable),
           menv :: List.map (fun id -> Lvar id) !new_ids_init)
   and linh_envs =
-    List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
+    List.map (fun (_, p) -> Lprim(Pfield 3, [transl_normal_path p]))
       (List.rev inh_init)
   in
   let make_envs lam =
@@ -758,7 +762,7 @@ let transl_class ids cl_id pub_meths cl vflag =
     List.filter
       (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
   let inh_keys =
-    List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
+    List.map (fun (_,p) -> Lprim(Pfield 1, [transl_normal_path p])) inh_paths in
   let lclass lam =
     Llet(Strict, class_init,
          Lfunction(Curried, [cla], def_ids cla cl_init), lam)
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index abada8543e..12e0e26dec 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -587,7 +587,7 @@ let assert_failed exp =
     Location.get_pos_info exp.exp_loc.Location.loc_start in
   Lprim(Praise, [event_after exp
     (Lprim(Pmakeblock(0, Immutable),
-          [transl_path Predef.path_assert_failure;
+          [transl_normal_path Predef.path_assert_failure;
            Lconst(Const_block(0,
               [Const_base(Const_string (fname, None));
                Const_base(Const_int line);
@@ -631,7 +631,7 @@ and transl_exp0 e =
   | Texp_ident(path, _, {val_kind = Val_anc _}) ->
       raise(Error(e.exp_loc, Free_super_var))
   | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) ->
-      transl_ident_path e.exp_env path
+      transl_path ~loc:e.exp_loc e.exp_env path
   | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
   | Texp_constant cst ->
       Lconst(Const_base cst)
@@ -722,7 +722,7 @@ and transl_exp0 e =
           end
       | Cstr_exception (path, _) ->
           Lprim(Pmakeblock(0, Immutable),
-                transl_ident_path e.exp_env path :: ll)
+                transl_path ~loc:e.exp_loc e.exp_env path :: ll)
       end
   | Texp_variant(l, arg) ->
       let tag = Btype.hash_variant l in
@@ -799,17 +799,18 @@ and transl_exp0 e =
             Lsend (kind, tag, obj, cache, e.exp_loc)
       in
       event_after e lam
-  | Texp_new (cl, _, _) ->
-      Lapply(Lprim(Pfield 0, [transl_ident_path e.exp_env cl]),
+  | Texp_new (cl, {Location.loc=loc}, _) ->
+      Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]),
              [lambda_unit], Location.none)
   | Texp_instvar(path_self, path, _) ->
-      Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
+      Lprim(Parrayrefu Paddrarray,
+            [transl_normal_path path_self; transl_normal_path path])
   | Texp_setinstvar(path_self, path, _, expr) ->
-      transl_setinstvar (transl_path path_self) path expr
+      transl_setinstvar (transl_normal_path path_self) path expr
   | Texp_override(path_self, modifs) ->
       let cpy = Ident.create "copy" in
       Llet(Strict, cpy,
-           Lapply(Translobj.oo_prim "copy", [transl_path path_self],
+           Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self],
                   Location.none),
            List.fold_right
              (fun (path, _, expr) rem ->
@@ -1017,7 +1018,7 @@ and transl_let rec_flag pat_expr_list body =
 
 and transl_setinstvar self var expr =
   Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray),
-                    [self; transl_path var; transl_exp expr])
+                    [self; transl_normal_path var; transl_exp expr])
 
 and transl_record all_labels repres lbl_expr_list opt_init_expr =
   let size = Array.length all_labels in
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index a2ca63c2a0..840690cc33 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -58,7 +58,7 @@ let rec apply_coercion strict restr arg =
       transl_primitive Location.none p
   | Tcoerce_alias (path, cc) ->
       name_lambda strict arg
-        (fun id -> apply_coercion Alias cc (transl_path path))
+        (fun id -> apply_coercion Alias cc (transl_normal_path path))
 
 and apply_coercion_field id (pos, cc) =
   apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id]))
@@ -119,7 +119,7 @@ let field_path path field =
 
 let mod_prim name =
   try
-    transl_path
+    transl_normal_path
       (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name))
                              Env.empty))
   with Not_found ->
@@ -270,7 +270,8 @@ let rec transl_module cc rootpath mexp =
   | _ ->
   match mexp.mod_desc with
     Tmod_ident (path,_) ->
-      apply_coercion StrictOpt cc (transl_ident_path mexp.mod_env path)
+      apply_coercion StrictOpt cc
+        (transl_path ~loc:mexp.mod_loc mexp.mod_env path)
   | Tmod_structure str ->
       transl_struct [] cc rootpath str
   | Tmod_functor( param, _, mty, body) ->
@@ -341,8 +342,8 @@ and transl_structure fields cc rootpath = function
       let id = decl.cd_id in
       Llet(Strict, id, transl_exception (field_path rootpath id) decl,
            transl_structure (id :: fields) cc rootpath rem)
-  | Tstr_exn_rebind( id, _, path, _, _) ->
-      Llet(Strict, id, transl_ident_path item.str_env path,
+  | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) ->
+      Llet(Strict, id, transl_path ~loc item.str_env path,
            transl_structure (id :: fields) cc rootpath rem)
   | Tstr_module mb ->
       let id = mb.mb_id in
@@ -524,8 +525,8 @@ let transl_store_structure glob map prims str =
       let lam = transl_exception (field_path rootpath id) decl in
       Lsequence(Llet(Strict, id, lam, store_ident id),
                 transl_store rootpath (add_ident false id subst) rem)
-  | Tstr_exn_rebind( id, _, path, _, _) ->
-      let lam = subst_lambda subst (transl_ident_path item.str_env path) in
+  | Tstr_exn_rebind( id, _, path, {Location.loc=loc}, _) ->
+      let lam = subst_lambda subst (transl_path ~loc item.str_env path) in
       Lsequence(Llet(Strict, id, lam, store_ident id),
                 transl_store rootpath (add_ident false id subst) rem)
   | Tstr_module{mb_id=id; mb_expr={mod_desc = Tmod_structure str}} ->
@@ -736,8 +737,8 @@ let transl_toplevel_item item =
                  (make_sequence toploop_setvalue_id idents)
   | Tstr_exception decl ->
       toploop_setvalue decl.cd_id (transl_exception None decl)
-  | Tstr_exn_rebind(id, _, path, _, _) ->
-      toploop_setvalue id (transl_ident_path item.str_env path)
+  | Tstr_exn_rebind(id, _, path, {Location.loc=loc}, _) ->
+      toploop_setvalue id (transl_path ~loc item.str_env path)
   | Tstr_module {mb_id=id; mb_expr=modl} ->
       (* we need to use the unique name for the module because of issues
          with "open" (PR#1672) *)
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index 437c3d71e3..c6a958cfc3 100644
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -20,7 +20,7 @@ open Lambda
 
 let oo_prim name =
   try
-    transl_path
+    transl_normal_path
       (fst (Env.lookup_value (Ldot (Lident "CamlinternalOO", name)) Env.empty))
   with Not_found ->
     fatal_error ("Primitive " ^ name ^ " not found.")
diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference
index c04b7a0c45..5b45a03bd9 100644
--- a/testsuite/tests/typing-modules/aliases.ml.reference
+++ b/testsuite/tests/typing-modules/aliases.ml.reference
@@ -13,8 +13,7 @@
     external unsafe_chr : int -> char = "%identity"
   end
 # - : char = 'B'
-#   C' Char
-Characters 27-29:
+#   Characters 27-29:
   module C'' : (module C) = C';; (* fails *)
                             ^^
 Error: Signature mismatch:
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 8c1bc0bf3b..87785bc436 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -32,7 +32,7 @@ module type OBJ =
 module type EVALPATH =
   sig
     type valu
-    val eval_path: Path.t -> valu
+    val eval_path: Env.t -> Path.t -> valu
     exception Error
     val same_value: valu -> valu -> bool
   end
@@ -361,7 +361,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
         (* Make sure this is the right exception and not an homonym,
            by evaluating the exception found and comparing with the
            identifier contained in the exception bucket *)
-        if not (EVP.same_value (O.field bucket 0) (EVP.eval_path path))
+        if not (EVP.same_value (O.field bucket 0) (EVP.eval_path env path))
         then raise Not_found;
         tree_of_constr_with_args
            (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args
diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
index 8ddf0796b0..3f7b85ab69 100644
--- a/toplevel/genprintval.mli
+++ b/toplevel/genprintval.mli
@@ -28,7 +28,7 @@ module type OBJ =
 module type EVALPATH =
   sig
     type valu
-    val eval_path: Path.t -> valu
+    val eval_path: Env.t -> Path.t -> valu
     exception Error
     val same_value: valu -> valu -> bool
   end
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 044e94da94..20fe39b260 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -221,7 +221,7 @@ let find_printer_type ppf lid =
 let dir_install_printer ppf lid =
   try
     let (ty_arg, path, is_old_style) = find_printer_type ppf lid in
-    let v = eval_path path in
+    let v = eval_path !toplevel_env path in
     let print_function =
       if is_old_style then
         (fun formatter repr -> Obj.obj v (Obj.obj repr))
@@ -262,7 +262,7 @@ let dir_trace ppf lid =
         fprintf ppf "%a is an external function and cannot be traced.@."
         Printtyp.longident lid
     | _ ->
-        let clos = eval_path path in
+        let clos = eval_path !toplevel_env path in
         (* Nothing to do if it's not a closure *)
         if Obj.is_block clos
         && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag)
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index f556fb65ec..503a11e5e0 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -61,12 +61,15 @@ let rec eval_path = function
   | Papply(p1, p2) ->
       fatal_error "Toploop.eval_path"
 
+let eval_path env path =
+  eval_path (Env.normalize_path (Some Location.none) env path)
+
 (* To print values *)
 
 module EvalPath = struct
   type valu = Obj.t
   exception Error
-  let eval_path p = try eval_path p with Symtable.Error _ -> raise Error
+  let eval_path env p = try eval_path env p with Symtable.Error _ -> raise Error
   let same_value v1 v2 = (v1 == v2)
 end
 
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index da607de9d7..324857a835 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -60,7 +60,7 @@ val mod_use_file : formatter -> string -> bool
            [use_file] prints the types and values of the results.
            [use_silently] does not print them.
            [mod_use_file] wrap the file contents into a module. *)
-val eval_path: Path.t -> Obj.t
+val eval_path: Env.t -> Path.t -> Obj.t
         (* Return the toplevel object referred to by the given path *)
 
 (* Printing of values *)
diff --git a/typing/env.ml b/typing/env.ml
index 4513133641..c5350f95f4 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -57,6 +57,7 @@ type error =
   | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
+  | Missing_module of Location.t * Path.t * Path.t
 
 exception Error of error
 
@@ -464,19 +465,28 @@ let find_module path env =
   | Papply(p1, p2) ->
       raise Not_found (* not right *)
 
-let rec normalize_path env path =
+let rec normalize_path lax env path =
   let path =
     match path with
       Pdot(p, s, pos) ->
-        Pdot(normalize_path env p, s, pos)
+        Pdot(normalize_path lax env p, s, pos)
     | Papply(p1, p2) ->
-        Papply(normalize_path env p1, normalize_path env p2)
+        Papply(normalize_path lax env p1, normalize_path true env p2)
     | _ -> path
   in
   try match find_module path env with
-    {md_type=Mty_alias path} -> normalize_path env path
+    {md_type=Mty_alias path} -> normalize_path lax env path
   | _ -> path
-  with Not_found -> path
+  with Not_found when lax
+  || (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
+      path
+
+let normalize_path oloc env path =
+  try normalize_path (oloc = None) env path
+  with Not_found ->
+    match oloc with None -> assert false
+    | Some loc ->
+        raise (Error(Missing_module(loc, path, normalize_path true env path)))
 
 (* Find the manifest type associated to a type when appropriate:
    - the type should be public or should have a private row,
@@ -494,7 +504,7 @@ let find_type_expansion path env =
      purely abstract data types without manifest type definition. *)
   | _ ->
       (* another way to expand is to normalize the path itself *)
-      let path' = normalize_path env path in
+      let path' = normalize_path None env path in
       if Path.same path path' then raise Not_found else
       (decl.type_params,
        newgenty (Tconstr (path', decl.type_params, ref Mnil)),
@@ -511,7 +521,7 @@ let find_type_expansion_opt path env =
      an approximation using their manifest type. *)
   | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
   | _ ->
-      let path' = normalize_path env path in
+      let path' = normalize_path None env path in
       if Path.same path path' then raise Not_found else
       (decl.type_params,
        newgenty (Tconstr (path', decl.type_params, ref Mnil)),
@@ -1684,10 +1694,22 @@ let report_error ppf = function
       fprintf ppf
         "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]"
         export import "The compilation flag -rectypes is required"
+  | Missing_module(_, path1, path2) ->
+      fprintf ppf "@[@[<hov>";
+      if Path.same path1 path2 then
+        fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1)
+      else
+        fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling."
+          (Path.name path1) (Path.name path2);
+      fprintf ppf "@]@ @[%s@ %s@ %s.@]@]"
+        "The compiled interface for module" (Ident.name (Path.head path2))
+        "was not found"
 
 let () =
   Location.register_error_of_exn
     (function
+      | Error (Missing_module (loc, _, _) as err) when loc <> Location.none ->
+          Some (Location.error_of_printer loc report_error err)
       | Error err -> Some (Location.error_of_printer_file report_error err)
       | _ -> None
     )
diff --git a/typing/env.mli b/typing/env.mli
index 3e67506192..7dd074b3d6 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -61,8 +61,10 @@ val find_type_expansion_opt:
    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 normalize_path: t -> Path.t -> Path.t
-        (* Normalize the path to a concrete value or module *)
+val normalize_path: Location.t option -> t -> Path.t -> Path.t
+(* Normalize the path to a concrete value or module.
+   If the option is None, allow returning dangling paths.
+   Otherwise raise a Missing_module error. *)
 
 val has_local_constraints: t -> bool
 val add_gadt_instance_level: int -> t -> t
@@ -180,6 +182,7 @@ type error =
   | Illegal_renaming of string * string * string
   | Inconsistent_import of string * string * string
   | Need_recursive_types of string * string
+  | Missing_module of Location.t * Path.t * Path.t
 
 exception Error of error
 
diff --git a/typing/includemod.ml b/typing/includemod.ml
index d84c8a62a7..f8f0a47aa5 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -172,14 +172,16 @@ 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) ->
-      let p1 = Env.normalize_path env p1
-      and p2 = Env.normalize_path env (Subst.module_path subst p2) in
+      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 *)
-      if Path.same p1 p2 then Tcoerce_none else
-      Printtyp.(Format.eprintf "%a %a@." path p1 path p2;
-      raise Dont_match)
+      if Path.same p1 p2 then Tcoerce_none else raise Dont_match
   | (Mty_alias p1, _) ->
-      let p1 = Env.normalize_path env p1 in
+      let p1 = try
+        Env.normalize_path (Some Location.none) env p1
+      with Env.Error (Env.Missing_module (_, _, path)) ->
+        raise (Error[cxt, env, Unbound_module_path path])
+      in
       let mty1 = Mtype.strengthen env (expand_module_alias env cxt p1) p1 in
       Tcoerce_alias (p1, modtypes env cxt subst mty1 mty2)
   | (_, Mty_ident p2) ->
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 189819e0de..e88e4b55f0 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -563,7 +563,7 @@ let rec expand_path env p =
       | _ -> assert false
       end
   | _ ->
-      let p' = Env.normalize_path env p in
+      let p' = Env.normalize_path None env p in
       if Path.same p p' then p else expand_path env p'
 
 let compare_type_path env tpath1 tpath2 =
diff --git a/typing/typemod.ml b/typing/typemod.ml
index bc6dbd3115..3be12710f9 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -964,7 +964,7 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod =
           { md with mod_type = Mty_alias path }
         else match mty with
           Mty_alias p1 when not alias ->
-            let p1 = Env.normalize_path env p1 in
+            let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
             let mty = Includemod.expand_module_alias env [] p1 in
             { md with
               mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit,