diff options
Diffstat (limited to 'typing')
| -rw-r--r-- | typing/env.ml | 18 | ||||
| -rw-r--r-- | typing/env.mli | 6 | ||||
| -rw-r--r-- | typing/typemod.ml | 8 |
3 files changed, 27 insertions, 5 deletions
diff --git a/typing/env.ml b/typing/env.ml index e7d15ca13b..9e7791168c 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -329,7 +329,7 @@ let read_pers_struct modname filename = ps_flags = flags } in if ps.ps_name <> modname then error (Illegal_renaming(modname, ps.ps_name, filename)); - (*check_consistency filename ps.ps_crcs;*) + if not !Clflags.transparent_modules then check_consistency ps; List.iter (function Rectypes -> if not !Clflags.recursive_types then @@ -486,6 +486,14 @@ let find_module path env = raise Not_found end +let required_globals = ref [] +let reset_required_globals () = required_globals := [] +let get_required_globals () = !required_globals +let add_required_global id = + if Ident.global id && not !Clflags.transparent_modules + && not (List.exists (Ident.same id) !required_globals) + then required_globals := id :: !required_globals + let rec normalize_path lax env path = let path = match path with @@ -496,7 +504,13 @@ let rec normalize_path lax env path = | _ -> path in try match find_module path env with - {md_type=Mty_alias path} -> normalize_path lax env path + {md_type=Mty_alias path1} -> + let path' = normalize_path lax env path1 in + if lax || !Clflags.transparent_modules then path' else + let id = Path.head path in + if Ident.global id && not (Ident.same id (Path.head path')) + then add_required_global id; + path' | _ -> path with Not_found when lax || (match path with Pident id -> not (Ident.persistent id) | _ -> true) -> diff --git a/typing/env.mli b/typing/env.mli index 5abf11a449..888869ebfc 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -64,7 +64,11 @@ 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. If the option is None, allow returning dangling paths. - Otherwise raise a Missing_module error. *) + Otherwise raise a Missing_module error, and may add forgotten + head as required global. *) +val reset_required_globals: unit -> unit +val get_required_globals: unit -> Ident.t list +val add_required_global: Ident.t -> unit val has_local_constraints: t -> bool val add_gadt_instance_level: int -> t -> t diff --git a/typing/typemod.ml b/typing/typemod.ml index 600be4a1a9..a7749d7a09 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -961,8 +961,9 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod = mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc } in let md = - if alias && not (Env.is_functor_arg path env) then md else - match (Env.find_module path env).md_type with + if alias && not (Env.is_functor_arg path env) then + (Env.add_required_global (Path.head path); md) + else match (Env.find_module path env).md_type with Mty_alias p1 when not alias -> let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in let mty = Includemod.expand_module_alias env [] p1 in @@ -1250,6 +1251,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let sg = match modl.mod_desc with Tmod_ident (p, _) when not (Env.is_functor_arg p env) -> + Env.add_required_global (Path.head p); let pos = ref 0 in List.map (function @@ -1301,6 +1303,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = str, sg, final_env let type_toplevel_phrase env s = + Env.reset_required_globals (); type_structure ~toplevel:true false None env s Location.none (*let type_module_alias = type_module ~alias:true true false None*) let type_module = type_module true false None @@ -1441,6 +1444,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = Cmt_format.set_saved_types []; try Typecore.reset_delayed_checks (); + Env.reset_required_globals (); let (str, sg, finalenv) = type_structure initial_env ast (Location.in_file sourcefile) in let simple_sg = simplify_signature sg in |