Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Turn more sig/str items into records. Patch from Leo White. 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14597 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2014-04-15 11:26:00 +00:00
parent c239f181be
commit 6fe5dd7cf4
23 changed files with 433 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
bytecomp/translmod.ml
View File

@ -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
[] ->

16
ocamldoc/odoc_ast.ml
View File

@ -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. *)

4
ocamldoc/odoc_sig.ml
View File

@ -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 =
{

37
parsing/ast_helper.ml
View File

@ -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

28
parsing/ast_helper.mli
View File

@ -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} *)

50
parsing/ast_mapper.ml
View File

@ -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} ->

4
parsing/ast_mapper.mli
View File

@ -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;

11
parsing/parser.mly
View File

@ -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

48
parsing/parsetree.mli
View File

@ -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]

26
parsing/pprintast.ml
View File

@ -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)}} ->

36
parsing/printast.ml
View File

@ -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;

20
tools/depend.ml
View File

@ -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

6
tools/tast_iter.ml
View File

@ -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 ->

30
tools/untypeast.ml
View File

@ -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 ->

36
typing/printtyped.ml
View File

@ -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

4
typing/typecore.ml
View File

@ -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

39
typing/typedecl.ml
View File

@ -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 =

2
typing/typedecl.mli
View File

@ -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 ->

40
typing/typedtree.ml
View File

@ -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;

40
typing/typedtree.mli
View File

@ -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;

5
typing/typedtreeIter.ml
View File

@ -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 ->

13
typing/typedtreeMap.ml
View File

@ -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)

70
typing/typemod.ml
View File

@ -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 ->