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

.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 \

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 *)
 

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

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);

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)

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

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) *)

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.")

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:

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

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

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)

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
 

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 *)