summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--bytecomp/translmod.ml50
-rw-r--r--ocamldoc/odoc_ast.ml16
-rw-r--r--ocamldoc/odoc_sig.ml4
-rw-r--r--parsing/ast_helper.ml37
-rw-r--r--parsing/ast_helper.mli28
-rw-r--r--parsing/ast_mapper.ml50
-rw-r--r--parsing/ast_mapper.mli4
-rw-r--r--parsing/parser.mly11
-rw-r--r--parsing/parsetree.mli48
-rw-r--r--parsing/pprintast.ml26
-rw-r--r--parsing/printast.ml36
-rw-r--r--tools/depend.ml20
-rw-r--r--tools/tast_iter.ml6
-rw-r--r--tools/untypeast.ml30
-rw-r--r--typing/printtyped.ml36
-rw-r--r--typing/typecore.ml4
-rw-r--r--typing/typedecl.ml39
-rw-r--r--typing/typedecl.mli2
-rw-r--r--typing/typedtree.ml40
-rw-r--r--typing/typedtree.mli40
-rw-r--r--typing/typedtreeIter.ml5
-rw-r--r--typing/typedtreeMap.ml13
-rw-r--r--typing/typemod.ml70
23 files changed, 433 insertions, 182 deletions
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 3b4112b3e..64964e187 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -367,8 +367,10 @@ 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, {Location.loc=loc}, _) ->
- Llet(Strict, id, transl_path ~loc item.str_env path,
+ | Tstr_exn_rebind er ->
+ let id = er.exrb_id in
+ let loc = er.exrb_txt.Location.loc in
+ Llet(Strict, id, transl_path ~loc item.str_env er.exrb_path,
transl_structure (id :: fields) cc rootpath rem)
| Tstr_module mb ->
let id = mb.mb_id in
@@ -393,8 +395,9 @@ and transl_structure fields cc rootpath = function
(id, transl_class ids id meths cl vf ))
cl_list,
transl_structure (List.rev ids @ fields) cc rootpath rem)
- | Tstr_include(modl, sg, _) ->
- let ids = bound_value_identifiers sg in
+ | Tstr_include incl ->
+ let ids = bound_value_identifiers incl.incl_type in
+ let modl = incl.incl_mod in
let mid = Ident.create "include" in
let rec rebind_idents pos newfields = function
[] ->
@@ -445,7 +448,7 @@ let rec defined_idents = function
| Tstr_primitive desc -> defined_idents rem
| Tstr_type decls -> defined_idents rem
| Tstr_exception decl -> decl.cd_id :: defined_idents rem
- | Tstr_exn_rebind(id, _, path, _, _) -> id :: defined_idents rem
+ | Tstr_exn_rebind er -> er.exrb_id :: defined_idents rem
| Tstr_module mb -> mb.mb_id :: defined_idents rem
| Tstr_recmodule decls ->
List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
@@ -454,8 +457,8 @@ let rec defined_idents = function
| 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
- | Tstr_include(modl, sg, _) ->
- bound_value_identifiers sg @ defined_idents rem
+ | Tstr_include incl ->
+ bound_value_identifiers incl.incl_type @ defined_idents rem
| Tstr_attribute _ -> defined_idents rem
(* second level idents (module M = struct ... let id = ... end),
@@ -469,13 +472,13 @@ let rec more_idents = function
| Tstr_primitive _ -> more_idents rem
| Tstr_type decls -> more_idents rem
| Tstr_exception _ -> more_idents rem
- | Tstr_exn_rebind(id, _, path, _, _) -> more_idents rem
+ | Tstr_exn_rebind _ -> more_idents rem
| Tstr_recmodule decls -> more_idents rem
| Tstr_modtype _ -> 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, _, _) -> more_idents rem
+ | Tstr_include _ -> more_idents rem
| Tstr_module {mb_expr={mod_desc = Tmod_structure str}} ->
all_idents str.str_items @ more_idents rem
| Tstr_module _ -> more_idents rem
@@ -491,7 +494,7 @@ and all_idents = function
| Tstr_primitive _ -> all_idents rem
| Tstr_type decls -> all_idents rem
| Tstr_exception decl -> decl.cd_id :: all_idents rem
- | Tstr_exn_rebind(id, _, path, _, _) -> id :: all_idents rem
+ | Tstr_exn_rebind er -> er.exrb_id :: all_idents rem
| Tstr_recmodule decls ->
List.map (fun mb -> mb.mb_id) decls @ all_idents rem
| Tstr_modtype _ -> all_idents rem
@@ -499,7 +502,8 @@ and all_idents = function
| 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
- | Tstr_include(modl, sg, _) -> bound_value_identifiers sg @ all_idents rem
+ | Tstr_include incl ->
+ bound_value_identifiers incl.incl_type @ all_idents rem
| Tstr_module {mb_id;mb_expr={mod_desc = Tmod_structure str}} ->
mb_id :: all_idents str.str_items @ all_idents rem
| Tstr_module mb -> mb.mb_id :: all_idents rem
@@ -551,8 +555,12 @@ 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, {Location.loc=loc}, _) ->
- let lam = subst_lambda subst (transl_path ~loc item.str_env path) in
+ | Tstr_exn_rebind er ->
+ let id = er.exrb_id in
+ let loc = er.exrb_txt.Location.loc in
+ let lam =
+ subst_lambda subst (transl_path ~loc item.str_env er.exrb_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}} ->
@@ -601,8 +609,9 @@ let transl_store_structure glob map prims str =
store_idents ids) in
Lsequence(subst_lambda subst lam,
transl_store rootpath (add_idents false ids subst) rem)
- | Tstr_include(modl, sg, _attrs) ->
- let ids = bound_value_identifiers sg in
+ | Tstr_include incl ->
+ let ids = bound_value_identifiers incl.incl_type in
+ let modl = incl.incl_mod in
let mid = Ident.create "include" in
let rec store_idents pos = function
[] -> transl_store rootpath (add_idents true ids subst) rem
@@ -763,8 +772,10 @@ 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, {Location.loc=loc}, _) ->
- toploop_setvalue id (transl_path ~loc item.str_env path)
+ | Tstr_exn_rebind er ->
+ let id = er.exrb_id in
+ let loc = er.exrb_txt.Location.loc in
+ toploop_setvalue id (transl_path ~loc item.str_env er.exrb_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) *)
@@ -791,8 +802,9 @@ let transl_toplevel_item item =
make_sequence
(fun (ci, _, _) -> toploop_setvalue_id ci.ci_id_class)
cl_list)
- | Tstr_include(modl, sg, _attrs) ->
- let ids = bound_value_identifiers sg in
+ | Tstr_include incl ->
+ let ids = bound_value_identifiers incl.incl_type in
+ let modl = incl.incl_mod in
let mid = Ident.create "include" in
let rec set_idents pos = function
[] ->
diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index 18e474a79..3e0cc83b6 100644
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -77,8 +77,8 @@ module Typedtree_search =
Hashtbl.add table (MT (Name.from_ident mtd.mtd_id)) tt
| Typedtree.Tstr_exception decl ->
Hashtbl.add table (E (Name.from_ident decl.cd_id)) tt
- | Typedtree.Tstr_exn_rebind (ident, _, _, _, _) ->
- Hashtbl.add table (ER (Name.from_ident ident)) tt
+ | Typedtree.Tstr_exn_rebind er ->
+ Hashtbl.add table (ER (Name.from_ident er.exrb_id)) tt
| Typedtree.Tstr_type ident_type_decl_list ->
List.iter
(fun td ->
@@ -136,7 +136,7 @@ module Typedtree_search =
let search_exception_rebind table name =
match Hashtbl.find table (ER name) with
- | (Typedtree.Tstr_exn_rebind (_, _, p, _, _)) -> p
+ | (Typedtree.Tstr_exn_rebind er) -> er.exrb_path
| _ -> assert false
let search_type_declaration table name =
@@ -890,10 +890,10 @@ module Analyser =
let tt_get_included_module_list tt_structure =
let f acc item =
match item.str_desc with
- Typedtree.Tstr_include (mod_expr, _, _) ->
+ Typedtree.Tstr_include incl ->
acc @ [
{ (* A VOIR : chercher dans les modules et les module types, avec quel env ? *)
- im_name = tt_name_from_module_expr mod_expr ;
+ im_name = tt_name_from_module_expr incl.incl_mod ;
im_module = None ;
im_info = None ;
}
@@ -1271,7 +1271,7 @@ module Analyser =
in
(0, new_env, [ Element_exception new_ex ])
- | Parsetree.Pstr_exn_rebind (name, _, _) ->
+ | Parsetree.Pstr_exn_rebind {Parsetree.pexrb_name = name} ->
(* a new exception is defined *)
let complete_name = Name.concat current_module_name name.txt in
(* we get the exception rebind in the typed tree *)
@@ -1434,7 +1434,7 @@ module Analyser =
in
(0, new_env2, [ Element_module_type mt ])
- | Parsetree.Pstr_open (_ovf, longident, _attrs) ->
+ | Parsetree.Pstr_open _ ->
(* A VOIR : enrichir l'environnement quand open ? *)
let ele_comments = match comment_opt with
None -> []
@@ -1544,7 +1544,7 @@ module Analyser =
in
(0, new_env, f ~first: true loc.Location.loc_start.Lexing.pos_cnum class_type_decl_list)
- | Parsetree.Pstr_include (module_expr, _attrs) ->
+ | Parsetree.Pstr_include incl ->
(* we add a dummy included module which will be replaced by a correct
one at the end of the module analysis,
to use the Path.t of the included modules in the typdtree. *)
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 627938453..13b250315 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -866,7 +866,7 @@ module Analyser =
in
(maybe_more, new_env2, [ Element_module_type mt ])
- | Parsetree.Psig_include (module_type, _attrs) ->
+ | Parsetree.Psig_include incl ->
let rec f = function
Parsetree.Pmty_ident longident ->
Name.from_longident longident.txt
@@ -885,7 +885,7 @@ module Analyser =
end
| Parsetree.Pmty_extension _ -> assert false
in
- let name = f module_type.Parsetree.pmty_desc in
+ let name = f incl.Parsetree.pincl_mod.Parsetree.pmty_desc in
let full_name = Odoc_env.full_module_or_module_type_name env name in
let im =
{
diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml
index 536389348..945964093 100644
--- a/parsing/ast_helper.ml
+++ b/parsing/ast_helper.ml
@@ -161,8 +161,8 @@ module Sig = struct
let module_ ?loc a = mk ?loc (Psig_module a)
let rec_module ?loc a = mk ?loc (Psig_recmodule a)
let modtype ?loc a = mk ?loc (Psig_modtype a)
- let open_ ?loc ?(attrs = []) a b = mk ?loc (Psig_open (a, b, attrs))
- let include_ ?loc ?(attrs = []) a = mk ?loc (Psig_include (a, attrs))
+ let open_ ?loc a = mk ?loc (Psig_open a)
+ let include_ ?loc a = mk ?loc (Psig_include a)
let class_ ?loc a = mk ?loc (Psig_class a)
let class_type ?loc a = mk ?loc (Psig_class_type a)
let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs))
@@ -177,15 +177,14 @@ module Str = struct
let primitive ?loc a = mk ?loc (Pstr_primitive a)
let type_ ?loc a = mk ?loc (Pstr_type a)
let exception_ ?loc a = mk ?loc (Pstr_exception a)
- let exn_rebind ?loc ?(attrs = []) a b =
- mk ?loc (Pstr_exn_rebind (a, b, attrs))
+ let exn_rebind ?loc a = mk ?loc (Pstr_exn_rebind a)
let module_ ?loc a = mk ?loc (Pstr_module a)
let rec_module ?loc a = mk ?loc (Pstr_recmodule a)
let modtype ?loc a = mk ?loc (Pstr_modtype a)
- let open_ ?loc ?(attrs = []) a b = mk ?loc (Pstr_open (a, b, attrs))
+ let open_ ?loc a = mk ?loc (Pstr_open a)
let class_ ?loc a = mk ?loc (Pstr_class a)
let class_type ?loc a = mk ?loc (Pstr_class_type a)
- let include_ ?loc ?(attrs = []) a = mk ?loc (Pstr_include (a, attrs))
+ let include_ ?loc a = mk ?loc (Pstr_include a)
let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs))
let attribute ?loc a = mk ?loc (Pstr_attribute a)
end
@@ -300,6 +299,23 @@ module Mb = struct
}
end
+module Opn = struct
+ let mk ?(attrs = []) ?(override = Fresh) lid =
+ {
+ popen_lid = lid;
+ popen_override = override;
+ popen_attributes = attrs;
+ }
+end
+
+module Incl = struct
+ let mk ?(attrs = []) mexpr =
+ {
+ pincl_mod = mexpr;
+ pincl_attributes = attrs;
+ }
+end
+
module Vb = struct
let mk ?(attrs = []) pat expr =
{
@@ -376,6 +392,15 @@ module Cstr = struct
}
end
+module Exrb = struct
+ let mk ?(attrs = []) name lid =
+ {
+ pexrb_name = name;
+ pexrb_lid = lid;
+ pexrb_attributes = attrs;
+ }
+end
+
module Convenience = struct
open Location
diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli
index de9be6685..7fc10d74d 100644
--- a/parsing/ast_helper.mli
+++ b/parsing/ast_helper.mli
@@ -190,8 +190,8 @@ module Sig:
val module_: ?loc:loc -> module_declaration -> signature_item
val rec_module: ?loc:loc -> module_declaration list -> signature_item
val modtype: ?loc:loc -> module_type_declaration -> signature_item
- val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> signature_item
- val include_: ?loc:loc -> ?attrs:attrs -> module_type -> signature_item
+ val open_: ?loc:loc -> open_description -> signature_item
+ val include_: ?loc:loc -> include_description -> signature_item
val class_: ?loc:loc -> class_description list -> signature_item
val class_type: ?loc:loc -> class_type_declaration list -> signature_item
val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item
@@ -208,14 +208,14 @@ module Str:
val primitive: ?loc:loc -> value_description -> structure_item
val type_: ?loc:loc -> type_declaration list -> structure_item
val exception_: ?loc:loc -> constructor_declaration -> structure_item
- val exn_rebind: ?loc:loc -> ?attrs:attrs -> str -> lid -> structure_item
+ val exn_rebind: ?loc:loc -> exception_rebind -> structure_item
val module_: ?loc:loc -> module_binding -> structure_item
val rec_module: ?loc:loc -> module_binding list -> structure_item
val modtype: ?loc:loc -> module_type_declaration -> structure_item
- val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> structure_item
+ val open_: ?loc:loc -> open_description -> structure_item
val class_: ?loc:loc -> class_declaration list -> structure_item
val class_type: ?loc:loc -> class_type_declaration list -> structure_item
- val include_: ?loc:loc -> ?attrs:attrs -> module_expr -> structure_item
+ val include_: ?loc:loc -> include_declaration -> structure_item
val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item
val attribute: ?loc:loc -> attribute -> structure_item
end
@@ -238,6 +238,18 @@ module Mb:
val mk: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> module_binding
end
+(* Opens *)
+module Opn:
+ sig
+ val mk: ?attrs:attrs -> ?override:override_flag -> lid -> open_description
+ end
+
+(* Includes *)
+module Incl:
+ sig
+ val mk: ?attrs:attrs -> 'a -> 'a include_infos
+ end
+
(** Value bindings *)
module Vb:
@@ -323,6 +335,12 @@ module Cstr:
val mk: pattern -> class_field list -> class_structure
end
+(** Exception rebinding *)
+module Exrb:
+ sig
+ val mk: ?attrs:attrs -> str -> lid -> exception_rebind
+end
+
(** {2 Convenience functions} *)
diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml
index 3eade32b1..b5a7303bc 100644
--- a/parsing/ast_mapper.ml
+++ b/parsing/ast_mapper.ml
@@ -39,8 +39,11 @@ type mapper = {
class_type_field: mapper -> class_type_field -> class_type_field;
constructor_declaration: mapper -> constructor_declaration
-> constructor_declaration;
+ exception_rebind: mapper -> exception_rebind -> exception_rebind;
expr: mapper -> expression -> expression;
extension: mapper -> extension -> extension;
+ include_declaration: mapper -> include_declaration -> include_declaration;
+ include_description: mapper -> include_description -> include_description;
label_declaration: mapper -> label_declaration -> label_declaration;
location: mapper -> Location.t -> Location.t;
module_binding: mapper -> module_binding -> module_binding;
@@ -49,6 +52,7 @@ type mapper = {
module_type: mapper -> module_type -> module_type;
module_type_declaration: mapper -> module_type_declaration
-> module_type_declaration;
+ open_description: mapper -> open_description -> open_description;
pat: mapper -> pattern -> pattern;
payload: mapper -> payload -> payload;
signature: mapper -> signature -> signature;
@@ -201,10 +205,8 @@ module MT = struct
| Psig_recmodule l ->
rec_module ~loc (List.map (sub.module_declaration sub) l)
| Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
- | Psig_open (ovf, lid, attrs) ->
- open_ ~loc ~attrs:(sub.attributes sub attrs) ovf (map_loc sub lid)
- | Psig_include (mt, attrs) ->
- include_ ~loc (sub.module_type sub mt) ~attrs:(sub.attributes sub attrs)
+ | Psig_open x -> open_ ~loc (sub.open_description sub x)
+ | Psig_include x -> include_ ~loc (sub.include_description sub x)
| Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l)
| Psig_class_type l ->
class_type ~loc (List.map (sub.class_type_declaration sub) l)
@@ -246,19 +248,15 @@ module M = struct
| Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd)
| Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l)
| Pstr_exception ed -> exception_ ~loc (sub.constructor_declaration sub ed)
- | Pstr_exn_rebind (s, lid, attrs) ->
- exn_rebind ~loc (map_loc sub s) (map_loc sub lid)
- ~attrs:(sub.attributes sub attrs)
+ | Pstr_exn_rebind x -> exn_rebind ~loc (sub.exception_rebind sub x)
| Pstr_module x -> module_ ~loc (sub.module_binding sub x)
| Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l)
| Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x)
- | Pstr_open (ovf, lid, attrs) ->
- open_ ~loc ~attrs:(sub.attributes sub attrs) ovf (map_loc sub lid)
+ | Pstr_open x -> open_ ~loc (sub.open_description sub x)
| Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l)
| Pstr_class_type l ->
class_type ~loc (List.map (sub.class_type_declaration sub) l)
- | Pstr_include (e, attrs) ->
- include_ ~loc (sub.module_expr sub e) ~attrs:(sub.attributes sub attrs)
+ | Pstr_include x -> include_ ~loc (sub.include_declaration sub x)
| Pstr_extension (x, attrs) ->
extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs)
| Pstr_attribute x -> attribute ~loc (sub.attribute sub x)
@@ -495,6 +493,28 @@ let default_mapper =
~loc:(this.location this pmb_loc)
);
+
+ open_description =
+ (fun this {popen_lid; popen_override; popen_attributes} ->
+ Opn.mk (map_loc this popen_lid)
+ ~override:popen_override
+ ~attrs:(this.attributes this popen_attributes)
+ );
+
+
+ include_description =
+ (fun this {pincl_mod; pincl_attributes} ->
+ Incl.mk (this.module_type this pincl_mod)
+ ~attrs:(this.attributes this pincl_attributes)
+ );
+
+ include_declaration =
+ (fun this {pincl_mod; pincl_attributes} ->
+ Incl.mk (this.module_expr this pincl_mod)
+ ~attrs:(this.attributes this pincl_attributes)
+ );
+
+
value_binding =
(fun this {pvb_pat; pvb_expr; pvb_attributes} ->
Vb.mk
@@ -524,6 +544,14 @@ let default_mapper =
~attrs:(this.attributes this pld_attributes)
);
+ exception_rebind =
+ (fun this {pexrb_name; pexrb_lid; pexrb_attributes} ->
+ Exrb.mk
+ (map_loc this pexrb_name)
+ (map_loc this pexrb_lid)
+ ~attrs:(this.attributes this pexrb_attributes)
+ );
+
cases = (fun this l -> List.map (this.case this) l);
case =
(fun this {pc_lhs; pc_guard; pc_rhs} ->
diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli
index 326310e4c..f8d3311e5 100644
--- a/parsing/ast_mapper.mli
+++ b/parsing/ast_mapper.mli
@@ -33,8 +33,11 @@ type mapper = {
class_type_field: mapper -> class_type_field -> class_type_field;
constructor_declaration: mapper -> constructor_declaration
-> constructor_declaration;
+ exception_rebind: mapper -> exception_rebind -> exception_rebind;
expr: mapper -> expression -> expression;
extension: mapper -> extension -> extension;
+ include_declaration: mapper -> include_declaration -> include_declaration;
+ include_description: mapper -> include_description -> include_description;
label_declaration: mapper -> label_declaration -> label_declaration;
location: mapper -> Location.t -> Location.t;
module_binding: mapper -> module_binding -> module_binding;
@@ -43,6 +46,7 @@ type mapper = {
module_type: mapper -> module_type -> module_type;
module_type_declaration: mapper -> module_type_declaration
-> module_type_declaration;
+ open_description: mapper -> open_description -> open_description;
pat: mapper -> pattern -> pattern;
payload: mapper -> payload -> payload;
signature: mapper -> signature -> signature;
diff --git a/parsing/parser.mly b/parsing/parser.mly
index ddfb2b496..eddec83ac 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -636,7 +636,8 @@ structure_item:
| EXCEPTION exception_declaration
{ mkstr(Pstr_exception $2) }
| EXCEPTION UIDENT EQUAL constr_longident post_item_attributes
- { mkstr(Pstr_exn_rebind(mkrhs $2 2, mkloc $4 (rhs_loc 4), $5)) }
+ { mkstr (Pstr_exn_rebind (Exrb.mk (mkrhs $2 2)
+ (mkloc $4 (rhs_loc 4)) ~attrs:$5)) }
| MODULE module_binding
{ mkstr(Pstr_module $2) }
| MODULE REC module_bindings
@@ -648,13 +649,13 @@ structure_item:
{ mkstr(Pstr_modtype (Mtd.mk (mkrhs $3 3)
~typ:$5 ~attrs:$6 ~loc:(symbol_rloc()))) }
| OPEN override_flag mod_longident post_item_attributes
- { mkstr(Pstr_open ($2, mkrhs $3 3, $4)) }
+ { mkstr(Pstr_open (Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4)) }
| CLASS class_declarations
{ mkstr(Pstr_class (List.rev $2)) }
| CLASS TYPE class_type_declarations
{ mkstr(Pstr_class_type (List.rev $3)) }
| INCLUDE module_expr post_item_attributes
- { mkstr(Pstr_include ($2, $3)) }
+ { mkstr(Pstr_include (Incl.mk $2 ~attrs:$3)) }
| item_extension post_item_attributes
{ mkstr(Pstr_extension ($1, $2)) }
| floating_attribute
@@ -742,9 +743,9 @@ signature_item:
~loc:(symbol_rloc())
~attrs:$6)) }
| OPEN override_flag mod_longident post_item_attributes
- { mksig(Psig_open ($2, mkrhs $3 3, $4)) }
+ { mksig(Psig_open (Opn.mk (mkrhs $3 3) ~override:$2 ~attrs:$4)) }
| INCLUDE module_type post_item_attributes %prec below_WITH
- { mksig(Psig_include ($2, $3)) }
+ { mksig(Psig_include (Incl.mk $2 ~attrs:$3)) }
| CLASS class_descriptions
{ mksig(Psig_class (List.rev $2)) }
| CLASS TYPE class_type_declarations
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index dd9b768b9..f712ca4b1 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -384,6 +384,14 @@ and constructor_declaration =
| C: T1 * ... * Tn -> T0 (res = Some T0)
*)
+and exception_rebind =
+ {
+ pexrb_name: string loc;
+ pexrb_lid: Longident.t loc;
+ pexrb_attributes: attributes;
+ }
+(* exception C = M.X *)
+
(** {2 Class language} *)
(* Type expressions for the class language *)
@@ -591,9 +599,9 @@ and signature_item_desc =
| Psig_modtype of module_type_declaration
(* module type S = MT
module type S *)
- | Psig_open of override_flag * Longident.t loc * attributes
+ | Psig_open of open_description
(* open X *)
- | Psig_include of module_type * attributes
+ | Psig_include of include_description
(* include MT *)
| Psig_class of class_description list
(* class c1 : ... and ... and cn : ... *)
@@ -626,6 +634,30 @@ and module_type_declaration =
S (abstract module type declaration, pmtd_type = None)
*)
+and open_description =
+ {
+ popen_lid: Longident.t loc;
+ popen_override: override_flag;
+ popen_attributes: attributes;
+ }
+(* open! X - popen_override: true
+ open X - popen_override: false
+
+ popen_override silences the 'used identifier shadowing' warning
+ *)
+
+and 'a include_infos =
+ {
+ pincl_mod: 'a;
+ pincl_attributes: attributes;
+ }
+
+and include_description = module_type include_infos
+(* include MT *)
+
+and include_declaration = module_expr include_infos
+(* include ME *)
+
and with_constraint =
| Pwith_type of Longident.t loc * type_declaration
(* with type X.t = ...
@@ -685,7 +717,7 @@ and structure_item_desc =
(* type t1 = ... and ... and tn = ... *)
| Pstr_exception of constructor_declaration
(* exception C of T *)
- | Pstr_exn_rebind of string loc * Longident.t loc * attributes
+ | Pstr_exn_rebind of exception_rebind
(* exception C = M.X *)
| Pstr_module of module_binding
(* module X = ME *)
@@ -693,17 +725,13 @@ and structure_item_desc =
(* module rec X1 = ME1 and ... and Xn = MEn *)
| Pstr_modtype of module_type_declaration
(* module type S = MT *)
- | Pstr_open of override_flag * Longident.t loc * attributes
- (* open! X - true
- open X - false
-
- override_flag silences the 'used identifier shadowing' warning
- *)
+ | Pstr_open of open_description
+ (* open X *)
| Pstr_class of class_declaration list
(* class c1 = ... and ... and cn = ... *)
| Pstr_class_type of class_type_declaration list
(* class type ct1 = ... and ... and ctn = ... *)
- | Pstr_include of module_expr * attributes
+ | Pstr_include of include_declaration
(* include ME *)
| Pstr_attribute of attribute
(* [@@id]
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
index ea4f60ac2..edc190d4a 100644
--- a/parsing/pprintast.ml
+++ b/parsing/pprintast.ml
@@ -911,11 +911,13 @@ class printer ()= object(self:'self)
pp f "@[<hov>module@ %s@ :@ %a@]"
pmd.pmd_name.txt
self#module_type pmd.pmd_type
- | Psig_open (ovf, li, _attrs) ->
- pp f "@[<hov2>open%s@ %a@]" (override ovf) self#longident_loc li
- | Psig_include (mt, _attrs) ->
+ | Psig_open od ->
+ pp f "@[<hov2>open%s@ %a@]"
+ (override od.popen_override)
+ self#longident_loc od.popen_lid
+ | Psig_include incl ->
pp f "@[<hov2>include@ %a@]"
- self#module_type mt
+ self#module_type incl.pincl_mod
| Psig_modtype {pmtd_name=s; pmtd_type=md} ->
pp f "@[<hov2>module@ type@ %s%a@]"
s.txt
@@ -1058,8 +1060,10 @@ class printer ()= object(self:'self)
| _ ->
pp f " =@ %a" self#module_expr me
)) x.pmb_expr
- | Pstr_open (ovf, li, _attrs) ->
- pp f "@[<2>open%s@;%a@]" (override ovf) self#longident_loc li;
+ | Pstr_open od ->
+ pp f "@[<2>open%s@;%a@]"
+ (override od.popen_override)
+ self#longident_loc od.popen_lid;
| Pstr_modtype {pmtd_name=s; pmtd_type=md} ->
pp f "@[<hov2>module@ type@ %s%a@]"
s.txt
@@ -1107,10 +1111,12 @@ class printer ()= object(self:'self)
| Pstr_primitive vd ->
pp f "@[<hov2>external@ %a@ :@ %a@]" protect_ident vd.pval_name.txt
self#value_description vd
- | Pstr_include (me, _attrs) ->
- pp f "@[<hov2>include@ %a@]" self#module_expr me
- | Pstr_exn_rebind (s, li, _attrs) -> (* todo: check this *)
- pp f "@[<hov2>exception@ %s@ =@ %a@]" s.txt self#longident_loc li
+ | Pstr_include incl ->
+ pp f "@[<hov2>include@ %a@]" self#module_expr incl.pincl_mod
+ | Pstr_exn_rebind er -> (* todo: check this *)
+ pp f "@[<hov2>exception@ %s@ =@ %a@]"
+ er.pexrb_name.txt
+ self#longident_loc er.pexrb_lid
| Pstr_recmodule decls -> (* 3.07 *)
let aux f = function
| {pmb_name = s; pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} ->
diff --git a/parsing/printast.ml b/parsing/printast.ml
index b66977314..a8a1671b9 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -621,15 +621,15 @@ and signature_item i ppf x =
line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name;
attributes i ppf x.pmtd_attributes;
modtype_declaration i ppf x.pmtd_type
- | Psig_open (ovf, li, attrs) ->
+ | Psig_open od ->
line i ppf "Psig_open %a %a\n"
- fmt_override_flag ovf
- fmt_longident_loc li;
- attributes i ppf attrs
- | Psig_include (mt, attrs) ->
+ fmt_override_flag od.popen_override
+ fmt_longident_loc od.popen_lid;
+ attributes i ppf od.popen_attributes
+ | Psig_include incl ->
line i ppf "Psig_include\n";
- module_type i ppf mt;
- attributes i ppf attrs
+ module_type i ppf incl.pincl_mod;
+ attributes i ppf incl.pincl_attributes
| Psig_class (l) ->
line i ppf "Psig_class\n";
list i class_description ppf l;
@@ -715,11 +715,11 @@ and structure_item i ppf x =
| Pstr_exception cd ->
line i ppf "Pstr_exception\n";
constructor_decl i ppf cd;
- | Pstr_exn_rebind (s, li, attrs) ->
+ | Pstr_exn_rebind er ->
line i ppf "Pstr_exn_rebind\n";
- attributes i ppf attrs;
- line (i+1) ppf "%a\n" fmt_string_loc s;
- line (i+1) ppf "%a\n" fmt_longident_loc li
+ attributes i ppf er.pexrb_attributes;
+ line (i+1) ppf "%a\n" fmt_string_loc er.pexrb_name;
+ line (i+1) ppf "%a\n" fmt_longident_loc er.pexrb_lid
| Pstr_module x ->
line i ppf "Pstr_module\n";
module_binding i ppf x
@@ -730,21 +730,21 @@ and structure_item i ppf x =
line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name;
attributes i ppf x.pmtd_attributes;
modtype_declaration i ppf x.pmtd_type
- | Pstr_open (ovf, li, attrs) ->
+ | Pstr_open od ->
line i ppf "Pstr_open %a %a\n"
- fmt_override_flag ovf
- fmt_longident_loc li;
- attributes i ppf attrs
+ fmt_override_flag od.popen_override
+ fmt_longident_loc od.popen_lid;
+ attributes i ppf od.popen_attributes
| Pstr_class (l) ->
line i ppf "Pstr_class\n";
list i class_declaration ppf l;
| Pstr_class_type (l) ->
line i ppf "Pstr_class_type\n";
list i class_type_declaration ppf l;
- | Pstr_include (me, attrs) ->
+ | Pstr_include incl ->
line i ppf "Pstr_include";
- attributes i ppf attrs;
- module_expr i ppf me
+ attributes i ppf incl.pincl_attributes;
+ module_expr i ppf incl.pincl_mod
| Pstr_extension ((s, arg), attrs) ->
line i ppf "Pstr_extension \"%s\"\n" s.txt;
attributes i ppf attrs;
diff --git a/tools/depend.ml b/tools/depend.ml
index 7ff6704f7..5f300ae88 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -244,10 +244,10 @@ and add_sig_item bv item =
| Some mty -> add_modtype bv mty
end;
bv
- | Psig_open (_ovf, lid, _) ->
- addmodule bv lid; bv
- | Psig_include (mty, _) ->
- add_modtype bv mty; bv
+ | Psig_open od ->
+ addmodule bv od.popen_lid; bv
+ | Psig_include incl ->
+ add_modtype bv incl.pincl_mod; bv
| Psig_class cdl ->
List.iter (add_class_description bv) cdl; bv
| Psig_class_type cdtl ->
@@ -286,8 +286,8 @@ and add_struct_item bv item =
List.iter (add_type_declaration bv) dcls; bv
| Pstr_exception pcd ->
add_constructor_decl bv pcd; bv
- | Pstr_exn_rebind(id, l, _attrs) ->
- add bv l; bv
+ | Pstr_exn_rebind er ->
+ add bv er.pexrb_lid; bv
| Pstr_module x ->
add_module bv x.pmb_expr; StringSet.add x.pmb_name.txt bv
| Pstr_recmodule bindings ->
@@ -304,14 +304,14 @@ and add_struct_item bv item =
| Some mty -> add_modtype bv mty
end;
bv
- | Pstr_open (_ovf, l, _attrs) ->
- addmodule bv l; bv
+ | Pstr_open od ->
+ addmodule bv od.popen_lid; bv
| Pstr_class cdl ->
List.iter (add_class_declaration bv) cdl; bv
| Pstr_class_type cdtl ->
List.iter (add_class_type_declaration bv) cdtl; bv
- | Pstr_include (modl, _attrs) ->
- add_module bv modl; bv
+ | Pstr_include incl ->
+ add_module bv incl.pincl_mod; bv
| Pstr_attribute _ | Pstr_extension _ ->
bv
diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml
index c8af13670..e5bd5e56d 100644
--- a/tools/tast_iter.ml
+++ b/tools/tast_iter.ml
@@ -28,7 +28,7 @@ let structure_item sub x =
| Tstr_primitive v -> sub # value_description v
| Tstr_type list -> List.iter (sub # type_declaration) list
| Tstr_exception decl -> constructor_decl sub decl
- | Tstr_exn_rebind (_id, _, _p, _, _) -> ()
+ | Tstr_exn_rebind _ -> ()
| Tstr_module mb -> sub # module_binding mb
| Tstr_recmodule list -> List.iter (sub # module_binding) list
| Tstr_modtype mtd -> opt (sub # module_type) mtd.mtd_type
@@ -37,7 +37,7 @@ let structure_item sub x =
List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list
| Tstr_class_type list ->
List.iter (fun (_id, _, ct) -> sub # class_type ct.ci_expr) list
- | Tstr_include (mexpr, _, _) -> sub # module_expr mexpr
+ | Tstr_include incl -> sub # module_expr incl.incl_mod
| Tstr_attribute _ -> ()
let value_description sub x =
@@ -175,7 +175,7 @@ let signature_item sub item =
| Tsig_modtype mtd ->
opt (sub # module_type) mtd.mtd_type
| Tsig_open _ -> ()
- | Tsig_include (mty,_,_) -> sub # module_type mty
+ | Tsig_include incl -> sub # module_type incl.incl_mod
| Tsig_class list ->
List.iter (sub # class_description) list
| Tsig_class_type list ->
diff --git a/tools/untypeast.ml b/tools/untypeast.ml
index 1acbb2c31..966368abf 100644
--- a/tools/untypeast.ml
+++ b/tools/untypeast.ml
@@ -55,8 +55,8 @@ and untype_structure_item item =
Pstr_type (List.map untype_type_declaration list)
| Tstr_exception decl ->
Pstr_exception (untype_constructor_declaration decl)
- | Tstr_exn_rebind (_id, name, _p, lid, attrs) ->
- Pstr_exn_rebind (name, lid, attrs)
+ | Tstr_exn_rebind er ->
+ Pstr_exn_rebind (untype_exception_rebind er)
| Tstr_module mb ->
Pstr_module (untype_module_binding mb)
| Tstr_recmodule list ->
@@ -65,7 +65,9 @@ and untype_structure_item item =
Pstr_modtype {pmtd_name=mtd.mtd_name;
pmtd_type=option untype_module_type mtd.mtd_type;
pmtd_loc=mtd.mtd_loc;pmtd_attributes=mtd.mtd_attributes;}
- | Tstr_open (ovf, _path, lid, attrs) -> Pstr_open (ovf, lid, attrs)
+ | Tstr_open od ->
+ Pstr_open {popen_lid = od.open_txt; popen_override = od.open_override;
+ popen_attributes = od.open_attributes}
| Tstr_class list ->
Pstr_class (List.map (fun (ci, _, _) ->
{ pci_virt = ci.ci_virt;
@@ -87,8 +89,9 @@ and untype_structure_item item =
pci_attributes = ct.ci_attributes;
}
) list)
- | Tstr_include (mexpr, _, attrs) ->
- Pstr_include (untype_module_expr mexpr, attrs)
+ | Tstr_include incl ->
+ Pstr_include {pincl_mod = untype_module_expr incl.incl_mod;
+ pincl_attributes = incl.incl_attributes}
| Tstr_attribute x ->
Pstr_attribute x
in
@@ -147,6 +150,13 @@ and untype_constructor_declaration cd =
pcd_attributes = cd.cd_attributes;
}
+and untype_exception_rebind er =
+ {
+ pexrb_name = er.exrb_name;
+ pexrb_lid = er.exrb_txt;
+ pexrb_attributes = er.exrb_attributes;
+ }
+
and untype_pattern pat =
let desc =
match pat with
@@ -345,9 +355,13 @@ and untype_signature_item item =
Psig_modtype {pmtd_name=mtd.mtd_name;
pmtd_type=option untype_module_type mtd.mtd_type;
pmtd_attributes=mtd.mtd_attributes; pmtd_loc=mtd.mtd_loc}
- | Tsig_open (ovf, _path, lid, attrs) -> Psig_open (ovf, lid, attrs)
- | Tsig_include (mty, _, attrs) ->
- Psig_include (untype_module_type mty, attrs)
+ | Tsig_open od ->
+ Psig_open {popen_lid = od.open_txt;
+ popen_override = od.open_override;
+ popen_attributes = od.open_attributes}
+ | Tsig_include incl ->
+ Psig_include {pincl_mod = untype_module_type incl.incl_mod;
+ pincl_attributes = incl.incl_attributes}
| Tsig_class list ->
Psig_class (List.map untype_class_description list)
| Tsig_class_type list ->
diff --git a/typing/printtyped.ml b/typing/printtyped.ml
index 209121e83..47b637dbe 100644
--- a/typing/printtyped.ml
+++ b/typing/printtyped.ml
@@ -599,13 +599,15 @@ and signature_item i ppf x =
line i ppf "Psig_modtype \"%a\"\n" fmt_ident x.mtd_id;
attributes i ppf x.mtd_attributes;
modtype_declaration i ppf x.mtd_type
- | Tsig_open (ovf, li,_,attrs) ->
- line i ppf "Psig_open %a %a\n" fmt_override_flag ovf fmt_path li;
- attributes i ppf attrs
- | Tsig_include (mt, _, attrs) ->
+ | Tsig_open od ->
+ line i ppf "Psig_open %a %a\n"
+ fmt_override_flag od.open_override
+ fmt_path od.open_path;
+ attributes i ppf od.open_attributes
+ | Tsig_include incl ->
line i ppf "Psig_include\n";
- attributes i ppf attrs;
- module_type i ppf mt
+ attributes i ppf incl.incl_attributes;
+ module_type i ppf incl.incl_mod
| Tsig_class (l) ->
line i ppf "Psig_class\n";
list i class_description ppf l;
@@ -692,9 +694,11 @@ and structure_item i ppf x =
| Tstr_exception cd ->
line i ppf "Pstr_exception\n";
constructor_decl i ppf cd;
- | Tstr_exn_rebind (s, _, li, _, attrs) ->
- line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li;
- attributes i ppf attrs
+ | Tstr_exn_rebind er ->
+ line i ppf "Pstr_exn_rebind \"%a\" %a\n"
+ fmt_ident er.exrb_id
+ fmt_path er.exrb_path;
+ attributes i ppf er.exrb_attributes
| Tstr_module x ->
line i ppf "Pstr_module\n";
module_binding i ppf x
@@ -705,19 +709,21 @@ and structure_item i ppf x =
line i ppf "Pstr_modtype \"%a\"\n" fmt_ident x.mtd_id;
attributes i ppf x.mtd_attributes;
modtype_declaration i ppf x.mtd_type
- | Tstr_open (ovf, li, _, attrs) ->
- line i ppf "Pstr_open %a %a\n" fmt_override_flag ovf fmt_path li;
- attributes i ppf attrs
+ | Tstr_open od ->
+ line i ppf "Pstr_open %a %a\n"
+ fmt_override_flag od.open_override
+ fmt_path od.open_path;
+ attributes i ppf od.open_attributes
| Tstr_class (l) ->
line i ppf "Pstr_class\n";
list i class_declaration ppf (List.map (fun (cl, _,_) -> cl) l);
| Tstr_class_type (l) ->
line i ppf "Pstr_class_type\n";
list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
- | Tstr_include (me, _, attrs) ->
+ | Tstr_include incl ->
line i ppf "Pstr_include";
- attributes i ppf attrs;
- module_expr i ppf me;
+ attributes i ppf incl.incl_attributes;
+ module_expr i ppf incl.incl_mod;
| Tstr_attribute (s, arg) ->
line i ppf "Pstr_attribute \"%s\"\n" s.txt;
Printast.payload i ppf arg
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 8a657b3cb..92d510f74 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -190,7 +190,7 @@ let iter_expression f e =
| Pstr_attribute _
| Pstr_extension _
| Pstr_exn_rebind _ -> ()
- | Pstr_include (me, _)
+ | Pstr_include {pincl_mod = me}
| Pstr_module {pmb_expr = me} -> module_expr me
| Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l
| Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
@@ -1437,7 +1437,7 @@ and is_nonexpansive_mod mexp =
| Tstr_value (_, pat_exp_list) ->
List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
| Tstr_module {mb_expr=m;_}
- | Tstr_include (m, _, _) -> is_nonexpansive_mod m
+ | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
| Tstr_recmodule id_mod_list ->
List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
id_mod_list
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 3f02d310c..d09130f92 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -1049,19 +1049,38 @@ let transl_exception env excdecl =
cd, exn_decl, newenv
(* Translate an exception rebinding *)
-let transl_exn_rebind env loc lid =
+let transl_exn_rebind env loc ser =
+ let name = ser.pexrb_name in
+ let lid = ser.pexrb_lid in
let cdescr =
try
- Env.lookup_constructor lid env
+ Env.lookup_constructor lid.txt env
with Not_found ->
- raise(Error(loc, Unbound_exception lid)) in
- Env.mark_constructor Env.Positive env (Longident.last lid) cdescr;
- match cdescr.cstr_tag with
- Cstr_exception (path, _) ->
- (path, {exn_args = cdescr.cstr_args;
- exn_attributes = [];
- Types.exn_loc = loc})
- | _ -> raise(Error(loc, Not_an_exception lid))
+ raise(Error(loc, Unbound_exception lid.txt)) in
+ Env.mark_constructor Env.Positive env (Longident.last lid.txt) cdescr;
+ let path =
+ match cdescr.cstr_tag with
+ Cstr_exception (path, _) -> path
+ | _ -> raise(Error(loc, Not_an_exception lid.txt))
+ in
+ let exn_decl =
+ {
+ exn_args = cdescr.cstr_args;
+ exn_attributes = [];
+ Types.exn_loc = loc
+ }
+ in
+ let (id, newenv) = Env.enter_exception name.txt exn_decl env in
+ let er =
+ { exrb_id = id;
+ exrb_name = name;
+ exrb_path = path;
+ exrb_txt = lid;
+ exrb_type = exn_decl;
+ exrb_attributes = ser.pexrb_attributes;
+ }
+ in
+ er, newenv
(* Translate a value declaration *)
let transl_value_decl env loc valdecl =
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 89eb07517..6f6bc52c2 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -24,7 +24,7 @@ val transl_exception:
Parsetree.constructor_declaration -> Typedtree.constructor_declaration * exception_declaration * Env.t
val transl_exn_rebind:
- Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
+ Env.t -> Location.t -> Parsetree.exception_rebind -> Typedtree.exception_rebind * Env.t
val transl_value_decl:
Env.t -> Location.t ->
diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index 166086ae8..bc71b7a1f 100644
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -211,15 +211,14 @@ and structure_item_desc =
| Tstr_primitive of value_description
| Tstr_type of type_declaration list
| Tstr_exception of constructor_declaration
- | Tstr_exn_rebind of
- Ident.t * string loc * Path.t * Longident.t loc * attribute list
+ | Tstr_exn_rebind of exception_rebind
| Tstr_module of module_binding
| Tstr_recmodule of module_binding list
| Tstr_modtype of module_type_declaration
- | Tstr_open of override_flag * Path.t * Longident.t loc * attribute list
+ | Tstr_open of open_description
| 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 * Types.signature * attribute list
+ | Tstr_include of include_declaration
| Tstr_attribute of attribute
and module_binding =
@@ -280,8 +279,8 @@ and signature_item_desc =
| Tsig_module of module_declaration
| Tsig_recmodule of module_declaration list
| Tsig_modtype of module_type_declaration
- | Tsig_open of override_flag * Path.t * Longident.t loc * attribute list
- | Tsig_include of module_type * Types.signature * attribute list
+ | Tsig_open of open_description
+ | Tsig_include of include_description
| Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list
| Tsig_attribute of attribute
@@ -304,6 +303,25 @@ and module_type_declaration =
mtd_loc: Location.t;
}
+and open_description =
+ {
+ open_path: Path.t;
+ open_txt: Longident.t loc;
+ open_override: override_flag;
+ open_attributes: attribute list;
+ }
+
+and 'a include_infos =
+ {
+ incl_mod: 'a;
+ incl_type: Types.signature;
+ incl_attributes: attribute list;
+ }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
and with_constraint =
Twith_type of type_declaration
| Twith_module of Path.t * Longident.t loc
@@ -391,6 +409,16 @@ and constructor_declaration =
cd_attributes: attribute list;
}
+and exception_rebind =
+ {
+ exrb_id: Ident.t;
+ exrb_name: string loc;
+ exrb_path: Path.t;
+ exrb_txt: Longident.t loc;
+ exrb_type: Types.exception_declaration;
+ exrb_attributes: attribute list;
+ }
+
and class_type =
{
cltyp_desc: class_type_desc;
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 1e6d0a6c0..1815dfc6e 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -210,15 +210,14 @@ and structure_item_desc =
| Tstr_primitive of value_description
| Tstr_type of type_declaration list
| Tstr_exception of constructor_declaration
- | Tstr_exn_rebind of Ident.t * string loc * Path.t * Longident.t loc
- * attributes
+ | Tstr_exn_rebind of exception_rebind
| Tstr_module of module_binding
| Tstr_recmodule of module_binding list
| Tstr_modtype of module_type_declaration
- | Tstr_open of override_flag * Path.t * Longident.t loc * attributes
+ | Tstr_open of open_description
| 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 * Types.signature * attributes
+ | Tstr_include of include_declaration
| Tstr_attribute of attribute
and module_binding =
@@ -279,8 +278,8 @@ and signature_item_desc =
| Tsig_module of module_declaration
| Tsig_recmodule of module_declaration list
| Tsig_modtype of module_type_declaration
- | Tsig_open of override_flag * Path.t * Longident.t loc * attributes
- | Tsig_include of module_type * Types.signature * attributes
+ | Tsig_open of open_description
+ | Tsig_include of include_description
| Tsig_class of class_description list
| Tsig_class_type of class_type_declaration list
| Tsig_attribute of attribute
@@ -303,6 +302,25 @@ and module_type_declaration =
mtd_loc: Location.t;
}
+and open_description =
+ {
+ open_path: Path.t;
+ open_txt: Longident.t loc;
+ open_override: override_flag;
+ open_attributes: attribute list;
+ }
+
+and 'a include_infos =
+ {
+ incl_mod: 'a;
+ incl_type: Types.signature;
+ incl_attributes: attribute list;
+ }
+
+and include_description = module_type include_infos
+
+and include_declaration = module_expr include_infos
+
and with_constraint =
Twith_type of type_declaration
| Twith_module of Path.t * Longident.t loc
@@ -391,6 +409,16 @@ and constructor_declaration =
cd_attributes: attributes;
}
+and exception_rebind =
+ {
+ exrb_id: Ident.t;
+ exrb_name: string loc;
+ exrb_path: Path.t;
+ exrb_txt: Longident.t loc;
+ exrb_type: Types.exception_declaration;
+ exrb_attributes: attribute list;
+ }
+
and class_type =
{
cltyp_desc: class_type_desc;
diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml
index c0d61297d..4681473d9 100644
--- a/typing/typedtreeIter.ml
+++ b/typing/typedtreeIter.ml
@@ -148,8 +148,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_class_type ct.ci_expr;
Iter.leave_class_type_declaration ct;
) list
- | Tstr_include (mexpr, _, _attrs) ->
- iter_module_expr mexpr
+ | Tstr_include incl -> iter_module_expr incl.incl_mod
| Tstr_attribute _ ->
()
end;
@@ -347,7 +346,7 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Tsig_modtype mtd ->
iter_module_type_declaration mtd
| Tsig_open _ -> ()
- | Tsig_include (mty, _, _attrs) -> iter_module_type mty
+ | Tsig_include incl -> iter_module_type incl.incl_mod
| Tsig_class list ->
List.iter iter_class_description list
| Tsig_class_type list ->
diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml
index 93881a0f1..4f83f5a63 100644
--- a/typing/typedtreeMap.ml
+++ b/typing/typedtreeMap.ml
@@ -114,8 +114,8 @@ module MakeMap(Map : MapArgument) = struct
Tstr_type (List.map map_type_declaration list)
| Tstr_exception cd ->
Tstr_exception (map_constructor_declaration cd)
- | Tstr_exn_rebind (id, name, path, lid, attrs) ->
- Tstr_exn_rebind (id, name, path, lid, attrs)
+ | Tstr_exn_rebind er ->
+ Tstr_exn_rebind er
| Tstr_module x ->
Tstr_module (map_module_binding x)
| Tstr_recmodule list ->
@@ -123,7 +123,7 @@ module MakeMap(Map : MapArgument) = struct
Tstr_recmodule list
| Tstr_modtype mtd ->
Tstr_modtype (map_module_type_declaration mtd)
- | Tstr_open (ovf, path, lid, attrs) -> Tstr_open (ovf, path, lid, attrs)
+ | Tstr_open od -> Tstr_open od
| Tstr_class list ->
let list =
List.map (fun (ci, string_list, virtual_flag) ->
@@ -141,8 +141,8 @@ module MakeMap(Map : MapArgument) = struct
(id, name, Map.leave_class_infos { ct with ci_expr = ci_expr})
) list in
Tstr_class_type list
- | Tstr_include (mexpr, sg, attrs) ->
- Tstr_include (map_module_expr mexpr, sg, attrs)
+ | Tstr_include incl ->
+ Tstr_include {incl with incl_mod = map_module_expr incl.incl_mod}
| Tstr_attribute x -> Tstr_attribute x
in
Map.leave_structure_item { item with str_desc = str_desc}
@@ -395,7 +395,8 @@ module MakeMap(Map : MapArgument) = struct
| Tsig_modtype mtd ->
Tsig_modtype (map_module_type_declaration mtd)
| Tsig_open _ -> item.sig_desc
- | Tsig_include (mty, sg, attrs) -> Tsig_include (map_module_type mty, sg, attrs)
+ | Tsig_include incl ->
+ Tsig_include {incl with incl_mod = map_module_type incl.incl_mod}
| Tsig_class list -> Tsig_class (List.map map_class_description list)
| Tsig_class_type list ->
Tsig_class_type (List.map map_class_type_declaration list)
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 72dbe7074..a647e73e8 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -361,10 +361,13 @@ and approx_sig env ssg =
let info = approx_modtype_info env d in
let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in
Sig_modtype(id, info) :: approx_sig newenv srem
- | Psig_open (ovf, lid, _attrs) ->
- let (path, mty) = type_open ovf env item.psig_loc lid in
+ | Psig_open sod ->
+ let (path, mty) =
+ type_open sod.popen_override env item.psig_loc sod.popen_lid
+ in
approx_sig mty srem
- | Psig_include (smty, _attrs) ->
+ | Psig_include sincl ->
+ let smty = sincl.pincl_mod in
let mty = approx_modtype env smty in
let sg = Subst.signature Subst.identity
(extract_sig env smty.pmty_loc mty) in
@@ -598,12 +601,23 @@ and transl_signature env sg =
mksig (Tsig_modtype mtd) env loc :: trem,
sg :: rem,
final_env
- | Psig_open (ovf, lid, attrs) ->
- let (path, newenv) = type_open ovf env item.psig_loc lid in
+ | Psig_open sod ->
+ let (path, newenv) =
+ type_open sod.popen_override env item.psig_loc sod.popen_lid
+ in
+ let od =
+ {
+ open_override = sod.popen_override;
+ open_path = path;
+ open_txt = sod.popen_lid;
+ open_attributes = sod.popen_attributes;
+ }
+ in
let (trem, rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_open (ovf, path,lid,attrs)) env loc :: trem,
+ mksig (Tsig_open od) env loc :: trem,
rem, final_env
- | Psig_include (smty, attrs) ->
+ | Psig_include sincl ->
+ let smty = sincl.pincl_mod in
let tmty = transl_modtype env smty in
let mty = tmty.mty_type in
let sg = Subst.signature Subst.identity
@@ -613,8 +627,13 @@ and transl_signature env sg =
item.psig_loc)
sg;
let newenv = Env.add_signature sg env in
+ let incl =
+ { incl_mod = tmty;
+ incl_type = sg;
+ incl_attributes = sincl.pincl_attributes }
+ in
let (trem, rem, final_env) = transl_sig newenv srem in
- mksig (Tsig_include (tmty, sg, attrs)) env loc :: trem,
+ mksig (Tsig_include incl) env loc :: trem,
remove_duplicates (get_values rem) (get_exceptions rem) sg @ rem,
final_env
| Psig_class cl ->
@@ -1155,11 +1174,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
| Pstr_exception sarg ->
let (arg, decl, newenv) = Typedecl.transl_exception env sarg in
Tstr_exception arg, [Sig_exception(arg.cd_id, decl)], newenv
- | Pstr_exn_rebind(name, longid, attrs) ->
- let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in
- let (id, newenv) = Env.enter_exception name.txt arg env in
- Tstr_exn_rebind(id, name, path, longid, attrs),
- [Sig_exception(id, arg)],
+ | Pstr_exn_rebind ser ->
+ let (er, newenv) = Typedecl.transl_exn_rebind env loc ser in
+ Tstr_exn_rebind er,
+ [Sig_exception(er.exrb_id, er.exrb_type)],
newenv
| Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
pmb_loc;
@@ -1242,9 +1260,19 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
transl_modtype_decl modtype_names env loc pmtd
in
Tstr_modtype mtd, [sg], newenv
- | Pstr_open (ovf, lid, attrs) ->
- let (path, newenv) = type_open ovf ~toplevel env loc lid in
- Tstr_open (ovf, path, lid, attrs), [], newenv
+ | Pstr_open sod ->
+ let (path, newenv) =
+ type_open sod.popen_override ~toplevel env loc sod.popen_lid
+ in
+ let od =
+ {
+ open_override = sod.popen_override;
+ open_path = path;
+ open_txt = sod.popen_lid;
+ open_attributes = sod.popen_attributes;
+ }
+ in
+ Tstr_open od, [], newenv
| Pstr_class cl ->
List.iter
(fun {pci_name = name} -> check "type" loc type_names name.txt)
@@ -1293,7 +1321,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
Sig_type(i'', d'', rs)])
classes []),
new_env
- | Pstr_include (smodl, attrs) ->
+ | Pstr_include sincl ->
+ let smodl = sincl.pincl_mod in
let modl = type_module true funct_body None env smodl in
(* Rename all identifiers bound by this signature to avoid clashes *)
let sg = Subst.signature Subst.identity
@@ -1322,7 +1351,12 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
List.iter
(check_sig_item type_names module_names modtype_names loc) sg;
let new_env = Env.add_signature sg env in
- Tstr_include (modl, sg, attrs), sg, new_env
+ let incl =
+ { incl_mod = modl;
+ incl_type = sg;
+ incl_attributes = sincl.pincl_attributes }
+ in
+ Tstr_include incl, sg, new_env
| Pstr_extension ((s, _), _) ->
raise (Error (s.loc, env, Extension s.txt))
| Pstr_attribute x ->
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-27 17:05:50 +0000