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

Add a unique id to every signature item

master
Thomas Refis 2019-08-20 09:53:05 +01:00
parent 9fb4b05f4b
commit d52dd5c33e
17 changed files with 380 additions and 202 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
lambda/translcore.ml
View File

@ -126,7 +126,8 @@ let rec push_defaults loc bindings cases partial =
let param = Typecore.name_cases "param" cases in
let desc =
{val_type = pat.pat_type; val_kind = Val_reg;
val_attributes = []; Types.val_loc = Location.none; }
val_attributes = []; Types.val_loc = Location.none;
val_uid = Types.Uid.internal_not_actually_unique; }
in
let env = Env.add_value param desc exp.exp_env in
let name = Ident.name param in

2
ocamldoc/odoc_sig.ml
View File

@ -413,7 +413,7 @@ module Analyser =
{ Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
get_field env comments @@
{Types.ld_id; ld_mutable; ld_type=ld_type.Typedtree.ctyp_type;
ld_loc; ld_attributes } in
ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in
let open Typedtree in
function
| Cstr_tuple l ->

11
toplevel/topdirs.ml
View File

@ -590,8 +590,9 @@ let () =
ext_args = Cstr_tuple desc.cstr_args;
ext_ret_type = ret_type;
ext_private = Asttypes.Public;
Types.ext_loc = desc.cstr_loc;
Types.ext_attributes = desc.cstr_attributes; }
ext_loc = desc.cstr_loc;
ext_attributes = desc.cstr_attributes;
ext_uid = desc.cstr_uid; }
in
[Sig_typext (id, ext, Text_first, Exported)]
else
@ -620,8 +621,10 @@ let () =
ext_args = Cstr_tuple desc.cstr_args;
ext_ret_type = ret_type;
ext_private = Asttypes.Public;
Types.ext_loc = desc.cstr_loc;
Types.ext_attributes = desc.cstr_attributes; }
ext_loc = desc.cstr_loc;
ext_attributes = desc.cstr_attributes;
ext_uid = desc.cstr_uid;
}
in
[Sig_typext (id, ext, Text_exception, Exported)]
)

5
typing/ctype.ml
View File

@ -1262,6 +1262,7 @@ let new_declaration expansion_scope manifest =
type_attributes = [];
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
let existential_name cstr ty = match repr ty with
@ -4678,6 +4679,7 @@ let nondep_type_decl env mid is_covariant decl =
type_attributes = decl.type_attributes;
type_immediate = decl.type_immediate;
type_unboxed = decl.type_unboxed;
type_uid = decl.type_uid;
}
with Nondep_cannot_erase _ as exn ->
clear_hash ();
@ -4714,6 +4716,7 @@ let nondep_extension_constructor env ids ext =
ext_private = ext.ext_private;
ext_attributes = ext.ext_attributes;
ext_loc = ext.ext_loc;
ext_uid = ext.ext_uid;
}
with Nondep_cannot_erase _ as exn ->
clear_hash ();
@ -4757,6 +4760,7 @@ let nondep_class_declaration env ids decl =
end;
cty_loc = decl.cty_loc;
cty_attributes = decl.cty_attributes;
cty_uid = decl.cty_uid;
}
in
clear_hash ();
@ -4771,6 +4775,7 @@ let nondep_cltype_declaration env ids decl =
clty_path = decl.clty_path;
clty_loc = decl.clty_loc;
clty_attributes = decl.clty_attributes;
clty_uid = decl.clty_uid;
}
in
clear_hash ();

21
typing/datarepr.ml
View File

@ -65,7 +65,7 @@ let constructor_existentials cd_args cd_res =
in
(tyl, existentials)
let constructor_args priv cd_args cd_res path rep =
let constructor_args ~current_unit priv cd_args cd_res path rep =
let tyl, existentials = constructor_existentials cd_args cd_res in
match cd_args with
| Cstr_tuple l -> existentials, l, None
@ -93,13 +93,14 @@ let constructor_args priv cd_args cd_res path rep =
type_attributes = [];
type_immediate = Unknown;
type_unboxed;
type_uid = Uid.mk ~current_unit;
}
in
existentials,
[ newgenconstr path type_params ],
Some tdecl
let constructor_descrs ty_path decl cstrs =
let constructor_descrs ~current_unit ty_path decl cstrs =
let ty_res = newgenconstr ty_path decl.type_params in
let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in
List.iter
@ -109,7 +110,7 @@ let constructor_descrs ty_path decl cstrs =
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
| {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem ->
| {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} :: rem ->
let ty_res =
match cd_res with
| Some ty_res' -> ty_res'
@ -131,7 +132,7 @@ let constructor_descrs ty_path decl cstrs =
then Record_unboxed true
else Record_inlined idx_nonconst
in
constructor_args decl.type_private cd_args cd_res
constructor_args ~current_unit decl.type_private cd_args cd_res
(Path.Pdot (ty_path, cstr_name)) representation
in
let cstr =
@ -149,18 +150,19 @@ let constructor_descrs ty_path decl cstrs =
cstr_loc = cd_loc;
cstr_attributes = cd_attributes;
cstr_inlined;
cstr_uid = cd_uid;
} in
(cd_id, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
let extension_descr path_ext ext =
let extension_descr ~current_unit path_ext ext =
let ty_res =
match ext.ext_ret_type with
Some type_ret -> type_ret
| None -> newgenconstr ext.ext_type_path ext.ext_type_params
in
let existentials, cstr_args, cstr_inlined =
constructor_args ext.ext_private ext.ext_args ext.ext_ret_type
constructor_args ~current_unit ext.ext_private ext.ext_args ext.ext_ret_type
path_ext (Record_extension path_ext)
in
{ cstr_name = Path.last path_ext;
@ -177,6 +179,7 @@ let extension_descr path_ext ext =
cstr_loc = ext.ext_loc;
cstr_attributes = ext.ext_attributes;
cstr_inlined;
cstr_uid = ext.ext_uid;
}
let none = {desc = Ttuple []; level = -1; scope = Btype.generic_level; id = -1}
@ -187,6 +190,7 @@ let dummy_label =
lbl_private = Public;
lbl_loc = Location.none;
lbl_attributes = [];
lbl_uid = Uid.internal_not_actually_unique;
}
let label_descrs ty_res lbls repres priv =
@ -205,6 +209,7 @@ let label_descrs ty_res lbls repres priv =
lbl_private = priv;
lbl_loc = l.ld_loc;
lbl_attributes = l.ld_attributes;
lbl_uid = l.ld_uid;
} in
all_labels.(num) <- lbl;
(l.ld_id, lbl) :: describe_labels (num+1) rest in
@ -227,9 +232,9 @@ let rec find_constr tag num_const num_nonconst = function
let find_constr_by_tag tag cstrlist =
find_constr tag 0 0 cstrlist
let constructors_of_type ty_path decl =
let constructors_of_type ~current_unit ty_path decl =
match decl.type_kind with
| Type_variant cstrs -> constructor_descrs ty_path decl cstrs
| Type_variant cstrs -> constructor_descrs ~current_unit ty_path decl cstrs
| Type_record _ | Type_abstract | Type_open -> []
let labels_of_type ty_path decl =

5
typing/datarepr.mli
View File

@ -19,13 +19,14 @@
open Types
val extension_descr:
Path.t -> extension_constructor -> constructor_description
current_unit:string -> Path.t -> extension_constructor ->
constructor_description
val labels_of_type:
Path.t -> type_declaration ->
(Ident.t * label_description) list
val constructors_of_type:
Path.t -> type_declaration ->
current_unit:string -> Path.t -> type_declaration ->
(Ident.t * constructor_description) list

22
typing/env.ml
View File

@ -648,7 +648,8 @@ let strengthen =
aliasable:bool -> t -> module_type -> Path.t -> module_type)
let md md_type =
{md_type; md_attributes=[]; md_loc=Location.none}
{md_type; md_attributes=[]; md_loc=Location.none
;md_uid = Uid.internal_not_actually_unique}
(* Print addresses *)
@ -1499,7 +1500,10 @@ let rec components_of_module_maker
Datarepr.set_row_name final_decl
(Subst.type_path prefixing_sub (Path.Pident id));
let constructors =
List.map snd (Datarepr.constructors_of_type path final_decl) in
List.map snd
(Datarepr.constructors_of_type ~current_unit:(get_unit_name ())
path final_decl)
in
let labels =
List.map snd (Datarepr.labels_of_type path final_decl) in
let tda =
@ -1521,7 +1525,10 @@ let rec components_of_module_maker
env := store_type_infos id fresh_decl !env
| Sig_typext(id, ext, _, _) ->
let ext' = Subst.extension_constructor sub ext in
let descr = Datarepr.extension_descr path ext' in
let descr =
Datarepr.extension_descr ~current_unit:(get_unit_name ()) path
ext'
in
let addr = next_address () in
let cda = { cda_description = descr; cda_address = Some addr } in
c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs
@ -1643,7 +1650,10 @@ and store_type ~check id info env =
check_usage loc id (fun s -> Warnings.Unused_type_declaration s)
type_declarations;
let path = Pident id in
let constructors = Datarepr.constructors_of_type path info in
let constructors =
Datarepr.constructors_of_type path info
~current_unit:(get_unit_name ())
in
let labels = Datarepr.labels_of_type path info in
let descrs = (List.map snd constructors, List.map snd labels) in
let tda = { tda_declaration = info; tda_descriptions = descrs } in
@ -1697,7 +1707,9 @@ and store_type_infos id info env =
and store_extension ~check id addr ext env =
let loc = ext.ext_loc in
let cstr = Datarepr.extension_descr (Pident id) ext in
let cstr =
Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext
in
let cda = { cda_description = cstr; cda_address = Some addr } in
if check && not loc.Location.loc_ghost &&
Warnings.is_active (Warnings.Unused_extension ("", false, false, false))

2
typing/mtype.ml
View File

@ -213,7 +213,7 @@ and nondep_sig_item env va ids = function
with Ctype.Nondep_cannot_erase _ as exn ->
match va with
Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none;
mtd_attributes=[]}, vis)
mtd_attributes=[]; mtd_uid = d.mtd_uid}, vis)
| _ -> raise exn
end
| Sig_class(id, d, rs, vis) ->

159
typing/predef.ml
View File

@ -116,41 +116,6 @@ let path_match_failure = Pident ident_match_failure
and path_assert_failure = Pident ident_assert_failure
and path_undefined_recursive_module = Pident ident_undefined_recursive_module
let decl_abstr =
{type_params = [];
type_arity = 0;
type_kind = Type_abstract;
type_loc = Location.none;
type_private = Asttypes.Public;
type_manifest = None;
type_variance = [];
type_separability = [];
type_is_newtype = false;
type_expansion_scope = lowest_level;
type_attributes = [];
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
}
let decl_abstr_with_one_param variance separability type_kind_fun =
let tvar = newgenvar() in
{type_params = [tvar];
type_arity = 1;
type_kind = type_kind_fun tvar;
type_loc = Location.none;
type_private = Asttypes.Public;
type_manifest = None;
type_variance = [variance];
type_separability = [separability];
type_is_newtype = false;
type_expansion_scope = lowest_level;
type_attributes = [];
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
}
let decl_abstr_imm = {decl_abstr with type_immediate = Always}
let cstr id args =
{
cd_id = id;
@ -158,6 +123,7 @@ let cstr id args =
cd_res = None;
cd_loc = Location.none;
cd_attributes = [];
cd_uid = Uid.of_predef_id id;
}
let ident_false = ident_create "false"
@ -167,32 +133,52 @@ and ident_nil = ident_create "[]"
and ident_cons = ident_create "::"
and ident_none = ident_create "None"
and ident_some = ident_create "Some"
let common_initial_env add_type add_extension empty_env =
let decl_bool =
{decl_abstr_imm with
type_kind = Type_variant([cstr ident_false []; cstr ident_true []])}
and decl_unit =
{decl_abstr_imm with
type_kind = Type_variant([cstr ident_void []])}
and decl_exn =
{decl_abstr with
type_kind = Type_open}
and decl_array =
decl_abstr_with_one_param
Variance.full Separability.Ind (fun _ -> Type_abstract)
and decl_list =
decl_abstr_with_one_param
Variance.covariant Separability.Ind (fun tvar -> Type_variant(
[cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]))
and decl_option =
decl_abstr_with_one_param
Variance.covariant Separability.Ind (fun tvar -> Type_variant(
[cstr ident_none []; cstr ident_some [tvar]]))
and decl_lazy_t =
decl_abstr_with_one_param
Variance.covariant Separability.Ind (fun _ -> Type_abstract)
in
let mk_add_type add_type type_ident
?manifest ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract) env =
let decl =
{type_params = [];
type_arity = 0;
type_kind = kind;
type_loc = Location.none;
type_private = Asttypes.Public;
type_manifest = manifest;
type_variance = [];
type_separability = [];
type_is_newtype = false;
type_expansion_scope = lowest_level;
type_attributes = [];
type_immediate = immediate;
type_unboxed = unboxed_false_default_false;
type_uid = Uid.of_predef_id type_ident;
}
in
add_type type_ident decl env
let common_initial_env add_type add_extension empty_env =
let add_type = mk_add_type add_type
and add_type1 type_ident
~variance ~separability ?(kind=fun _ -> Type_abstract) env =
let param = newgenvar () in
let decl =
{type_params = [param];
type_arity = 1;
type_kind = kind param;
type_loc = Location.none;
type_private = Asttypes.Public;
type_manifest = None;
type_variance = [variance];
type_separability = [separability];
type_is_newtype = false;
type_expansion_scope = lowest_level;
type_attributes = [];
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = Uid.of_predef_id type_ident;
}
in
add_type type_ident decl env
in
let add_extension id l =
add_extension id
{ ext_type_path = path_exn;
@ -203,7 +189,9 @@ let common_initial_env add_type add_extension empty_env =
ext_loc = Location.none;
ext_attributes = [Ast_helper.Attr.mk
(Location.mknoloc "ocaml.warn_on_literal_pattern")
(Parsetree.PStr [])] }
(Parsetree.PStr [])];
ext_uid = Uid.of_predef_id id;
}
in
add_extension ident_match_failure
[newgenty (Ttuple[type_string; type_int; type_int])] (
@ -220,29 +208,40 @@ let common_initial_env add_type add_extension empty_env =
[newgenty (Ttuple[type_string; type_int; type_int])] (
add_extension ident_undefined_recursive_module
[newgenty (Ttuple[type_string; type_int; type_int])] (
add_type ident_int64 decl_abstr (
add_type ident_int32 decl_abstr (
add_type ident_nativeint decl_abstr (
add_type ident_lazy_t decl_lazy_t (
add_type ident_option decl_option (
add_type ident_list decl_list (
add_type ident_array decl_array (
add_type ident_exn decl_exn (
add_type ident_unit decl_unit (
add_type ident_bool decl_bool (
add_type ident_float decl_abstr (
add_type ident_string decl_abstr (
add_type ident_char decl_abstr_imm (
add_type ident_int decl_abstr_imm (
add_type ident_extension_constructor decl_abstr (
add_type ident_floatarray decl_abstr (
add_type ident_int64 (
add_type ident_int32 (
add_type ident_nativeint (
add_type1 ident_lazy_t ~variance:Variance.covariant
~separability:Separability.Ind (
add_type1 ident_option ~variance:Variance.covariant
~separability:Separability.Ind
~kind:(fun tvar ->
Type_variant([cstr ident_none []; cstr ident_some [tvar]])
) (
add_type1 ident_list ~variance:Variance.covariant
~separability:Separability.Ind
~kind:(fun tvar ->
Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]])
) (
add_type1 ident_array ~variance:Variance.full ~separability:Separability.Ind (
add_type ident_exn ~kind:Type_open (
add_type ident_unit ~immediate:Always
~kind:(Type_variant([cstr ident_void []])) (
add_type ident_bool ~immediate:Always
~kind:(Type_variant([cstr ident_false []; cstr ident_true []])) (
add_type ident_float (
add_type ident_string (
add_type ident_char ~immediate:Always (
add_type ident_int ~immediate:Always (
add_type ident_extension_constructor (
add_type ident_floatarray (
empty_env))))))))))))))))))))))))))))
let build_initial_env add_type add_exception empty_env =
let common = common_initial_env add_type add_exception empty_env in
let safe_string = add_type ident_bytes decl_abstr common in
let decl_bytes_unsafe = {decl_abstr with type_manifest = Some type_string} in
let unsafe_string = add_type ident_bytes decl_bytes_unsafe common in
let add_type = mk_add_type add_type in
let safe_string = add_type ident_bytes common in
let unsafe_string = add_type ident_bytes ~manifest:type_string common in
(safe_string, unsafe_string)
let builtin_values =

1
typing/printtyp.ml
View File

@ -1592,6 +1592,7 @@ let dummy =
type_attributes = [];
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = Uid.internal_not_actually_unique;
}
let hide ids env = List.fold_right

12
typing/subst.ml
View File

@ -263,6 +263,7 @@ let label_declaration copy_scope s l =
ld_type = typexp copy_scope s l.ld_type;
ld_loc = loc s l.ld_loc;
ld_attributes = attrs s l.ld_attributes;
ld_uid = l.ld_uid;
}
let constructor_arguments copy_scope s = function
@ -278,6 +279,7 @@ let constructor_declaration copy_scope s c =
cd_res = Option.map (typexp copy_scope s) c.cd_res;
cd_loc = loc s c.cd_loc;
cd_attributes = attrs s c.cd_attributes;
cd_uid = c.cd_uid;
}
let type_declaration' copy_scope s decl =
@ -307,6 +309,7 @@ let type_declaration' copy_scope s decl =
type_attributes = attrs s decl.type_attributes;
type_immediate = decl.type_immediate;
type_unboxed = decl.type_unboxed;
type_uid = decl.type_uid;
}
let type_declaration s decl =
@ -347,6 +350,7 @@ let class_declaration' copy_scope s decl =
end;
cty_loc = loc s decl.cty_loc;
cty_attributes = attrs s decl.cty_attributes;
cty_uid = decl.cty_uid;
}
let class_declaration s decl =
@ -359,6 +363,7 @@ let cltype_declaration' copy_scope s decl =
clty_path = type_path s decl.clty_path;
clty_loc = loc s decl.clty_loc;
clty_attributes = attrs s decl.clty_attributes;
clty_uid = decl.clty_uid;
}
let cltype_declaration s decl =
@ -372,6 +377,7 @@ let value_description' copy_scope s descr =
val_kind = descr.val_kind;
val_loc = loc s descr.val_loc;
val_attributes = attrs s descr.val_attributes;
val_uid = descr.val_uid;
}
let value_description s descr =
@ -384,7 +390,9 @@ let extension_constructor' copy_scope s ext =
ext_ret_type = Option.map (typexp copy_scope s) ext.ext_ret_type;
ext_private = ext.ext_private;
ext_attributes = attrs s ext.ext_attributes;
ext_loc = if s.for_saving then Location.none else ext.ext_loc; }
ext_loc = if s.for_saving then Location.none else ext.ext_loc;
ext_uid = ext.ext_uid;
}
let extension_constructor s ext =
For_copy.with_scope
@ -506,6 +514,7 @@ and module_declaration scoping s decl =
md_type = modtype scoping s decl.md_type;
md_attributes = attrs s decl.md_attributes;
md_loc = loc s decl.md_loc;
md_uid = decl.md_uid;
}
and modtype_declaration scoping s decl =
@ -513,6 +522,7 @@ and modtype_declaration scoping s decl =
mtd_type = Option.map (modtype scoping s) decl.mtd_type;
mtd_attributes = attrs s decl.mtd_attributes;
mtd_loc = loc s decl.mtd_loc;
mtd_uid = decl.mtd_uid;
}

25
typing/typeclass.ml
View File

@ -263,7 +263,8 @@ let enter_met_env ?check loc lab kind unbound_kind ty val_env met_env par_env =
let (id, met_env) =
Env.enter_value ?check lab
{val_type = ty; val_kind = kind;
val_attributes = []; Types.val_loc = loc} met_env
val_attributes = []; Types.val_loc = loc;
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } met_env
in
(id, val_env, met_env, par_env)
@ -1199,6 +1200,7 @@ and class_expr_aux cl_num val_env met_env scl =
cl_num);
val_attributes = [];
Types.val_loc = vd.Types.val_loc;
val_uid = vd.val_uid;
}
in
let id' = Ident.create_local (Ident.name id) in
@ -1291,7 +1293,7 @@ let rec approx_description ct =
(*******************************)
let temp_abbrev loc env id arity =
let temp_abbrev loc env id arity uid =
let params = ref [] in
for _i = 1 to arity do
params := Ctype.newvar () :: !params
@ -1312,17 +1314,18 @@ let temp_abbrev loc env id arity =
type_attributes = []; (* or keep attrs from the class decl? *)
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = uid;
}
env
in
(!params, ty, env)
let initial_env define_class approx
(res, env) (cl, id, ty_id, obj_id, cl_id) =
(res, env) (cl, id, ty_id, obj_id, cl_id, uid) =
(* Temporary abbreviations *)
let arity = List.length cl.pci_params in
let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in
let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in
let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity uid in
let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity uid in
(* Temporary type for the class constructor *)
let constr_type = approx cl.pci_expr in
@ -1346,6 +1349,7 @@ let initial_env define_class approx
end;
cty_loc = Location.none;
cty_attributes = [];
cty_uid = uid;
}
in
let env =
@ -1356,6 +1360,7 @@ let initial_env define_class approx
clty_path = unbound_class;
clty_loc = Location.none;
clty_attributes = [];
clty_uid = uid;
}
(
if define_class then
@ -1486,6 +1491,7 @@ let class_infos define_class kind
clty_path = Path.Pident obj_id;
clty_loc = cl.pci_loc;
clty_attributes = cl.pci_attributes;
clty_uid = dummy_class.cty_uid;
}
and clty =
{cty_params = params; cty_type = typ;
@ -1498,6 +1504,7 @@ let class_infos define_class kind
end;
cty_loc = cl.pci_loc;
cty_attributes = cl.pci_attributes;
cty_uid = dummy_class.cty_uid;
}
in
dummy_class.cty_type <- typ;
@ -1535,6 +1542,7 @@ let class_infos define_class kind
clty_path = Path.Pident obj_id;
clty_loc = cl.pci_loc;
clty_attributes = cl.pci_attributes;
clty_uid = dummy_class.cty_uid;
}
and clty =
{cty_params = params'; cty_type = typ';
@ -1547,6 +1555,7 @@ let class_infos define_class kind
end;
cty_loc = cl.pci_loc;
cty_attributes = cl.pci_attributes;
cty_uid = dummy_class.cty_uid;
}
in
let obj_abbr =
@ -1565,6 +1574,7 @@ let class_infos define_class kind
type_attributes = []; (* or keep attrs from cl? *)
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = dummy_class.cty_uid;
}
in
let (cl_params, cl_ty) =
@ -1588,6 +1598,7 @@ let class_infos define_class kind
type_attributes = []; (* or keep attrs from cl? *)
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = dummy_class.cty_uid;
}
in
((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
@ -1744,7 +1755,9 @@ let type_classes define_class approx kind env cls =
Ident.create_scoped ~scope cl.pci_name.txt,
Ident.create_scoped ~scope cl.pci_name.txt,
Ident.create_scoped ~scope cl.pci_name.txt,
Ident.create_scoped ~scope ("#" ^ cl.pci_name.txt)))
Ident.create_scoped ~scope ("#" ^ cl.pci_name.txt),
Uid.mk ~current_unit:(Env.get_unit_name ())
))
cls
in
Ctype.begin_class_def ();

75
typing/typecore.ml
View File

@ -1867,6 +1867,7 @@ let add_pattern_variables ?check ?check_as env pv =
Env.add_value ?check pv_id
{val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
val_attributes = pv_attributes;
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
} env
)
pv env
@ -1907,23 +1908,38 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
end;
List.iter (fun f -> f()) (get_ref pattern_force);
if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ()));
let (pv, met_env) =
let (pv, val_env, met_env) =
List.fold_right
(fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} (pv, env) ->
(fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes}
(pv, val_env, met_env) ->
let check s =
if pv_as_var then Warnings.Unused_var s
else Warnings.Unused_var_strict s in
let id' = Ident.create_local (Ident.name pv_id) in
((id', pv_id, pv_type)::pv,
Env.add_value id' {val_type = pv_type;
val_kind = Val_ivar (Immutable, cl_num);
val_attributes = pv_attributes;
Types.val_loc = pv_loc;
} ~check
env))
!pattern_variables ([], met_env)
let id' = Ident.rename pv_id in
let val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
let val_env =
Env.add_value pv_id
{ val_type = pv_type
; val_kind = Val_reg
; val_attributes = pv_attributes
; val_loc = pv_loc
; val_uid
}
val_env
in
let met_env =
Env.add_value id' ~check
{ val_type = pv_type
; val_kind = Val_ivar (Immutable, cl_num)
; val_attributes = pv_attributes
; val_loc = pv_loc
; val_uid
}
met_env
in
((id', pv_id, pv_type)::pv, val_env, met_env))
!pattern_variables ([], val_env, met_env)
in
let val_env = add_pattern_variables val_env (get_ref pattern_variables) in
(pat, pv, val_env, met_env)
let type_self_pattern cl_num privty val_env met_env par_env spat =
@ -1947,12 +1963,13 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
(val_env, met_env, par_env) ->
let name = Ident.name pv_id in
(Env.enter_unbound_value name Val_unbound_self val_env,
Env.add_value pv_id {val_type = pv_type;
val_kind =
Val_self (meths, vars, cl_num, privty);
val_attributes = pv_attributes;
Types.val_loc = pv_loc;
}
Env.add_value pv_id
{val_type = pv_type;
val_kind = Val_self (meths, vars, cl_num, privty);
val_attributes = pv_attributes;
val_loc = pv_loc;
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
~check:(fun s -> if pv_as_var then Warnings.Unused_var s
else Warnings.Unused_var_strict s)
met_env,
@ -2997,9 +3014,13 @@ and type_expect_
match param.ppat_desc with
| Ppat_any -> Ident.create_local "_for", env
| Ppat_var {txt} ->
Env.enter_value txt {val_type = instance Predef.type_int;
val_attributes = [];
val_kind = Val_reg; Types.val_loc = loc; } env
Env.enter_value txt
{val_type = instance Predef.type_int;
val_attributes = [];
val_kind = Val_reg;
val_loc = loc;
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
} env
~check:(fun s -> Warnings.Unused_for_index s)
| _ ->
raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
@ -3154,7 +3175,9 @@ and type_expect_
{val_type = method_type;
val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none}
val_loc = Location.none;
val_uid = Uid.internal_not_actually_unique;
}
in
let exp_env = Env.add_value method_id method_desc env in
let exp =
@ -3319,7 +3342,8 @@ and type_expect_
in
let scope = create_scope () in
let md =
{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc }
{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
in
let (id, new_env) =
match name.txt with
@ -3459,6 +3483,7 @@ and type_expect_
type_attributes = [];
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
let scope = create_scope () in
@ -4097,7 +4122,9 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
let desc =
{ val_type = ty; val_kind = Val_reg;
val_attributes = [];
Types.val_loc = Location.none}
val_loc = Location.none;
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
let exp_env = Env.add_value id desc env in
{pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];

52
typing/typedecl.ml
View File

@ -89,7 +89,7 @@ let add_type ~check id decl env =
Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
(fun () -> Env.add_type ~check id decl env)
let enter_type rec_flag env sdecl id =
let enter_type rec_flag env sdecl (id, uid) =
let needed =
match rec_flag with
| Asttypes.Nonrecursive ->
@ -122,6 +122,7 @@ let enter_type rec_flag env sdecl id =
type_attributes = sdecl.ptype_attributes;
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = uid;
}
in
add_type ~check:true id decl env
@ -229,7 +230,8 @@ let transl_labels env closed lbls =
ld_mutable = ld.ld_mutable;
ld_type = ty;
ld_loc = ld.ld_loc;
ld_attributes = ld.ld_attributes
ld_attributes = ld.ld_attributes;
ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
)
lbls in
@ -272,7 +274,7 @@ let make_constructor env type_path type_params sargs sret_type =
widen z;
targs, Some tret_type, args, Some ret_type
let transl_declaration env sdecl id =
let transl_declaration env sdecl (id, uid) =
(* Bind type parameters *)
reset_type_variables();
Ctype.begin_def ();
@ -365,7 +367,8 @@ let transl_declaration env sdecl id =
cd_args = args;
cd_res = ret_type;
cd_loc = scstr.pcd_loc;
cd_attributes = scstr.pcd_attributes }
cd_attributes = scstr.pcd_attributes;
cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
in
tcstr, cstr
in
@ -408,6 +411,7 @@ let transl_declaration env sdecl id =
type_attributes = sdecl.ptype_attributes;
type_immediate = Unknown;
type_unboxed = unboxed_status;
type_uid = uid;
} in
(* Check constraints *)
@ -824,18 +828,20 @@ let transl_type_decl env rec_flag sdecl_list =
(* Create identifiers. *)
let scope = Ctype.create_scope () in
let id_list =
List.map (fun sdecl -> Ident.create_scoped ~scope sdecl.ptype_name.txt)
sdecl_list
let ids_list =
List.map (fun sdecl ->
Ident.create_scoped ~scope sdecl.ptype_name.txt,
Uid.mk ~current_unit:(Env.get_unit_name ())
) sdecl_list
in
Ctype.begin_def();
(* Enter types. *)
let temp_env =
List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in
List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
(* Translate each declaration. *)
let current_slot = ref None in
let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
let id_slots id =
let ids_slots (id, _uid as ids) =
match rec_flag with
| Asttypes.Recursive when warn_unused ->
(* See typecore.ml for a description of the algorithm used
@ -853,9 +859,9 @@ let transl_type_decl env rec_flag sdecl_list =
(get_ref slot);
old_callback ()
);
id, Some slot
ids, Some slot
| Asttypes.Recursive | Asttypes.Nonrecursive ->
id, None
ids, None
in
let transl_declaration name_sdecl (id, slot) =
current_slot := slot;
@ -864,7 +870,7 @@ let transl_type_decl env rec_flag sdecl_list =
(fun () -> transl_declaration temp_env name_sdecl id)
in
let tdecls =
List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
let decls =
List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
current_slot := None;
@ -877,16 +883,16 @@ let transl_type_decl env rec_flag sdecl_list =
| Asttypes.Nonrecursive -> ()
| Asttypes.Recursive ->
List.iter2
(fun id sdecl -> update_type temp_env new_env id sdecl.ptype_loc)
id_list sdecl_list
(fun (id, _) sdecl -> update_type temp_env new_env id sdecl.ptype_loc)
ids_list sdecl_list
end;
(* Generalize type declarations. *)
Ctype.end_def();
List.iter (fun (_, decl) -> generalize_decl decl) decls;
(* Check for ill-formed abbrevs *)
let id_loc_list =
List.map2 (fun id sdecl -> (id, sdecl.ptype_loc))
id_list sdecl_list
List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
ids_list sdecl_list
in
List.iter (fun (id, decl) ->
check_well_founded_manifest new_env (List.assoc id id_loc_list)
@ -1045,7 +1051,9 @@ let transl_extension_constructor env type_path type_params
ext_ret_type = ret_type;
ext_private = priv;
Types.ext_loc = sext.pext_loc;
Types.ext_attributes = sext.pext_attributes; }
Types.ext_attributes = sext.pext_attributes;
ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
{ ext_id = id;
ext_name = sext.pext_name;
@ -1309,7 +1317,9 @@ let transl_value_decl env loc valdecl =
match valdecl.pval_prim with
[] when Env.is_in_signature env ->
{ val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
val_attributes = valdecl.pval_attributes }
val_attributes = valdecl.pval_attributes;
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
| [] ->
raise (Error(valdecl.pval_loc, Val_in_structure))
| _ ->
@ -1337,7 +1347,9 @@ let transl_value_decl env loc valdecl =
then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
check_unboxable env loc ty;
{ val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
val_attributes = valdecl.pval_attributes }
val_attributes = valdecl.pval_attributes;
val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
let (id, newenv) =
Env.enter_value valdecl.pval_name.txt v env
@ -1420,6 +1432,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
type_attributes = sdecl.ptype_attributes;
type_immediate = Unknown;
type_unboxed;
type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
begin match row_path with None -> ()
@ -1473,6 +1486,7 @@ let abstract_type_decl arity =
type_attributes = [];
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = Uid.internal_not_actually_unique;
} in
Ctype.end_def();
generalize_decl decl;

89
typing/typemod.ml
View File

@ -500,6 +500,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
type_attributes = [];
type_immediate = Unknown;
type_unboxed = unboxed_false_default_false;
type_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
and id_row = Ident.create_local (s^"#row") in
let initial_env =
@ -744,6 +745,7 @@ and approx_module_declaration env pmd =
Types.md_type = approx_modtype env pmd.pmd_type;
md_attributes = pmd.pmd_attributes;
md_loc = pmd.pmd_loc;
md_uid = Uid.internal_not_actually_unique;
}
and approx_sig env ssg =
@ -846,6 +848,7 @@ and approx_modtype_info env sinfo =
mtd_type = Option.map (approx_modtype env) sinfo.pmtd_type;
mtd_attributes = sinfo.pmtd_attributes;
mtd_loc = sinfo.pmtd_loc;
mtd_uid = Uid.internal_not_actually_unique;
}
let approx_modtype env smty =
@ -1159,6 +1162,7 @@ and transl_modtype_aux env smty =
{ md_type = arg.mty_type;
md_attributes = [];
md_loc = param.loc;
md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
Env.enter_module_declaration ~scope ~arg:true name Mp_present
@ -1296,6 +1300,7 @@ and transl_signature env sg =
md_type=tmty.mty_type;
md_attributes=pmd.pmd_attributes;
md_loc=pmd.pmd_loc;
md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
let id, newenv =
@ -1331,7 +1336,9 @@ and transl_signature env sg =
else
{ md_type = Mty_alias path;
md_attributes = pms.pms_attributes;
md_loc = pms.pms_loc }
md_loc = pms.pms_loc;
md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
let pres =
match md.md_type with
@ -1357,21 +1364,22 @@ and transl_signature env sg =
let (tdecls, newenv) =
transl_recmodule_modtypes env sdecls in
let decls =
List.filter_map (fun md ->
List.filter_map (fun (md, uid) ->
match md.md_id with
| None -> None
| Some id -> Some (id, md)
| Some id -> Some (id, md, uid)
) tdecls
in
List.iter
(fun (id, md) -> Signature_names.check_module names md.md_loc id)
decls;
List.iter (fun (id, md, _) ->
Signature_names.check_module names md.md_loc id
) decls;
let (trem, rem, final_env) = transl_sig newenv srem in
mksig (Tsig_recmodule tdecls) env loc :: trem,
map_rec (fun rs (id, md) ->
mksig (Tsig_recmodule (List.map fst tdecls)) env loc :: trem,
map_rec (fun rs (id, md, uid) ->
let d = {Types.md_type = md.md_type.mty_type;
md_attributes = md.md_attributes;
md_loc = md.md_loc;
md_uid = uid;
} in
Sig_module(id, Mp_present, d, rs, Exported))
decls rem,
@ -1501,6 +1509,7 @@ and transl_modtype_decl_aux names env
Types.mtd_type=Option.map (fun t -> t.mty_type) tmty;
mtd_attributes=pmtd_attributes;
mtd_loc=pmtd_loc;
mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
let scope = Ctype.create_scope () in
@ -1547,7 +1556,8 @@ and transl_recmodule_modtypes env sdecls =
Option.map (fun id ->
(id, Types.{md_type = mty.mty_type;
md_loc = mty.mty_loc;
md_attributes = mty.mty_attributes})
md_attributes = mty.mty_attributes;
md_uid = Uid.internal_not_actually_unique; })
) id)
in
let scope = Ctype.create_scope () in
@ -1587,13 +1597,15 @@ and transl_recmodule_modtypes env sdecls =
let env2 = make_env2 dcl2 in
check_recmod_typedecls env2 (map_mtys dcl2);
let dcl2 =
List.map2
(fun pmd (id, id_loc, mty) ->
List.map2 (fun pmd (id, id_loc, mty) ->
let md =
{md_id=id; md_name=id_loc; md_type=mty;
md_presence=Mp_present;
md_loc=pmd.pmd_loc;
md_attributes=pmd.pmd_attributes})
sdecls dcl2
md_attributes=pmd.pmd_attributes}
in
md, Uid.mk ~current_unit:(Env.get_unit_name ())
) sdecls dcl2
in
(dcl2, env2)
@ -1719,7 +1731,7 @@ let check_recmodule_inclusion env bindings =
(* Generate fresh names Y_i for the rec. bound module idents X_i *)
let bindings1 =
List.map
(fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc) ->
(fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc, _uid) ->
let ids =
Option.map
(fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id
@ -1754,7 +1766,8 @@ let check_recmodule_inclusion env bindings =
end else begin
(* Base case: check inclusion of s(mty_actual) in s(mty_decl)
and insert coercion if needed *)
let check_inclusion (id, name, mty_decl, modl, mty_actual, attrs, loc) =
let check_inclusion
(id, name, mty_decl, modl, mty_actual, attrs, loc, uid) =
let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type
and mty_actual' = subst_and_strengthen env scope s id mty_actual in
let coercion =
@ -1770,14 +1783,17 @@ let check_recmodule_inclusion env bindings =
mod_loc = modl.mod_loc;
mod_attributes = [];
} in
{
mb_id = id;
mb_name = name;
mb_presence = Mp_present;
mb_expr = modl';
mb_attributes = attrs;
mb_loc = loc;
}
let mb =
{
mb_id = id;
mb_name = name;
mb_presence = Mp_present;
mb_expr = modl';
mb_attributes = attrs;
mb_loc = loc;
}
in
mb, uid
in
List.map check_inclusion bindings
end
@ -1920,6 +1936,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
{ md_type = mty.mty_type;
md_attributes = [];
md_loc = param.loc;
md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
let id, newenv =
@ -2208,10 +2225,12 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
| Mty_alias _ -> Mp_absent
| _ -> Mp_present
in
let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
let md =
{ md_type = enrich_module_type anchor name.txt modl.mod_type env;
md_attributes = attrs;
md_loc = pmb_loc;
md_uid;
}
in
(*prerr_endline (Ident.unique_toplevel_name id);*)
@ -2227,6 +2246,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
{md_type = modl.mod_type;
md_attributes = attrs;
md_loc = pmb_loc;
md_uid;
}, Trec_not, Exported)]
in
Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
@ -2256,12 +2276,12 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
pmd_attributes=attrs; pmd_loc=loc}) sbind
) in
List.iter
(fun md ->
(fun (md, _) ->
Option.iter Signature_names.(check_module names md.md_loc) md.md_id)
decls;
let bindings1 =
List.map2
(fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) ->
(fun ({md_id=id; md_type=mty}, uid) (name, _, smodl, attrs, loc) ->
let modl =
Builtin_attributes.warning_scope attrs
(fun () ->
@ -2272,11 +2292,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let mty' =
enrich_module_type anchor name.txt modl.mod_type newenv
in
(id, name, mty, modl, mty', attrs, loc))
(id, name, mty, modl, mty', attrs, loc, uid))
decls sbind in
let newenv = (* allow aliasing recursive modules from outside *)
List.fold_left
(fun env md ->
(fun env (md, uid) ->
match md.md_id with
| None -> env
| Some id ->
@ -2285,6 +2305,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
md_type = md.md_type.mty_type;
md_attributes = md.md_attributes;
md_loc = md.md_loc;
md_uid = uid;
}
in
Env.add_module_declaration ~check:true
@ -2295,15 +2316,17 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let bindings2 =
check_recmodule_inclusion newenv bindings1 in
let mbs =
List.filter_map (fun mb -> Option.map (fun id -> id, mb) mb.mb_id)
bindings2
List.filter_map (fun (mb, uid) ->
Option.map (fun id -> id, mb, uid) mb.mb_id
) bindings2
in
Tstr_recmodule bindings2,
map_rec (fun rs (id, mb) ->
Tstr_recmodule (List.map fst bindings2),
map_rec (fun rs (id, mb, uid) ->
Sig_module(id, Mp_present, {
md_type=mb.mb_expr.mod_type;
md_attributes=mb.mb_attributes;
md_loc=mb.mb_loc;
md_uid = uid;
}, rs, Exported))
mbs [],
newenv
@ -2705,7 +2728,9 @@ let package_signatures units =
let md =
{ md_type=Mty_signature sg;
md_attributes=[];
md_loc=Location.none; }
md_loc=Location.none;
md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
}
in
Sig_module(newid, Mp_present, md, Trec_not, Exported))
units_with_ids

56
typing/types.ml
View File

@ -79,6 +79,34 @@ module TypeOps = struct
let equal t1 t2 = t1 == t2
end
(* *)
module Uid = struct
type t =
| Compilation_unit of string
| Item of { comp_unit: string; id: int }
| Internal
| Predef of string
let mk =
let id = ref (-1) in
fun ~current_unit ->
incr id;
Item { comp_unit = current_unit; id = !id }
let of_compilation_unit_id id =
if not (Ident.persistent id) then
Misc.fatal_errorf "Types.Uid.of_compilation_unit_id %S" (Ident.name id);
Compilation_unit (Ident.name id)
let of_predef_id id =
if not (Ident.is_predef id) then
Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id);
Predef (Ident.name id)
let internal_not_actually_unique = Internal
end
(* Maps of methods and instance variables *)
module Meths = Misc.Stdlib.String.Map
@ -91,7 +119,8 @@ type value_description =
val_kind: value_kind;
val_loc: Location.t;
val_attributes: Parsetree.attributes;
}
val_uid: Uid.t;
}
and value_kind =
Val_reg (* Regular value *)
@ -178,6 +207,7 @@ type type_declaration =
type_attributes: Parsetree.attributes;
type_immediate: Type_immediacy.t;
type_unboxed: unboxed_status;
type_uid: Uid.t;
}
and type_kind =
@ -200,6 +230,7 @@ and label_declaration =
ld_type: type_expr;
ld_loc: Location.t;
ld_attributes: Parsetree.attributes;
ld_uid: Uid.t;
}
and constructor_declaration =
@ -209,6 +240,7 @@ and constructor_declaration =
cd_res: type_expr option;
cd_loc: Location.t;
cd_attributes: Parsetree.attributes;
cd_uid: Uid.t;
}
and constructor_arguments =
@ -227,13 +259,15 @@ let unboxed_true_default_false = {unboxed = true; default = false}
let unboxed_true_default_true = {unboxed = true; default = true}
type extension_constructor =
{ ext_type_path: Path.t;
ext_type_params: type_expr list;
ext_args: constructor_arguments;
ext_ret_type: type_expr option;
ext_private: private_flag;
ext_loc: Location.t;
ext_attributes: Parsetree.attributes; }
{ ext_type_path: Path.t;
ext_type_params: type_expr list;
ext_args: constructor_arguments;
ext_ret_type: type_expr option;
ext_private: private_flag;
ext_loc: Location.t;
ext_attributes: Parsetree.attributes;
ext_uid: Uid.t;
}
and type_transparence =
Type_public (* unrestricted expansion *)
@ -264,6 +298,7 @@ type class_declaration =
cty_variance: Variance.t list;
cty_loc: Location.t;
cty_attributes: Parsetree.attributes;
cty_uid: Uid.t;
}
type class_type_declaration =
@ -273,6 +308,7 @@ type class_type_declaration =
clty_variance: Variance.t list;
clty_loc: Location.t;
clty_attributes: Parsetree.attributes;
clty_uid: Uid.t;
}
(* Type expressions for the module language *)
@ -312,6 +348,7 @@ and module_declaration =
md_type: module_type;
md_attributes: Parsetree.attributes;
md_loc: Location.t;
md_uid: Uid.t;
}
and modtype_declaration =
@ -319,6 +356,7 @@ and modtype_declaration =
mtd_type: module_type option; (* Note: abstract *)
mtd_attributes: Parsetree.attributes;
mtd_loc: Location.t;
mtd_uid: Uid.t;
}
and rec_status =
@ -350,6 +388,7 @@ type constructor_description =
cstr_loc: Location.t;
cstr_attributes: Parsetree.attributes;
cstr_inlined: type_declaration option;
cstr_uid: Uid.t;
}
and constructor_tag =
@ -383,6 +422,7 @@ type label_description =
lbl_private: private_flag; (* Read-only field? *)
lbl_loc: Location.t;
lbl_attributes: Parsetree.attributes;
lbl_uid: Uid.t;
}
let rec bound_value_identifiers = function

42
typing/types.mli
View File

@ -240,6 +240,17 @@ module TypeOps : sig
val hash : t -> int
end
(* *)
module Uid : sig
type t
val mk : current_unit:string -> t
val of_compilation_unit_id : Ident.t -> t
val of_predef_id : Ident.t -> t
val internal_not_actually_unique : t
end
(* Maps of methods and instance variables *)
module Meths : Map.S with type key = string
@ -252,7 +263,8 @@ type value_description =
val_kind: value_kind;
val_loc: Location.t;
val_attributes: Parsetree.attributes;
}
val_uid: Uid.t;
}
and value_kind =
Val_reg (* Regular value *)
@ -334,6 +346,7 @@ type type_declaration =
type_attributes: Parsetree.attributes;
type_immediate: Type_immediacy.t;
type_unboxed: unboxed_status;
type_uid: Uid.t;
}
and type_kind =
@ -356,6 +369,7 @@ and label_declaration =
ld_type: type_expr;
ld_loc: Location.t;
ld_attributes: Parsetree.attributes;
ld_uid: Uid.t;
}
and constructor_declaration =
@ -365,6 +379,7 @@ and constructor_declaration =
cd_res: type_expr option;
cd_loc: Location.t;
cd_attributes: Parsetree.attributes;
cd_uid: Uid.t;
}
and constructor_arguments =
@ -386,15 +401,16 @@ val unboxed_true_default_false : unboxed_status
val unboxed_true_default_true : unboxed_status
type extension_constructor =
{
ext_type_path: Path.t;
ext_type_params: type_expr list;
ext_args: constructor_arguments;
ext_ret_type: type_expr option;
ext_private: private_flag;
ext_loc: Location.t;
ext_attributes: Parsetree.attributes;
}
{
ext_type_path: Path.t;
ext_type_params: type_expr list;
ext_args: constructor_arguments;
ext_ret_type: type_expr option;
ext_private: private_flag;
ext_loc: Location.t;
ext_attributes: Parsetree.attributes;
ext_uid: Uid.t;
}
and type_transparence =
Type_public (* unrestricted expansion *)
@ -425,6 +441,7 @@ type class_declaration =
cty_variance: Variance.t list;
cty_loc: Location.t;
cty_attributes: Parsetree.attributes;
cty_uid: Uid.t;
}
type class_type_declaration =
@ -434,6 +451,7 @@ type class_type_declaration =
clty_variance: Variance.t list;
clty_loc: Location.t;
clty_attributes: Parsetree.attributes;
clty_uid: Uid.t;
}
(* Type expressions for the module language *)
@ -473,6 +491,7 @@ and module_declaration =
md_type: module_type;
md_attributes: Parsetree.attributes;
md_loc: Location.t;
md_uid: Uid.t;
}
and modtype_declaration =
@ -480,6 +499,7 @@ and modtype_declaration =
mtd_type: module_type option; (* None: abstract *)
mtd_attributes: Parsetree.attributes;
mtd_loc: Location.t;
mtd_uid: Uid.t;
}
and rec_status =
@ -511,6 +531,7 @@ type constructor_description =
cstr_loc: Location.t;
cstr_attributes: Parsetree.attributes;
cstr_inlined: type_declaration option;
cstr_uid: Uid.t;
}
and constructor_tag =
@ -538,6 +559,7 @@ type label_description =
lbl_private: private_flag; (* Read-only field? *)
lbl_loc: Location.t;
lbl_attributes: Parsetree.attributes;
lbl_uid: Uid.t;
}
(** Extracts the list of "value" identifiers bound by a signature.