From eda1266114bf61f37b9304dc282caa31ddf7ec9f Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Sep 30 2013 15:54:02 +0000 Subject: passes the testsuite! git-svn-id: http://caml.inria.fr/svn/ocaml/branches/module-alias@14202 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 5d41d4c..2a9a164 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -124,7 +124,7 @@ 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, Mtype.normalize_path cl.cl_env path)::inh_init), + ((envs, (obj_init, Env.normalize_path cl.cl_env path)::inh_init), mkappl(Lvar obj_init, env @ [obj])) | Tcl_structure str -> create_object cl_table obj (fun obj -> @@ -331,7 +331,7 @@ 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 (Mtype.normalize_path cl.cl_env path) path'); + assert (Path.same (Env.normalize_path cl.cl_env path) path'); let lpath = transl_ident_path cl.cl_env path in let inh = Ident.create "inh" and ofs = List.length vals + 1 @@ -398,7 +398,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; - (Mtype.normalize_path cl.cl_env path, obj_init) + (Env.normalize_path cl.cl_env path, obj_init) | Tcl_fun (_, pat, _, cl, partial) -> let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 3a8e75a..8808072 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -40,7 +40,7 @@ let transl_object = (* Translation of value identifiers *) let transl_ident_path env path = - transl_path (Mtype.normalize_path env path) + transl_path (Env.normalize_path env path) (* Translation of primitives *) diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index b2ebba1..b2ee5c5 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -19,7 +19,7 @@ module F(X:sig end) = Char;; module C4 = F(struct end);; C4.chr 66;; -module G(X:sig end) = X;; (* does not alias X *) +module G(X:sig end) = struct module M = X end;; (* does not alias X *) module M = G(struct end);; module M' = struct diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference new file mode 100644 index 0000000..6570891 --- /dev/null +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -0,0 +1,98 @@ + +# module C = Char +# - : char = 'B' +# module C' : + sig + external code : char -> int = "%identity" + val chr : int -> char + val escaped : char -> string + val lowercase : char -> char + val uppercase : char -> char + type t = char + val compare : t -> t -> int + external unsafe_chr : int -> char = "%identity" + end +# - : char = 'B' +# C' Char +Characters 27-29: + module C'' : (module C) = C';; (* fails *) + ^^ +Error: Signature mismatch: + Modules do not match: (module C') is not included in (module Char) +# module C'' = Char +# - : char = 'B' +# module C3 : + sig + external code : char -> int = "%identity" + val chr : int -> char + val escaped : char -> string + val lowercase : char -> char + val uppercase : char -> char + type t = char + val compare : t -> t -> int + external unsafe_chr : int -> char = "%identity" + end +# - : char = 'B' +# val f : 'a list -> int = +# val g : int list -> int = +# module F : + functor (X : sig end) -> + sig + external code : char -> int = "%identity" + val chr : int -> char + val escaped : char -> string + val lowercase : char -> char + val uppercase : char -> char + type t = char + val compare : t -> t -> int + external unsafe_chr : int -> char = "%identity" + end +# module C4 : + sig + external code : char -> int = "%identity" + val chr : int -> char + val escaped : char -> string + val lowercase : char -> char + val uppercase : char -> char + type t = char + val compare : t -> t -> int + external unsafe_chr : int -> char = "%identity" + end +# - : char = 'B' +# module G : functor (X : sig end) -> sig module M : sig end end +# module M : sig module M : sig end end +# module M' : sig module N : sig val x : int end module N' = N end +# - : int = 1 +# module M'' : sig module N' : sig val x : int end end +# - : int = 1 +# module M2 : sig module N : sig val x : int end module N' = N end +# module M3 : sig module N' : sig val x : int end end +# - : int = 1 +# module M3' : sig module N' : sig val x : int end end +# - : int = 1 +# module M4 : sig module N' : sig val x : int end end +# - : int = 1 +# module F : + functor (X : sig end) -> + sig module N : sig val x : int end module N' = N end +# module G : functor (X : sig end) -> sig module N' : sig val x : int end end +# module M5 : sig module N' : sig val x : int end end +# - : int = 1 +# module M : + sig + module D : sig val y : int end + module N : sig val x : int end + module N' = N + end +# module M1 : sig module N : sig val x : int end module N' = N end +# - : int = 1 +# module M2 : sig module N' : sig val x : int end end +# - : int = 1 +# # - : int = 1 +# module M : sig module C = Char module C' = Char end +# module M1 : sig module C : sig val chr : int -> char end module C' = C end +# - : char = 'B' +# module M2 : sig module C' : sig val chr : int -> char end end +# - : char = 'B' +# - : f:('a -> 'b) -> 'a list -> 'b list = +# diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index 3d21780..137943c 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -6,8 +6,8 @@ ^ Error: This expression has type F0.t but an expression was expected of type Foobar.t -# module F : sig type t = Foobar.t end -# val f : F.t -> Foobar.t = +# module F = Foobar +# val f : Foobar.t -> Foobar.t = # module M : sig type t = < m : int > end # module M1 : sig type t = private < m : int; .. > end # module M2 : sig type t = private < m : int; .. > end @@ -24,6 +24,10 @@ Error: This expression has type M1.t but an expression was expected of type ^^ Error: Signature mismatch: Modules do not match: + (module M2) + is not included in + sig type t = private M3.t end + Modules do not match: sig type t = M2.t end is not included in sig type t = private M3.t end @@ -36,6 +40,10 @@ Error: Signature mismatch: ^ Error: Signature mismatch: Modules do not match: + (module M) + is not included in + sig type t = private M3.t end + Modules do not match: sig type t = < m : int > end is not included in sig type t = private M3.t end @@ -48,6 +56,10 @@ Error: Signature mismatch: ^^ Error: Signature mismatch: Modules do not match: + (module M1) + is not included in + sig type t = private M3.t end + Modules do not match: sig type t = M1.t end is not included in sig type t = private M3.t end @@ -61,6 +73,10 @@ Error: Signature mismatch: ^^ Error: Signature mismatch: Modules do not match: + (module M1) + is not included in + sig type t = private < n : int; .. > end + Modules do not match: sig type t = M1.t end is not included in sig type t = private < n : int; .. > end diff --git a/typing/env.ml b/typing/env.ml index 127e48d..c9f14c6 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1303,6 +1303,18 @@ let _ = components_of_functor_appl' := components_of_functor_appl; components_of_module_maker' := components_of_module_maker +let rec normalize_path env path = + let path = + match path with + Pdot(p, s, pos) -> + Pdot(normalize_path env p, s, pos) + | _ -> path + in + try match find_module path env with + {md_type=Mty_alias path} -> normalize_path env path + | _ -> path + with Not_found -> path + (* Insertion of bindings by identifier *) let add_functor_arg ?(arg=false) id env = @@ -1321,7 +1333,12 @@ and add_exception ~check id decl env = store_exception ~check None id (Pident id) decl env env and add_module_declaration ?arg id md env = - let env = store_module None id (Pident id) md env env in + let path = + match md.md_type with + Mty_alias path -> normalize_path env path + | _ -> Pident id + in + let env = store_module None id path md env env in add_functor_arg ?arg id env and add_modtype id info env = @@ -1355,8 +1372,10 @@ let enter_value ?check = enter (store_value ?check) and enter_type = enter (store_type ~check:true) and enter_exception = enter (store_exception ~check:true) and enter_module_declaration ?arg name md env = - let (id, env) = enter store_module name md env in - (id, add_functor_arg ?arg id env) + let id = Ident.create name in + (id, add_module_declaration ?arg id md env) + (* let (id, env) = enter store_module name md env in + (id, add_functor_arg ?arg id env) *) and enter_modtype = enter store_modtype and enter_class = enter store_class and enter_cltype = enter store_cltype diff --git a/typing/env.mli b/typing/env.mli index 7c50ce4..de9189b 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -61,6 +61,8 @@ 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 has_local_constraints: t -> bool val add_gadt_instance_level: int -> t -> t diff --git a/typing/includemod.ml b/typing/includemod.ml index 4a508ac..35f40dd 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -106,10 +106,12 @@ let expand_module_alias env cxt path = with Not_found -> raise(Error[cxt, env, Unbound_module_path path]) +(* let rec normalize_module_path env cxt path = match expand_module_alias env cxt path with Mty_alias path' -> normalize_module_path env cxt path' | _ -> path +*) (* Extract name, kind and ident from a signature item *) @@ -170,16 +172,15 @@ 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 = normalize_module_path env cxt p1 - and p2 = normalize_module_path env cxt (Subst.module_path subst p2) in + let p1 = Env.normalize_path env p1 + and p2 = Env.normalize_path env (Subst.module_path subst p2) in if Path.same p1 p2 then Tcoerce_none else Printtyp.(Format.eprintf "%a %a@." path p1 path p2; raise Dont_match) | (Mty_alias p1, _) -> - let p1 = normalize_module_path env cxt p1 in - let mty1 = expand_module_alias env cxt p1 in - Tcoerce_alias (Mtype.normalize_path env p1, - modtypes env cxt subst mty1 mty2) + let p1 = Env.normalize_path env p1 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) -> try_modtypes2 env cxt mty1 (Subst.modtype subst mty2) | (Mty_ident p1, _) -> diff --git a/typing/mtype.ml b/typing/mtype.ml index 09316de..a0df417 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -17,18 +17,6 @@ open Path open Types -let rec normalize_path env path = - let path = - match path with - Pdot(p, s, pos) -> - Pdot(normalize_path env p, s, pos) - | _ -> path - in - try match Env.find_module path env with - {md_type=Mty_alias path} -> normalize_path env path - | _ -> path - with Not_found -> path - let rec scrape env mty = match mty with Mty_ident p -> diff --git a/typing/mtype.mli b/typing/mtype.mli index 73f295c..fe82473 100644 --- a/typing/mtype.mli +++ b/typing/mtype.mli @@ -36,6 +36,3 @@ val no_code_needed_sig: Env.t -> signature -> bool val enrich_modtype: Env.t -> Path.t -> module_type -> module_type val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration val type_paths: Env.t -> Path.t -> module_type -> Path.t list - -val normalize_path: Env.t -> Path.t -> Path.t - (* Normalize the path to a concrete value or module *)