diff options
31 files changed, 102 insertions, 90 deletions
diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 9423b5803..64b737a31 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex cd845916d..078d9b49a 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 42804220b..d2a8a2726 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 16c481bf8..8bf26087a 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -316,7 +316,7 @@ and transl_structure fields cc rootpath = function (transl_structure ext_fields cc rootpath rem) | Tstr_modtype(id, _, decl) -> transl_structure fields cc rootpath rem - | Tstr_open (path, _) -> + | Tstr_open _ -> transl_structure fields cc rootpath rem | Tstr_class cl_list -> let ids = List.map (fun (ci,_,_) -> ci.ci_id_class) cl_list in @@ -373,7 +373,7 @@ let rec defined_idents = function | Tstr_recmodule decls -> List.map (fun (id, _, _, _) -> id) decls @ defined_idents rem | Tstr_modtype(id, _, decl) -> defined_idents rem - | Tstr_open (path, _) -> defined_idents rem + | Tstr_open _ -> defined_idents rem | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem @@ -393,7 +393,7 @@ let rec more_idents = function | Tstr_exn_rebind(id, _, path, _) -> more_idents rem | Tstr_recmodule decls -> more_idents rem | Tstr_modtype(id, _, decl) -> more_idents rem - | Tstr_open (path, _) -> more_idents rem + | Tstr_open _ -> more_idents rem | Tstr_class cl_list -> more_idents rem | Tstr_class_type cl_list -> more_idents rem | Tstr_include(modl, ids) -> more_idents rem @@ -415,7 +415,7 @@ and all_idents = function | Tstr_recmodule decls -> List.map (fun (id, _, _, _) -> id) decls @ all_idents rem | Tstr_modtype(id, _, decl) -> all_idents rem - | Tstr_open (path, _) -> all_idents rem + | Tstr_open _ -> all_idents rem | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem | Tstr_class_type cl_list -> all_idents rem @@ -510,7 +510,7 @@ let transl_store_structure glob map prims str = transl_store rootpath (add_idents true ids subst) rem)) | Tstr_modtype(id, _, decl) -> transl_store rootpath subst rem - | Tstr_open (path, _) -> + | Tstr_open _ -> transl_store rootpath subst rem | Tstr_class cl_list -> let ids = List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list in @@ -701,7 +701,7 @@ let transl_toplevel_item item = (make_sequence toploop_setvalue_id idents) | Tstr_modtype(id, _, decl) -> lambda_unit - | Tstr_open (path, _) -> + | Tstr_open _ -> lambda_unit | Tstr_class cl_list -> (* we need to use unique names for the classes because there might diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index c2b850ecc..3c04214aa 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -864,7 +864,7 @@ value varify_constructors var_names = let e2 = ExSeq loc el in mkexp loc (Pexp_while (expr e1) (expr e2)) | <:expr@loc< let open $i$ in $e$ >> -> - mkexp loc (Pexp_open (long_uident i) (expr e)) + mkexp loc (Pexp_open Fresh (long_uident i) (expr e)) | <:expr@loc< (module $me$ : $pt$) >> -> mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)), Some (mktyp loc (Ptyp_package (package_type pt))), None)) @@ -1008,7 +1008,7 @@ value varify_constructors var_names = in [mksig loc (Psig_modtype (with_loc n loc) si) :: l] | SgOpn loc id -> - [mksig loc (Psig_open (long_uident id)) :: l] + [mksig loc (Psig_open Fresh (long_uident id)) :: l] | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l] | SgVal loc n t -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t [])) :: l] | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ] @@ -1075,7 +1075,7 @@ value varify_constructors var_names = [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] | StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l] | StOpn loc id -> - [mkstr loc (Pstr_open (long_uident id)) :: l] + [mkstr loc (Pstr_open Fresh (long_uident id)) :: l] | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l] | StVal loc rf bi -> [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l] diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 9e8309b66..7ccaa7537 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -15167,7 +15167,7 @@ module Struct = let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while ((expr e1), (expr e2))) | Ast.ExOpI (loc, i, e) -> - mkexp loc (Pexp_open ((long_uident i), (expr e))) + mkexp loc (Pexp_open (Fresh, (long_uident i), (expr e))) | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) -> mkexp loc (Pexp_constraint @@ -15347,7 +15347,7 @@ module Struct = | _ -> Pmodtype_manifest (module_type mt)) in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l | SgOpn (loc, id) -> - (mksig loc (Psig_open (long_uident id))) :: l + (mksig loc (Psig_open (Fresh, long_uident id))) :: l | SgTyp (loc, tdl) -> (mksig loc (Psig_type (mktype_decl tdl []))) :: l | SgVal (loc, n, t) -> @@ -15457,7 +15457,7 @@ module Struct = (Pstr_modtype ((with_loc n loc), (module_type mt)))) :: l | StOpn (loc, id) -> - (mkstr loc (Pstr_open (long_uident id))) :: l + (mkstr loc (Pstr_open (Fresh, long_uident id))) :: l | StTyp (loc, tdl) -> (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l | StVal (loc, rf, bi) -> diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 7d282f6d7..039bbb482 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1418,7 +1418,7 @@ module Analyser = in (0, new_env2, [ Element_module_type mt ]) - | Parsetree.Pstr_open longident -> + | Parsetree.Pstr_open (_, longident) -> (* A VOIR : enrichir l'environnement quand open ? *) let ele_comments = match comment_opt with None -> [] diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index 0cad8ffc7..5450c8616 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -206,7 +206,7 @@ let mkpath = function ~f:(fun acc x -> Pdot (acc, x, 0)) let get_fields ~prefix ~sign self = - let env = open_signature (mkpath prefix) sign initial in + let env = open_signature Fresh (mkpath prefix) sign initial in match (expand_head env self).desc with Tobject (ty_obj, _) -> let l,_ = flatten_fields ty_obj in l diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 6ba813c4c..13847e280 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -187,10 +187,10 @@ let rec search_pos_signature l ~pos ~env = List.fold_left l ~init:env ~f: begin fun env pt -> let env = match pt.psig_desc with - Psig_open id -> + Psig_open (ovf, id) -> let path, mt = lookup_module id.txt env in begin match mt with - Mty_signature sign -> open_signature path sign env + Mty_signature sign -> open_signature ovf path sign env | _ -> env end | sign_item -> @@ -220,7 +220,8 @@ let rec search_pos_signature l ~pos ~env = List.iter l ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) (* The last cases should not happen in generated interfaces *) - | Psig_open lid -> add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc + | Psig_open (_, lid) -> + add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc | Psig_include t -> search_pos_module t ~pos ~env end; env @@ -325,7 +326,7 @@ let dummy_item = Sig_modtype (Ident.create "dummy", Modtype_abstract) let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = let env = match path with None -> env - | Some path -> Env.open_signature path sign env in + | Some path -> Env.open_signature Fresh path sign env in let title = match title, path with Some title, _ -> title | None, Some path -> string_of_path path diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml index 9cd1014d8..600e4650b 100644 --- a/otherlibs/labltk/browser/viewer.ml +++ b/otherlibs/labltk/browser/viewer.ml @@ -239,7 +239,7 @@ let view_defined ~env ?(show_all=false) modlid = in let l = iter_sign sign [] in let title = string_of_path path in - let env = open_signature path sign env in + let env = open_signature Asttypes.Fresh path sign env in !choose_symbol_ref l ~title ~signature:sign ~env ~path; if show_all then view_signature sign ~title ~env ~path | _ -> () diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 3cb24a45a..2caca7c67 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -173,7 +173,7 @@ module MT = struct let module_ ?loc a b = mk_item ?loc (Psig_module (a, b)) let rec_module ?loc a = mk_item ?loc (Psig_recmodule a) let modtype ?loc a b = mk_item ?loc (Psig_modtype (a, b)) - let open_ ?loc a = mk_item ?loc (Psig_open a) + let open_ ?loc a b = mk_item ?loc (Psig_open (a, b)) let include_ ?loc a = mk_item ?loc (Psig_include a) let class_ ?loc a = mk_item ?loc (Psig_class a) let class_type ?loc a = mk_item ?loc (Psig_class_type a) @@ -188,7 +188,7 @@ module MT = struct | Psig_recmodule l -> rec_module ~loc (List.map (map_tuple (map_loc sub) (sub # module_type)) l) | Psig_modtype (s, Pmodtype_manifest mt) -> modtype ~loc (map_loc sub s) (Pmodtype_manifest (sub # module_type mt)) | Psig_modtype (s, Pmodtype_abstract) -> modtype ~loc (map_loc sub s) Pmodtype_abstract - | Psig_open s -> open_ ~loc (map_loc sub s) + | Psig_open (ovf, s) -> open_ ~loc ovf (map_loc sub s) | Psig_include mt -> include_ ~loc (sub # module_type mt) | Psig_class l -> class_ ~loc (List.map (sub # class_description) l) | Psig_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l) @@ -227,7 +227,7 @@ module M = struct let module_ ?loc a b = mk_item ?loc (Pstr_module (a, b)) let rec_module ?loc a = mk_item ?loc (Pstr_recmodule a) let modtype ?loc a b = mk_item ?loc (Pstr_modtype (a, b)) - let open_ ?loc a = mk_item ?loc (Pstr_open a) + let open_ ?loc a b = mk_item ?loc (Pstr_open (a, b)) let class_ ?loc a = mk_item ?loc (Pstr_class a) let class_type ?loc a = mk_item ?loc (Pstr_class_type a) let include_ ?loc a = mk_item ?loc (Pstr_include a) @@ -244,7 +244,7 @@ module M = struct | Pstr_module (s, m) -> module_ ~loc (map_loc sub s) (sub # module_expr m) | Pstr_recmodule l -> rec_module ~loc (List.map (fun (s, mty, me) -> (map_loc sub s, sub # module_type mty, sub # module_expr me)) l) | Pstr_modtype (s, mty) -> modtype ~loc (map_loc sub s) (sub # module_type mty) - | Pstr_open lid -> open_ ~loc (map_loc sub lid) + | Pstr_open (ovf, lid) -> open_ ~loc ovf (map_loc sub lid) | Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l) | Pstr_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l) | Pstr_include e -> include_ ~loc (sub # module_expr e) @@ -287,7 +287,7 @@ module E = struct let object_ ?loc a = mk ?loc (Pexp_object a) let newtype ?loc a b = mk ?loc (Pexp_newtype (a, b)) let pack ?loc a = mk ?loc (Pexp_pack a) - let open_ ?loc a b = mk ?loc (Pexp_open (a, b)) + let open_ ?loc a b c = mk ?loc (Pexp_open (a, b, c)) let lid ?(loc = Location.none) lid = ident ~loc (mkloc (Longident.parse lid) loc) let apply_nolabs ?loc f el = apply ?loc f (List.map (fun e -> ("", e)) el) @@ -328,7 +328,7 @@ module E = struct | Pexp_object cls -> object_ ~loc (sub # class_structure cls) | Pexp_newtype (s, e) -> newtype ~loc s (sub # expr e) | Pexp_pack me -> pack ~loc (sub # module_expr me) - | Pexp_open (lid, e) -> open_ ~loc (map_loc sub lid) (sub # expr e) + | Pexp_open (ovf, lid, e) -> open_ ~loc ovf (map_loc sub lid) (sub # expr e) end module P = struct diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index 74714cdb2..10be4a8eb 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -145,7 +145,7 @@ module MT: val module_: ?loc:Location.t -> string loc -> module_type -> signature_item val rec_module: ?loc:Location.t -> (string loc * module_type) list -> signature_item val modtype: ?loc:Location.t -> string loc -> modtype_declaration -> signature_item - val open_: ?loc:Location.t -> Longident.t loc -> signature_item + val open_: ?loc:Location.t -> override_flag -> Longident.t loc -> signature_item val include_: ?loc:Location.t -> module_type -> signature_item val class_: ?loc:Location.t -> class_description list -> signature_item val class_type: ?loc:Location.t -> class_type_declaration list -> signature_item @@ -172,7 +172,7 @@ module M: val module_: ?loc:Location.t -> string loc -> module_expr -> structure_item val rec_module: ?loc:Location.t -> (string loc * module_type * module_expr) list -> structure_item val modtype: ?loc:Location.t -> string loc -> module_type -> structure_item - val open_: ?loc:Location.t -> Longident.t loc -> structure_item + val open_: ?loc:Location.t -> override_flag -> Longident.t loc -> structure_item val class_: ?loc:Location.t -> class_declaration list -> structure_item val class_type: ?loc:Location.t -> class_type_declaration list -> structure_item val include_: ?loc:Location.t -> module_expr -> structure_item @@ -214,7 +214,7 @@ module E: val object_: ?loc:Location.t -> class_structure -> expression val newtype: ?loc:Location.t -> string -> expression -> expression val pack: ?loc:Location.t -> module_expr -> expression - val open_: ?loc:Location.t -> Longident.t loc -> expression -> expression + val open_: ?loc:Location.t -> override_flag -> Longident.t loc -> expression -> expression val lid: ?loc:Location.t -> string -> expression val apply_nolabs: ?loc:Location.t -> expression -> expression list -> expression val strconst: ?loc:Location.t -> string -> expression diff --git a/parsing/parser.mly b/parsing/parser.mly index 35145b597..429d6bec0 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -594,8 +594,8 @@ structure_item: { mkstr(Pstr_recmodule(List.rev $3)) } | MODULE TYPE ident EQUAL module_type { mkstr(Pstr_modtype(mkrhs $3 3, $5)) } - | OPEN mod_longident - { mkstr(Pstr_open (mkrhs $2 2)) } + | OPEN override_flag mod_longident + { mkstr(Pstr_open ($2, mkrhs $3 3)) } | CLASS class_declarations { mkstr(Pstr_class (List.rev $2)) } | CLASS TYPE class_type_declarations @@ -664,8 +664,8 @@ signature_item: { mksig(Psig_modtype(mkrhs $3 3, Pmodtype_abstract)) } | MODULE TYPE ident EQUAL module_type { mksig(Psig_modtype(mkrhs $3 3, Pmodtype_manifest $5)) } - | OPEN mod_longident - { mksig(Psig_open (mkrhs $2 2)) } + | OPEN override_flag mod_longident + { mksig(Psig_open ($2, mkrhs $3 3)) } | INCLUDE module_type { mksig(Psig_include $2) } | CLASS class_descriptions @@ -970,8 +970,8 @@ expr: { mkexp(Pexp_let($2, List.rev $3, $5)) } | LET MODULE UIDENT module_binding IN seq_expr { mkexp(Pexp_letmodule(mkrhs $3 3, $4, $6)) } - | LET OPEN mod_longident IN seq_expr - { mkexp(Pexp_open(mkrhs $3 3, $5)) } + | LET OPEN override_flag mod_longident IN seq_expr + { mkexp(Pexp_open($3, mkrhs $4 4, $6)) } | FUNCTION opt_bar match_cases { mkexp(Pexp_function("", None, List.rev $3)) } | FUN labeled_simple_pattern fun_def @@ -1088,7 +1088,7 @@ simple_expr: | simple_expr DOT label_longident { mkexp(Pexp_field($1, mkrhs $3 3)) } | mod_longident DOT LPAREN seq_expr RPAREN - { mkexp(Pexp_open(mkrhs $1 1, $4)) } + { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) } | mod_longident DOT LPAREN seq_expr error { unclosed "(" 3 ")" 5 } | simple_expr DOT LPAREN seq_expr RPAREN diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index b802fc85a..ce6ac362d 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -118,7 +118,7 @@ and expression_desc = | Pexp_object of class_structure | Pexp_newtype of string * expression | Pexp_pack of module_expr - | Pexp_open of Longident.t loc * expression + | Pexp_open of override_flag * Longident.t loc * expression (* Value descriptions *) @@ -242,7 +242,7 @@ and signature_item_desc = | Psig_module of string loc * module_type | Psig_recmodule of (string loc * module_type) list | Psig_modtype of string loc * modtype_declaration - | Psig_open of Longident.t loc + | Psig_open of override_flag * Longident.t loc | Psig_include of module_type | Psig_class of class_description list | Psig_class_type of class_type_declaration list @@ -287,7 +287,7 @@ and structure_item_desc = | Pstr_module of string loc * module_expr | Pstr_recmodule of (string loc * module_type * module_expr) list | Pstr_modtype of string loc * module_type - | Pstr_open of Longident.t loc + | Pstr_open of override_flag * Longident.t loc | Pstr_class of class_declaration list | Pstr_class_type of class_type_declaration list | Pstr_include of module_expr diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 812867522..e409849c7 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -612,8 +612,8 @@ class printer ()= object(self:'self) pp f "@[<hov2>lazy@ %a@]" self#simple_expr e | Pexp_poly _ -> assert false - | Pexp_open (lid, e) -> - pp f "@[<2>let open %a in@;%a@]" self#longident_loc lid + | Pexp_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) self#longident_loc lid self#expression e | Pexp_variant (l,Some eo) -> pp f "@[<2>`%s@;%a@]" l self#simple_expr eo @@ -881,8 +881,8 @@ class printer ()= object(self:'self) pp f "@[<hov>module@ %s@ :@ %a@]" s.txt self#module_type mt - | Psig_open li -> - pp f "@[<hov2>open@ %a@]" self#longident_loc li + | Psig_open (ovf, li) -> + pp f "@[<hov2>open%s@ %a@]" (override ovf) self#longident_loc li | Psig_include (mt) -> pp f "@[<hov2>include@ %a@]" self#module_type mt @@ -1017,8 +1017,8 @@ class printer ()= object(self:'self) | _ -> pp f " =@ %a" self#module_expr me )) me - | Pstr_open (li) -> - pp f "@[<2>open@;%a@]" self#longident_loc li; + | Pstr_open (ovf, li) -> + pp f "@[<2>open%s@;%a@]" (override ovf) self#longident_loc li; | Pstr_modtype (s, mt) -> pp f "@[<2>module type %s =@;%a@]" s.txt self#module_type mt | Pstr_class l -> diff --git a/parsing/printast.ml b/parsing/printast.ml index 41e13eaeb..22c68ee4b 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -334,8 +334,9 @@ and expression i ppf x = | Pexp_pack me -> line i ppf "Pexp_pack\n"; module_expr i ppf me - | Pexp_open (m, e) -> - line i ppf "Pexp_open \"%a\"\n" fmt_longident_loc m; + | Pexp_open (ovf, m, e) -> + line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident_loc m; expression i ppf e and value_description i ppf x = @@ -558,7 +559,10 @@ and signature_item i ppf x = | Psig_modtype (s, md) -> line i ppf "Psig_modtype %a\n" fmt_string_loc s; modtype_declaration i ppf md; - | Psig_open li -> line i ppf "Psig_open %a\n" fmt_longident_loc li; + | Psig_open (ovf, li) -> + line i ppf "Psig_open %a %a\n" + fmt_override_flag ovf + fmt_longident_loc li; | Psig_include (mt) -> line i ppf "Psig_include\n"; module_type i ppf mt; @@ -645,7 +649,10 @@ and structure_item i ppf x = | Pstr_modtype (s, mt) -> line i ppf "Pstr_modtype %a\n" fmt_string_loc s; module_type i ppf mt; - | Pstr_open li -> line i ppf "Pstr_open %a\n" fmt_longident_loc li; + | Pstr_open (ovf, li) -> + line i ppf "Pstr_open %a %a\n" + fmt_override_flag ovf + fmt_longident_loc li; | Pstr_class (l) -> line i ppf "Pstr_class\n"; list i class_declaration ppf l; diff --git a/tools/depend.ml b/tools/depend.ml index 3e0c8b386..31edfc97b 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -174,7 +174,7 @@ let rec add_expr bv exp = let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m - | Pexp_open (m, e) -> addmodule bv m; add_expr bv e + | Pexp_open (_ovf, m, e) -> addmodule bv m; add_expr bv e and add_pat_expr_list bv pel = List.iter (fun (p, e) -> let bv = add_pattern bv p in add_expr bv e) pel @@ -225,7 +225,7 @@ and add_sig_item bv item = | Pmodtype_manifest mty -> add_modtype bv mty end; bv - | Psig_open lid -> + | Psig_open (_ovf, lid) -> addmodule bv lid; bv | Psig_include mty -> add_modtype bv mty; bv @@ -277,7 +277,7 @@ and add_struct_item bv item = bv' | Pstr_modtype(id, mty) -> add_modtype bv mty; bv - | Pstr_open l -> + | Pstr_open (_ovf, l) -> addmodule bv l; bv | Pstr_class cdl -> List.iter (add_class_declaration bv) cdl; bv diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 16f9def1f..72c990099 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -281,7 +281,7 @@ and rw_exp iflag sexp = List.iter (rewrite_class_field iflag) cl.pcstr_fields | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp - | Pexp_open (_, e) -> rewrite_exp iflag e + | Pexp_open (_ovf, _, e) -> rewrite_exp iflag e | Pexp_pack (smod) -> rewrite_mod iflag smod and rewrite_ifbody iflag ghost sifbody = diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 1fd2766e8..a0b1a2c1e 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -64,7 +64,7 @@ and untype_structure_item item = untype_module_expr mexpr) list) | Tstr_modtype (_id, name, mtype) -> Pstr_modtype (name, untype_module_type mtype) - | Tstr_open (_path, lid) -> Pstr_open (lid) + | Tstr_open (ovf, _path, lid) -> Pstr_open (ovf, lid) | Tstr_class list -> Pstr_class (List.map (fun (ci, _, _) -> { pci_virt = ci.ci_virt; @@ -182,7 +182,7 @@ and untype_extra (extra, loc) sexp = Pexp_constraint (sexp, option untype_core_type cty1, option untype_core_type cty2) - | Texp_open (_path, lid, _) -> Pexp_open (lid, sexp) + | Texp_open (ovf, _path, lid, _) -> Pexp_open (ovf, lid, sexp) | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto) | Texp_newtype s -> Pexp_newtype (s, sexp) in @@ -317,7 +317,7 @@ and untype_signature_item item = name, untype_module_type mtype) list) | Tsig_modtype (_id, name, mdecl) -> Psig_modtype (name, untype_modtype_declaration mdecl) - | Tsig_open (_path, lid) -> Psig_open (lid) + | Tsig_open (ovf, _path, lid) -> Psig_open (ovf, lid) | Tsig_include (mty, _lid) -> Psig_include (untype_module_type mty) | Tsig_class list -> Psig_class (List.map untype_class_description list) diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index 433bc5c49..9a0174482 100644 --- a/typing/cmt_format.ml +++ b/typing/cmt_format.ml @@ -75,8 +75,8 @@ module ClearEnv = TypedtreeMap.MakeMap (struct let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env } let leave_expression e = let exp_extra = List.map (function - (Texp_open (path, lloc, env), loc) -> - (Texp_open (path, lloc, keep_only_summary env), loc) + (Texp_open (ovf, path, lloc, env), loc) -> + (Texp_open (ovf, path, lloc, keep_only_summary env), loc) | exp_extra -> exp_extra) e.exp_extra in { e with exp_env = keep_only_summary e.exp_env; diff --git a/typing/env.ml b/typing/env.ml index ba5c53625..43efbd40d 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1367,8 +1367,8 @@ let open_pers_signature name env = let ps = find_pers_struct name in open_signature None (Pident(Ident.create_persistent name)) ps.ps_sig env -let open_signature ?(loc = Location.none) ?(toplevel = false) root sg env = - if not toplevel && not loc.Location.loc_ghost && (Warnings.is_active (Warnings.Unused_open "") || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))) +let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = + if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost && (Warnings.is_active (Warnings.Unused_open "") || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))) then begin let used = ref false in !add_delayed_check_forward diff --git a/typing/env.mli b/typing/env.mli index 701e8a6e2..89d4bd1d8 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -106,7 +106,7 @@ val add_signature: signature -> t -> t (* Insertion of all fields of a signature, relative to the given path. Used to implement open. *) -val open_signature: ?loc:Location.t -> ?toplevel:bool -> Path.t -> signature -> t -> t +val open_signature: ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t -> signature -> t -> t val open_pers_signature: string -> t -> t (* Insertion by name *) diff --git a/typing/envaux.ml b/typing/envaux.ml index 4edf3b46a..30146be1e 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -63,7 +63,7 @@ let rec env_from_summary sum subst = with Not_found -> raise (Error (Module_not_found path')) in - Env.open_signature path' (extract_sig env mty) env + Env.open_signature Asttypes.Override path' (extract_sig env mty) env in Hashtbl.add env_cache (sum, subst) env; env diff --git a/typing/printtyped.ml b/typing/printtyped.ml index f1351d076..840a76736 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -234,8 +234,8 @@ and expression_extra i ppf x = line i ppf "Pexp_constraint\n"; option i core_type ppf cto1; option i core_type ppf cto2; - | Texp_open (m, _, _) -> - line i ppf "Pexp_open \"%a\"\n" fmt_path m; + | Texp_open (ovf, m, _, _) -> + line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; | Texp_poly cto -> line i ppf "Pexp_poly\n"; option i core_type ppf cto; @@ -579,7 +579,8 @@ and signature_item i ppf x = | Tsig_modtype (s, _, md) -> line i ppf "Psig_modtype \"%a\"\n" fmt_ident s; modtype_declaration i ppf md; - | Tsig_open (li,_) -> line i ppf "Psig_open %a\n" fmt_path li; + | Tsig_open (ovf, li,_) -> + line i ppf "Psig_open %a %a\n" fmt_override_flag ovf fmt_path li; | Tsig_include (mt, _) -> line i ppf "Psig_include\n"; module_type i ppf mt; @@ -668,7 +669,8 @@ and structure_item i ppf x = | Tstr_modtype (s, _, mt) -> line i ppf "Pstr_modtype \"%a\"\n" fmt_ident s; module_type i ppf mt; - | Tstr_open (li, _) -> line i ppf "Pstr_open %a\n" fmt_path li; + | Tstr_open (ovf, li, _) -> + line i ppf "Pstr_open %a %a\n" fmt_override_flag ovf fmt_path li; | Tstr_class (l) -> line i ppf "Pstr_class\n"; list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l); diff --git a/typing/typecore.ml b/typing/typecore.ml index 08e56b33c..09f81378c 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -131,7 +131,7 @@ let iter_expression f e = | Pexp_variant (_, eo) -> may expr eo | Pexp_record (iel, eo) -> may expr eo; List.iter (fun (_, e) -> expr e) iel - | Pexp_open (_, e) + | Pexp_open (_, _, e) | Pexp_newtype (_, e) | Pexp_poly (e, _) | Pexp_lazy e @@ -2699,11 +2699,12 @@ and type_expect_ ?in_function env sexp ty_expected = exp_loc = loc; exp_extra = []; exp_type = newty (Tpackage (p, nl, tl')); exp_env = env } - | Pexp_open (lid, e) -> - let (path, newenv) = !type_open env sexp.pexp_loc lid in + | Pexp_open (ovf, lid, e) -> + let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in let exp = type_expect newenv e ty_expected in { exp with - exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra; + exp_extra = (Texp_open (ovf, path, lid, newenv), loc) :: + exp.exp_extra; } and type_label_access env loc srecord lid = @@ -2785,7 +2786,7 @@ and type_argument env sarg ty_expected' ty_expected = let rec is_inferred sexp = match sexp.pexp_desc with Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true - | Pexp_open (_, e) -> is_inferred e + | Pexp_open (_, _, e) -> is_inferred e | _ -> false in match expand_head env ty_expected' with diff --git a/typing/typecore.mli b/typing/typecore.mli index 49897558d..30093733a 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -113,7 +113,7 @@ val report_error: Env.t -> formatter -> error -> unit (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) -val type_open: (Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref +val type_open: (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 29aa97d3b..89ac52725 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -58,7 +58,7 @@ and expression = and exp_extra = | Texp_constraint of core_type option * core_type option - | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_open of override_flag * Path.t * Longident.t loc * Env.t | Texp_poly of core_type option | Texp_newtype of string @@ -199,7 +199,7 @@ and structure_item_desc = | Tstr_module of Ident.t * string loc * module_expr | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list | Tstr_modtype of Ident.t * string loc * module_type - | Tstr_open of Path.t * Longident.t loc + | Tstr_open of override_flag * Path.t * Longident.t loc | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of module_expr * Ident.t list @@ -241,7 +241,7 @@ and signature_item_desc = | Tsig_module of Ident.t * string loc * module_type | Tsig_recmodule of (Ident.t * string loc * module_type) list | Tsig_modtype of Ident.t * string loc * modtype_declaration - | Tsig_open of Path.t * Longident.t loc + | Tsig_open of override_flag * Path.t * Longident.t loc | Tsig_include of module_type * Types.signature | Tsig_class of class_description list | Tsig_class_type of class_type_declaration list diff --git a/typing/typedtree.mli b/typing/typedtree.mli index d18058c34..70e79b04c 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -57,7 +57,7 @@ and expression = and exp_extra = | Texp_constraint of core_type option * core_type option - | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_open of override_flag * Path.t * Longident.t loc * Env.t | Texp_poly of core_type option | Texp_newtype of string @@ -198,7 +198,7 @@ and structure_item_desc = | Tstr_module of Ident.t * string loc * module_expr | Tstr_recmodule of (Ident.t * string loc * module_type * module_expr) list | Tstr_modtype of Ident.t * string loc * module_type - | Tstr_open of Path.t * Longident.t loc + | Tstr_open of override_flag * Path.t * Longident.t loc | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of module_expr * Ident.t list @@ -240,7 +240,7 @@ and signature_item_desc = | Tsig_module of Ident.t * string loc * module_type | Tsig_recmodule of (Ident.t * string loc * module_type) list | Tsig_modtype of Ident.t * string loc * modtype_declaration - | Tsig_open of Path.t * Longident.t loc + | Tsig_open of override_flag * Path.t * Longident.t loc | Tsig_include of module_type * Types.signature | Tsig_class of class_description list | Tsig_class_type of class_type_declaration list diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 7815556fc..42808266a 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -229,7 +229,7 @@ module MakeIterator(Iter : IteratorArgument) : sig match cstr with Texp_constraint (cty1, cty2) -> option iter_core_type cty1; option iter_core_type cty2 - | Texp_open (path, _, _) -> () + | Texp_open (_, path, _, _) -> () | Texp_poly cto -> option iter_core_type cto | Texp_newtype s -> ()) exp.exp_extra; diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index f455b2edd..2b6f641b8 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -121,7 +121,7 @@ module MakeMap(Map : MapArgument) = struct Tstr_recmodule list | Tstr_modtype (id, name, mtype) -> Tstr_modtype (id, name, map_module_type mtype) - | Tstr_open (path, lid) -> Tstr_open (path, lid) + | Tstr_open (ovf, path, lid) -> Tstr_open (ovf, path, lid) | Tstr_class list -> let list = List.map (fun (ci, string_list, virtual_flag) -> @@ -401,7 +401,7 @@ module MakeMap(Map : MapArgument) = struct (id, name, map_module_type mtype) ) list) | Tsig_modtype (id, name, mdecl) -> Tsig_modtype (id, name, map_modtype_declaration mdecl) - | Tsig_open (path, lid) -> item.sig_desc + | Tsig_open _ -> item.sig_desc | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid) | Tsig_class list -> Tsig_class (List.map map_class_description list) | Tsig_class_type list -> diff --git a/typing/typemod.ml b/typing/typemod.ml index 81a050585..47c3d80c2 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -64,10 +64,10 @@ let extract_sig_open env loc mty = (* Compute the environment after opening a module *) -let type_open ?toplevel env loc lid = +let type_open ?toplevel ovf env loc lid = let (path, mty) = Typetexp.find_module env loc lid.txt in let sg = extract_sig_open env loc mty in - path, Env.open_signature ~loc ?toplevel path sg env + path, Env.open_signature ~loc ?toplevel ovf path sg env (* Record a module type *) let rm node = @@ -315,8 +315,8 @@ and approx_sig env ssg = let info = approx_modtype_info env sinfo in let (id, newenv) = Env.enter_modtype name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem - | Psig_open lid -> - let (path, mty) = type_open env item.psig_loc lid in + | Psig_open (ovf, lid) -> + let (path, mty) = type_open ovf env item.psig_loc lid in approx_sig mty srem | Psig_include smty -> let mty = approx_modtype env smty in @@ -514,10 +514,11 @@ and transl_signature env sg = mksig (Tsig_modtype (id, name, tinfo)) env loc :: trem, Sig_modtype(id, info) :: rem, final_env - | Psig_open lid -> - let (path, newenv) = type_open env item.psig_loc lid in + | Psig_open (ovf, lid) -> + let (path, newenv) = type_open ovf env item.psig_loc lid in let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_open (path,lid)) env loc :: trem, rem, final_env + mksig (Tsig_open (ovf, path,lid)) env loc :: trem, + rem, final_env | Psig_include smty -> let tmty = transl_modtype env smty in let mty = tmty.mty_type in @@ -1065,9 +1066,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (item :: str_rem, Sig_modtype(id, Modtype_manifest mty.mty_type) :: sig_rem, final_env) - | Pstr_open (lid) -> - let (path, newenv) = type_open ~toplevel env loc lid in - let item = mk (Tstr_open (path, lid)) in + | Pstr_open (ovf, lid) -> + let (path, newenv) = type_open ovf ~toplevel env loc lid in + let item = mk (Tstr_open (ovf, path, lid)) in let (str_rem, sig_rem, final_env) = type_struct newenv srem in (item :: str_rem, sig_rem, final_env) | Pstr_class cl -> |