From 251289a3a19bac4d8138e756d5c0fb5b5de18f50 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Wed, 2 Oct 2013 08:34:01 +0000 Subject: fix exn_rebind: camlp4 compiles again git-svn-id: http://caml.inria.fr/svn/ocaml/branches/module-alias@14207 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- bytecomp/lambda.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'bytecomp/lambda.ml') diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index cfced858e..baaefc8d8 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -253,10 +253,10 @@ and sameswitch sw1 sw2 = | (Some a1, Some a2) -> same a1 a2 | _ -> false) -let name_lambda arg fn = +let name_lambda strict arg fn = match arg with Lvar id -> fn id - | _ -> let id = Ident.create "let" in Llet(Strict, id, arg, fn id) + | _ -> let id = Ident.create "let" in Llet(strict, id, arg, fn id) let name_lambda_list args fn = let rec name_list names = function -- cgit v1.2.3-70-g09d2 From 06d511c857fbf2f0144b1dfa88ef3cd8eb95cf37 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Thu, 3 Oct 2013 12:51:30 +0000 Subject: more exception paths requiring normalization git-svn-id: http://caml.inria.fr/svn/ocaml/branches/module-alias@14211 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- bytecomp/lambda.ml | 5 +++++ bytecomp/lambda.mli | 1 + bytecomp/matching.ml | 3 ++- bytecomp/translcore.ml | 10 ++++------ bytecomp/translcore.mli | 1 - 5 files changed, 12 insertions(+), 8 deletions(-) (limited to 'bytecomp/lambda.ml') diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index baaefc8d8..01c55af55 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -386,6 +386,11 @@ let rec transl_path = function | 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) + (* Compile a sequence of expressions *) let rec make_sequence fn = function diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 42cb02b45..6538c6f5f 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -211,6 +211,7 @@ 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 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 2572b843e..57270e35d 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -2158,7 +2158,8 @@ let combine_constructor arg ex_pat cstr partial ctx def match ex with | Cstr_exception (path, _) -> Lifthenelse(Lprim(Pintcomp Ceq, - [Lprim(Pfield 0, [arg]); transl_path path]), + [Lprim(Pfield 0, [arg]); + transl_ident_path ex_pat.pat_env path]), act, rem) | _ -> assert false) tests default in diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 88080727e..abada8543 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -38,10 +38,6 @@ let transl_object = ref (fun id s cl -> assert false : Ident.t -> string list -> class_expr -> lambda) -(* Translation of value identifiers *) -let transl_ident_path env path = - transl_path (Env.normalize_path env path) - (* Translation of primitives *) let comparisons_table = create_hashtable 11 [ @@ -725,7 +721,8 @@ and transl_exp0 e = Lprim(Pmakeblock(n, Immutable), ll) end | Cstr_exception (path, _) -> - Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) + Lprim(Pmakeblock(0, Immutable), + transl_ident_path e.exp_env path :: ll) end | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in @@ -803,7 +800,8 @@ and transl_exp0 e = in event_after e lam | Texp_new (cl, _, _) -> - Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none) + Lapply(Lprim(Pfield 0, [transl_ident_path e.exp_env cl]), + [lambda_unit], Location.none) | Texp_instvar(path_self, path, _) -> Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) | Texp_setinstvar(path_self, path, _, expr) -> diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 797757846..842ed78dc 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -24,7 +24,6 @@ val transl_let: rec_flag -> value_binding list -> lambda -> lambda val transl_primitive: Location.t -> Primitive.description -> lambda val transl_exception: Path.t option -> constructor_declaration -> lambda -val transl_ident_path: Env.t -> Path.t -> lambda val check_recursive_lambda: Ident.t list -> lambda -> bool -- cgit v1.2.3-70-g09d2 From 7a904bb8db40a21ba6fd24e5feed9a8dd0c32d28 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Fri, 4 Oct 2013 02:06:40 +0000 Subject: 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 | 8 ++--- bytecomp/lambda.ml | 8 ++--- bytecomp/lambda.mli | 4 +-- bytecomp/matching.ml | 5 +-- bytecomp/translclass.ml | 22 +++++++------ bytecomp/translcore.ml | 19 ++++++------ bytecomp/translmod.ml | 19 ++++++------ bytecomp/translobj.ml | 2 +- .../tests/typing-modules/aliases.ml.reference | 3 +- toplevel/genprintval.ml | 4 +-- toplevel/genprintval.mli | 2 +- toplevel/topdirs.ml | 4 +-- toplevel/toploop.ml | 5 ++- toplevel/toploop.mli | 2 +- typing/env.ml | 36 +++++++++++++++++----- typing/env.mli | 7 +++-- typing/includemod.ml | 14 +++++---- typing/typecore.ml | 2 +- typing/typemod.ml | 2 +- 19 files changed, 102 insertions(+), 66 deletions(-) (limited to 'bytecomp/lambda.ml') diff --git a/.depend b/.depend index ab2130dd4..8d35f6c93 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 01c55af55..1b6b805d0 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 6538c6f5f..7f5db6906 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 57270e35d..3b06070d5 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 2a9a164fc..55ddab3bc 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 abada8543..12e0e26de 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 a2ca63c2a..840690cc3 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 437c3d71e..c6a958cfc 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 c04b7a0c4..5b45a03bd 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 8c1bc0bf3..87785bc43 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 8ddf0796b..3f7b85ab6 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 044e94da9..20fe39b26 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 f556fb65e..503a11e5e 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 da607de9d..324857a83 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 451313364..c5350f95f 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 "@[Unit %s imports from %s, which uses recursive types.@ %s@]" export import "The compilation flag -rectypes is required" + | Missing_module(_, path1, path2) -> + fprintf ppf "@[@["; + 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 3e6750619..7dd074b3d 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 d84c8a62a..f8f0a47aa 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 189819e0d..e88e4b55f 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 bc6dbd311..3be12710f 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, -- cgit v1.2.3-70-g09d2