Fix wrong calls to Env.normalize_path on non-module paths (#2131)
parent
f6837be875
commit
4c130cae87
3
Changes
3
Changes
|
@ -683,6 +683,9 @@ Working version
|
||||||
(Alain Frisch, review by Armaël Guéneau and Gabriel Scherer,
|
(Alain Frisch, review by Armaël Guéneau and Gabriel Scherer,
|
||||||
report by Hugo Heuzard)
|
report by Hugo Heuzard)
|
||||||
|
|
||||||
|
- GPR#2131: fix wrong calls to Env.normalize_path on non-module paths
|
||||||
|
(Alain Frisch, review by Jacques Garrigue)
|
||||||
|
|
||||||
|
|
||||||
OCaml 4.07.1 (4 October 2018)
|
OCaml 4.07.1 (4 October 2018)
|
||||||
-----------------------------
|
-----------------------------
|
||||||
|
|
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -91,7 +91,7 @@ let used_primitives = Hashtbl.create 7
|
||||||
let add_used_primitive loc env path =
|
let add_used_primitive loc env path =
|
||||||
match path with
|
match path with
|
||||||
Some (Path.Pdot _ as path) ->
|
Some (Path.Pdot _ as path) ->
|
||||||
let path = Env.normalize_path (Some loc) env path in
|
let path = Env.normalize_path_prefix (Some loc) env path in
|
||||||
let unit = Path.head path in
|
let unit = Path.head path in
|
||||||
if Ident.global unit && not (Hashtbl.mem used_primitives path)
|
if Ident.global unit && not (Hashtbl.mem used_primitives path)
|
||||||
then Hashtbl.add used_primitives path loc
|
then Hashtbl.add used_primitives path loc
|
||||||
|
|
|
@ -0,0 +1,17 @@
|
||||||
|
(* TEST
|
||||||
|
* expect
|
||||||
|
*)
|
||||||
|
|
||||||
|
module X = struct
|
||||||
|
|
||||||
|
module B = List
|
||||||
|
|
||||||
|
exception B of {x:int}
|
||||||
|
end
|
||||||
|
|
||||||
|
let _ = X.B {x=2}
|
||||||
|
;;
|
||||||
|
[%%expect{|
|
||||||
|
module X : sig module B = List exception B of { x : int; } end
|
||||||
|
- : exn = X.B {x = 2}
|
||||||
|
|}]
|
|
@ -4,6 +4,7 @@ firstclass.ml
|
||||||
generative.ml
|
generative.ml
|
||||||
nondep.ml
|
nondep.ml
|
||||||
nondep_private_abbrev.ml
|
nondep_private_abbrev.ml
|
||||||
|
normalize_path.ml
|
||||||
pr5911.ml
|
pr5911.ml
|
||||||
pr6394.ml
|
pr6394.ml
|
||||||
pr7207.ml
|
pr7207.ml
|
||||||
|
|
|
@ -756,7 +756,7 @@ let rec normalize_package_path env p =
|
||||||
match p with
|
match p with
|
||||||
Path.Pdot (p1, s) ->
|
Path.Pdot (p1, s) ->
|
||||||
(* For module aliases *)
|
(* For module aliases *)
|
||||||
let p1' = Env.normalize_path None env p1 in
|
let p1' = Env.normalize_module_path None env p1 in
|
||||||
if Path.same p1 p1' then p else
|
if Path.same p1 p1' then p else
|
||||||
normalize_package_path env (Path.Pdot (p1', s))
|
normalize_package_path env (Path.Pdot (p1', s))
|
||||||
| _ -> p
|
| _ -> p
|
||||||
|
@ -1511,7 +1511,7 @@ let expand_abbrev_gen kind find_type_expansion env ty =
|
||||||
match find_type_expansion path env with
|
match find_type_expansion path env with
|
||||||
| exception Not_found ->
|
| exception Not_found ->
|
||||||
(* another way to expand is to normalize the path itself *)
|
(* another way to expand is to normalize the path itself *)
|
||||||
let path' = Env.normalize_path None env path in
|
let path' = Env.normalize_type_path None env path in
|
||||||
if Path.same path path' then raise Cannot_expand
|
if Path.same path path' then raise Cannot_expand
|
||||||
else newty2 level (Tconstr (path', args, abbrev))
|
else newty2 level (Tconstr (path', args, abbrev))
|
||||||
| (params, body, lv) ->
|
| (params, body, lv) ->
|
||||||
|
|
|
@ -1106,18 +1106,25 @@ let add_required_global id =
|
||||||
&& not (List.exists (Ident.same id) !required_globals)
|
&& not (List.exists (Ident.same id) !required_globals)
|
||||||
then required_globals := id :: !required_globals
|
then required_globals := id :: !required_globals
|
||||||
|
|
||||||
let rec normalize_path lax env path =
|
let rec normalize_module_path lax env = function
|
||||||
let path =
|
| Pident id as path when lax && Ident.persistent id ->
|
||||||
match path with
|
path (* fast path (avoids lookup) *)
|
||||||
Pdot(p, s) ->
|
| Pdot (p, s) as path ->
|
||||||
Pdot(normalize_path lax env p, s)
|
let p' = normalize_module_path lax env p in
|
||||||
| Papply(p1, p2) ->
|
if p == p' then expand_module_path lax env path
|
||||||
Papply(normalize_path lax env p1, normalize_path true env p2)
|
else expand_module_path lax env (Pdot(p', s))
|
||||||
| _ -> path
|
| Papply (p1, p2) as path ->
|
||||||
in
|
let p1' = normalize_module_path lax env p1 in
|
||||||
|
let p2' = normalize_module_path true env p2 in
|
||||||
|
if p1 == p1' && p2 == p2' then expand_module_path lax env path
|
||||||
|
else expand_module_path lax env (Papply(p1', p2'))
|
||||||
|
| Pident _ as path ->
|
||||||
|
expand_module_path lax env path
|
||||||
|
|
||||||
|
and expand_module_path lax env path =
|
||||||
try match find_module ~alias:true path env with
|
try match find_module ~alias:true path env with
|
||||||
{md_type=Mty_alias path1} ->
|
{md_type=Mty_alias path1} ->
|
||||||
let path' = normalize_path lax env path1 in
|
let path' = normalize_module_path lax env path1 in
|
||||||
if lax || !Clflags.transparent_modules then path' else
|
if lax || !Clflags.transparent_modules then path' else
|
||||||
let id = Path.head path in
|
let id = Path.head path in
|
||||||
if Ident.global id && not (Ident.same id (Path.head path'))
|
if Ident.global id && not (Ident.same id (Path.head path'))
|
||||||
|
@ -1128,22 +1135,50 @@ let rec normalize_path lax env path =
|
||||||
|| (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
|
|| (match path with Pident id -> not (Ident.persistent id) | _ -> true) ->
|
||||||
path
|
path
|
||||||
|
|
||||||
let normalize_path oloc env path =
|
let normalize_module_path oloc env path =
|
||||||
try normalize_path (oloc = None) env path
|
try normalize_module_path (oloc = None) env path
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
match oloc with None -> assert false
|
match oloc with None -> assert false
|
||||||
| Some loc ->
|
| Some loc ->
|
||||||
raise (Error(Missing_module(loc, path, normalize_path true env path)))
|
raise (Error(Missing_module(loc, path,
|
||||||
|
normalize_module_path true env path)))
|
||||||
|
|
||||||
let normalize_path_prefix oloc env path =
|
let normalize_path_prefix oloc env path =
|
||||||
match path with
|
match path with
|
||||||
Pdot(p, s) ->
|
Pdot(p, s) ->
|
||||||
Pdot(normalize_path oloc env p, s)
|
let p2 = normalize_module_path oloc env p in
|
||||||
|
if p == p2 then path else Pdot(p2, s)
|
||||||
| Pident _ ->
|
| Pident _ ->
|
||||||
path
|
path
|
||||||
| Papply _ ->
|
| Papply _ ->
|
||||||
assert false
|
assert false
|
||||||
|
|
||||||
|
let is_uident s =
|
||||||
|
match s.[0] with
|
||||||
|
| 'A'..'Z' -> true
|
||||||
|
| _ -> false
|
||||||
|
|
||||||
|
let normalize_type_path oloc env path =
|
||||||
|
(* Inlined version of Path.is_constructor_typath:
|
||||||
|
constructor type paths (i.e. path pointing to an inline
|
||||||
|
record argument of a constructpr) are built as a regular
|
||||||
|
type path followed by a capitalized constructor name. *)
|
||||||
|
match path with
|
||||||
|
| Pident _ ->
|
||||||
|
path
|
||||||
|
| Pdot(p, s) ->
|
||||||
|
let p2 =
|
||||||
|
if is_uident s && not (is_uident (Path.last p)) then
|
||||||
|
(* Cstr M.t.C *)
|
||||||
|
normalize_path_prefix oloc env p
|
||||||
|
else
|
||||||
|
(* Regular M.t, Ext M.C *)
|
||||||
|
normalize_module_path oloc env p
|
||||||
|
in
|
||||||
|
if p == p2 then path else Pdot (p2, s)
|
||||||
|
| Papply _ ->
|
||||||
|
assert false
|
||||||
|
|
||||||
let find_module path env =
|
let find_module path env =
|
||||||
find_module ~alias:false path env
|
find_module ~alias:false path env
|
||||||
|
|
||||||
|
|
|
@ -87,13 +87,21 @@ val find_constructor_address: Path.t -> t -> address
|
||||||
|
|
||||||
val add_functor_arg: Ident.t -> t -> t
|
val add_functor_arg: Ident.t -> t -> t
|
||||||
val is_functor_arg: Path.t -> t -> bool
|
val is_functor_arg: Path.t -> t -> bool
|
||||||
val normalize_path: Location.t option -> t -> Path.t -> Path.t
|
|
||||||
(* Normalize the path to a concrete value or module.
|
val normalize_module_path: Location.t option -> t -> Path.t -> Path.t
|
||||||
|
(* Normalize the path to a concrete module.
|
||||||
If the option is None, allow returning dangling paths.
|
If the option is None, allow returning dangling paths.
|
||||||
Otherwise raise a Missing_module error, and may add forgotten
|
Otherwise raise a Missing_module error, and may add forgotten
|
||||||
head as required global. *)
|
head as required global. *)
|
||||||
|
|
||||||
|
val normalize_type_path: Location.t option -> t -> Path.t -> Path.t
|
||||||
|
(* Normalize the prefix part of the type path *)
|
||||||
|
|
||||||
val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
|
val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
|
||||||
(* Only normalize the prefix part of the path *)
|
(* Normalize the prefix part of other kinds of paths
|
||||||
|
(value/modtype/etc) *)
|
||||||
|
|
||||||
|
|
||||||
val reset_required_globals: unit -> unit
|
val reset_required_globals: unit -> unit
|
||||||
val get_required_globals: unit -> Ident.t list
|
val get_required_globals: unit -> Ident.t list
|
||||||
val add_required_global: Ident.t -> unit
|
val add_required_global: Ident.t -> unit
|
||||||
|
|
|
@ -264,14 +264,16 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
|
||||||
if Env.is_functor_arg p2 env then
|
if Env.is_functor_arg p2 env then
|
||||||
raise (Error[cxt, env, Invalid_module_alias p2]);
|
raise (Error[cxt, env, Invalid_module_alias p2]);
|
||||||
if not (Path.same p1 p2) then begin
|
if not (Path.same p1 p2) then begin
|
||||||
let p1 = Env.normalize_path None env p1
|
let p1 = Env.normalize_module_path None env p1
|
||||||
and p2 = Env.normalize_path None env (Subst.module_path subst p2) in
|
and p2 = Env.normalize_module_path None env
|
||||||
|
(Subst.module_path subst p2)
|
||||||
|
in
|
||||||
if not (Path.same p1 p2) then raise Dont_match
|
if not (Path.same p1 p2) then raise Dont_match
|
||||||
end;
|
end;
|
||||||
Tcoerce_none
|
Tcoerce_none
|
||||||
| (Mty_alias p1, _) -> begin
|
| (Mty_alias p1, _) -> begin
|
||||||
let p1 = try
|
let p1 = try
|
||||||
Env.normalize_path (Some Location.none) env p1
|
Env.normalize_module_path (Some Location.none) env p1
|
||||||
with Env.Error (Env.Missing_module (_, _, path)) ->
|
with Env.Error (Env.Missing_module (_, _, path)) ->
|
||||||
raise (Error[cxt, env, Unbound_module_path path])
|
raise (Error[cxt, env, Unbound_module_path path])
|
||||||
in
|
in
|
||||||
|
|
|
@ -19,7 +19,8 @@ type t =
|
||||||
| Papply of t * t
|
| Papply of t * t
|
||||||
|
|
||||||
let rec same p1 p2 =
|
let rec same p1 p2 =
|
||||||
match (p1, p2) with
|
p1 == p2
|
||||||
|
|| match (p1, p2) with
|
||||||
(Pident id1, Pident id2) -> Ident.same id1 id2
|
(Pident id1, Pident id2) -> Ident.same id1 id2
|
||||||
| (Pdot(p1, s1), Pdot(p2, s2)) -> s1 = s2 && same p1 p2
|
| (Pdot(p1, s1), Pdot(p2, s2)) -> s1 = s2 && same p1 p2
|
||||||
| (Papply(fun1, arg1), Papply(fun2, arg2)) ->
|
| (Papply(fun1, arg1), Papply(fun2, arg2)) ->
|
||||||
|
@ -27,7 +28,8 @@ let rec same p1 p2 =
|
||||||
| (_, _) -> false
|
| (_, _) -> false
|
||||||
|
|
||||||
let rec compare p1 p2 =
|
let rec compare p1 p2 =
|
||||||
match (p1, p2) with
|
if p1 == p2 then 0
|
||||||
|
else match (p1, p2) with
|
||||||
(Pident id1, Pident id2) -> Ident.compare id1 id2
|
(Pident id1, Pident id2) -> Ident.compare id1 id2
|
||||||
| (Pdot(p1, s1), Pdot(p2, s2)) ->
|
| (Pdot(p1, s1), Pdot(p2, s2)) ->
|
||||||
let h = compare p1 p2 in
|
let h = compare p1 p2 in
|
||||||
|
|
|
@ -566,7 +566,7 @@ let rec normalize_type_path ?(cache=false) env p =
|
||||||
(p, Nth (index params ty))
|
(p, Nth (index params ty))
|
||||||
with
|
with
|
||||||
Not_found ->
|
Not_found ->
|
||||||
(Env.normalize_path None env p, Id)
|
(Env.normalize_type_path None env p, Id)
|
||||||
|
|
||||||
let penalty s =
|
let penalty s =
|
||||||
if s <> "" && s.[0] = '_' then
|
if s <> "" && s.[0] = '_' then
|
||||||
|
|
|
@ -680,7 +680,7 @@ let rec expand_path env p =
|
||||||
| _ -> assert false
|
| _ -> assert false
|
||||||
end
|
end
|
||||||
| _ ->
|
| _ ->
|
||||||
let p' = Env.normalize_path None env p in
|
let p' = Env.normalize_type_path None env p in
|
||||||
if Path.same p p' then p else expand_path env p'
|
if Path.same p p' then p else expand_path env p'
|
||||||
|
|
||||||
let compare_type_path env tpath1 tpath2 =
|
let compare_type_path env tpath1 tpath2 =
|
||||||
|
|
|
@ -1723,7 +1723,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
|
||||||
(Env.add_required_global (Path.head path); md)
|
(Env.add_required_global (Path.head path); md)
|
||||||
else match (Env.find_module path env).md_type with
|
else match (Env.find_module path env).md_type with
|
||||||
| Mty_alias p1 when not alias ->
|
| Mty_alias p1 when not alias ->
|
||||||
let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in
|
let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in
|
||||||
let mty = Includemod.expand_module_alias env [] p1 in
|
let mty = Includemod.expand_module_alias env [] p1 in
|
||||||
{ md with
|
{ md with
|
||||||
mod_desc =
|
mod_desc =
|
||||||
|
|
Loading…
Reference in New Issue