commit
c323d11144
3
Changes
3
Changes
|
@ -188,6 +188,9 @@ Working version
|
|||
runtime/win32.c removed).
|
||||
(David Allsopp, review by Oliver Andrieu and Xavier Leroy)
|
||||
|
||||
- #8934: Stop relying on location to track usage
|
||||
(Thomas Refis, review by Gabriel Radanne)
|
||||
|
||||
- #8970: separate value patterns (matching on values) from computation patterns
|
||||
(matching on the effects of a copmutation) in the typedtree.
|
||||
(Gabriel Scherer, review by Jacques Garrigue and Alain Frisch)
|
||||
|
|
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -42,6 +42,7 @@ let init_path ?(dir="") () =
|
|||
|
||||
let initial_env () =
|
||||
Ident.reinit();
|
||||
Types.Uid.reinit();
|
||||
let initially_opened_module =
|
||||
if !Clflags.nopervasives then
|
||||
None
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -2,14 +2,7 @@ File "test_loc_type_eq.ml", line 1, characters 49-76:
|
|||
1 | module M : Test_functor.S with type elt = unit = Test_functor.Apply (String)
|
||||
^^^^^^^^^^^^^^^^^^^^^^^^^^^
|
||||
Error: Signature mismatch:
|
||||
Modules do not match:
|
||||
sig
|
||||
type elt = String.t
|
||||
type t = Test_functor.Apply(String).t
|
||||
val create : elt -> t
|
||||
end
|
||||
is not included in
|
||||
sig type elt = unit type t val create : elt -> t end
|
||||
...
|
||||
Type declarations do not match:
|
||||
type elt = String.t
|
||||
is not included in
|
||||
|
|
|
@ -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)]
|
||||
)
|
||||
|
|
|
@ -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
|
||||
|
@ -4679,6 +4680,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 ();
|
||||
|
@ -4715,6 +4717,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 ();
|
||||
|
@ -4758,6 +4761,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 ();
|
||||
|
@ -4772,6 +4776,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 ();
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
||||
|
||||
|
|
235
typing/env.ml
235
typing/env.ml
|
@ -27,16 +27,17 @@ module String = Misc.Stdlib.String
|
|||
|
||||
let add_delayed_check_forward = ref (fun _ -> assert false)
|
||||
|
||||
let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t =
|
||||
Hashtbl.create 16
|
||||
(* This table is used to usage of value declarations. A declaration is
|
||||
identified with its name and location. The callback attached to a
|
||||
declaration is called whenever the value is used explicitly
|
||||
(lookup_value) or implicitly (inclusion test between signatures,
|
||||
cf Includemod.value_descriptions). *)
|
||||
type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t
|
||||
(** This table is used to track usage of value declarations.
|
||||
A declaration is identified by its uid.
|
||||
The callback attached to a declaration is called whenever the value (or
|
||||
type, or ...) is used explicitly (lookup_value, ...) or implicitly
|
||||
(inclusion test between signatures, cf Includemod.value_descriptions, ...).
|
||||
*)
|
||||
|
||||
let type_declarations = Hashtbl.create 16
|
||||
let module_declarations = Hashtbl.create 16
|
||||
let value_declarations : unit usage_tbl = Types.Uid.Tbl.create 16
|
||||
let type_declarations : unit usage_tbl = Types.Uid.Tbl.create 16
|
||||
let module_declarations : unit usage_tbl = Types.Uid.Tbl.create 16
|
||||
|
||||
type constructor_usage = Positive | Pattern | Privatize
|
||||
type constructor_usages =
|
||||
|
@ -58,9 +59,7 @@ let add_constructor_usage priv cu usage =
|
|||
let constructor_usages () =
|
||||
{cu_positive = false; cu_pattern = false; cu_privatize = false}
|
||||
|
||||
let used_constructors :
|
||||
(string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t
|
||||
= Hashtbl.create 16
|
||||
let used_constructors : constructor_usage usage_tbl = Types.Uid.Tbl.create 16
|
||||
|
||||
(** Map indexed by the name of module components. *)
|
||||
module NameMap = String.Map
|
||||
|
@ -407,7 +406,7 @@ and module_declaration_lazy =
|
|||
and module_components =
|
||||
{
|
||||
alerts: alerts;
|
||||
loc: Location.t;
|
||||
uid: Uid.t;
|
||||
comps:
|
||||
(components_maker,
|
||||
(module_components_repr, module_components_failure) result)
|
||||
|
@ -648,7 +647,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 *)
|
||||
|
||||
|
@ -703,10 +703,10 @@ let add_persistent_structure id env =
|
|||
else
|
||||
env
|
||||
|
||||
let components_of_module ~alerts ~loc env fs ps path addr mty =
|
||||
let components_of_module ~alerts ~uid env fs ps path addr mty =
|
||||
{
|
||||
alerts;
|
||||
loc;
|
||||
uid;
|
||||
comps = EnvLazy.create {
|
||||
cm_env = env;
|
||||
cm_freshening_subst = fs;
|
||||
|
@ -728,8 +728,13 @@ let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } =
|
|||
Misc.Stdlib.String.Map.empty
|
||||
flags
|
||||
in
|
||||
let loc = Location.none in
|
||||
let md = md (Mty_signature sign) in
|
||||
let md =
|
||||
{ md_type = Mty_signature sign;
|
||||
md_loc = Location.none;
|
||||
md_attributes = [];
|
||||
md_uid = Uid.of_compilation_unit_id id;
|
||||
}
|
||||
in
|
||||
let mda_address = EnvLazy.create_forced (Aident id) in
|
||||
let mda_declaration =
|
||||
EnvLazy.create (Subst.identity, Subst.Make_local, md)
|
||||
|
@ -738,7 +743,7 @@ let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } =
|
|||
let freshening_subst =
|
||||
if freshen then (Some Subst.identity) else None
|
||||
in
|
||||
components_of_module ~alerts ~loc
|
||||
components_of_module ~alerts ~uid:md.md_uid
|
||||
empty freshening_subst Subst.identity
|
||||
path mda_address (Mty_signature sign)
|
||||
in
|
||||
|
@ -779,10 +784,10 @@ let is_imported_opaque modname =
|
|||
Persistent_env.is_imported_opaque persistent_env modname
|
||||
|
||||
let reset_declaration_caches () =
|
||||
Hashtbl.clear value_declarations;
|
||||
Hashtbl.clear type_declarations;
|
||||
Hashtbl.clear module_declarations;
|
||||
Hashtbl.clear used_constructors;
|
||||
Types.Uid.Tbl.clear value_declarations;
|
||||
Types.Uid.Tbl.clear type_declarations;
|
||||
Types.Uid.Tbl.clear module_declarations;
|
||||
Types.Uid.Tbl.clear used_constructors;
|
||||
()
|
||||
|
||||
let reset_cache () =
|
||||
|
@ -1499,7 +1504,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 +1529,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
|
||||
|
@ -1546,7 +1557,7 @@ let rec components_of_module_maker
|
|||
Builtin_attributes.alerts_of_attrs md.md_attributes
|
||||
in
|
||||
let comps =
|
||||
components_of_module ~alerts ~loc:md.md_loc !env freshening_sub
|
||||
components_of_module ~alerts ~uid:md.md_uid !env freshening_sub
|
||||
prefixing_sub path addr md.md_type
|
||||
in
|
||||
let mda =
|
||||
|
@ -1606,13 +1617,15 @@ let rec components_of_module_maker
|
|||
|
||||
(* Insertion of bindings by identifier + path *)
|
||||
|
||||
and check_usage loc id warn tbl =
|
||||
if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin
|
||||
and check_usage loc id uid warn tbl =
|
||||
if not loc.Location.loc_ghost &&
|
||||
Uid.for_actual_declaration uid &&
|
||||
Warnings.is_active (warn "")
|
||||
then begin
|
||||
let name = Ident.name id in
|
||||
let key = (name, loc) in
|
||||
if Hashtbl.mem tbl key then ()
|
||||
if Types.Uid.Tbl.mem tbl uid then ()
|
||||
else let used = ref false in
|
||||
Hashtbl.add tbl key (fun () -> used := true);
|
||||
Types.Uid.Tbl.add tbl uid (fun () -> used := true);
|
||||
if not (name = "" || name.[0] = '_' || name.[0] = '#')
|
||||
then
|
||||
!add_delayed_check_forward
|
||||
|
@ -1631,7 +1644,9 @@ and check_value_name name loc =
|
|||
|
||||
and store_value ?check id addr decl env =
|
||||
check_value_name (Ident.name id) decl.val_loc;
|
||||
Option.iter (fun f -> check_usage decl.val_loc id f value_declarations) check;
|
||||
Option.iter
|
||||
(fun f -> check_usage decl.val_loc id decl.val_uid f value_declarations)
|
||||
check;
|
||||
let vda = { vda_description = decl; vda_address = addr } in
|
||||
{ env with
|
||||
values = IdTbl.add id (Val_bound vda) env.values;
|
||||
|
@ -1640,10 +1655,14 @@ and store_value ?check id addr decl env =
|
|||
and store_type ~check id info env =
|
||||
let loc = info.type_loc in
|
||||
if check then
|
||||
check_usage loc id (fun s -> Warnings.Unused_type_declaration s)
|
||||
check_usage loc id info.type_uid
|
||||
(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
|
||||
|
@ -1656,10 +1675,11 @@ and store_type ~check id info env =
|
|||
begin fun (_, cstr) ->
|
||||
let name = cstr.cstr_name in
|
||||
let loc = cstr.cstr_loc in
|
||||
let k = (ty_name, loc, name) in
|
||||
if not (Hashtbl.mem used_constructors k) then
|
||||
let k = cstr.cstr_uid in
|
||||
if not (Types.Uid.Tbl.mem used_constructors k) then
|
||||
let used = constructor_usages () in
|
||||
Hashtbl.add used_constructors k (add_constructor_usage priv used);
|
||||
Types.Uid.Tbl.add used_constructors k
|
||||
(add_constructor_usage priv used);
|
||||
if not (ty_name = "" || ty_name.[0] = '_')
|
||||
then !add_delayed_check_forward
|
||||
(fun () ->
|
||||
|
@ -1697,19 +1717,20 @@ 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))
|
||||
then begin
|
||||
let priv = ext.ext_private in
|
||||
let is_exception = Path.same ext.ext_type_path Predef.path_exn in
|
||||
let ty_name = Path.last ext.ext_type_path in
|
||||
let name = cstr.cstr_name in
|
||||
let k = (ty_name, loc, name) in
|
||||
if not (Hashtbl.mem used_constructors k) then begin
|
||||
let k = cstr.cstr_uid in
|
||||
if not (Types.Uid.Tbl.mem used_constructors k) then begin
|
||||
let used = constructor_usages () in
|
||||
Hashtbl.add used_constructors k (add_constructor_usage priv used);
|
||||
Types.Uid.Tbl.add used_constructors k (add_constructor_usage priv used);
|
||||
!add_delayed_check_forward
|
||||
(fun () ->
|
||||
if not (is_in_signature env) && not used.cu_positive then
|
||||
|
@ -1726,7 +1747,8 @@ and store_extension ~check id addr ext env =
|
|||
|
||||
and store_module ~check ~freshening_sub id addr presence md env =
|
||||
let loc = md.md_loc in
|
||||
Option.iter (fun f -> check_usage loc id f module_declarations) check;
|
||||
Option.iter
|
||||
(fun f -> check_usage loc id md.md_uid f module_declarations) check;
|
||||
let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in
|
||||
let module_decl_lazy =
|
||||
match freshening_sub with
|
||||
|
@ -1734,7 +1756,7 @@ and store_module ~check ~freshening_sub id addr presence md env =
|
|||
| Some s -> EnvLazy.create (s, Subst.Rescope (Ident.scope id), md)
|
||||
in
|
||||
let comps =
|
||||
components_of_module ~alerts ~loc:md.md_loc
|
||||
components_of_module ~alerts ~uid:md.md_uid
|
||||
env freshening_sub Subst.identity (Pident id) addr md.md_type
|
||||
in
|
||||
let mda =
|
||||
|
@ -1785,7 +1807,7 @@ let components_of_functor_appl ~loc f env p1 p2 =
|
|||
("the signature of " ^ Path.name p) mty;
|
||||
let comps =
|
||||
components_of_module ~alerts:Misc.Stdlib.String.Map.empty
|
||||
~loc:Location.none
|
||||
~uid:Uid.internal_not_actually_unique
|
||||
(*???*)
|
||||
env None Subst.identity p addr mty
|
||||
in
|
||||
|
@ -2095,41 +2117,35 @@ let (initial_safe_string, initial_unsafe_string) =
|
|||
|
||||
(* Tracking usage *)
|
||||
|
||||
let mark_module_used name loc =
|
||||
match Hashtbl.find module_declarations (name, loc) with
|
||||
let mark_module_used uid =
|
||||
match Types.Uid.Tbl.find module_declarations uid with
|
||||
| mark -> mark ()
|
||||
| exception Not_found -> ()
|
||||
|
||||
let mark_modtype_used _name _mtd = ()
|
||||
let mark_modtype_used _uid = ()
|
||||
|
||||
let mark_value_used name vd =
|
||||
match Hashtbl.find value_declarations (name, vd.val_loc) with
|
||||
let mark_value_used uid =
|
||||
match Types.Uid.Tbl.find value_declarations uid with
|
||||
| mark -> mark ()
|
||||
| exception Not_found -> ()
|
||||
|
||||
let mark_type_used name td =
|
||||
match Hashtbl.find type_declarations (name, td.type_loc) with
|
||||
let mark_type_used uid =
|
||||
match Types.Uid.Tbl.find type_declarations uid with
|
||||
| mark -> mark ()
|
||||
| exception Not_found -> ()
|
||||
|
||||
let mark_type_path_used env path =
|
||||
match find_type path env with
|
||||
| decl -> mark_type_used (Path.last path) decl
|
||||
| decl -> mark_type_used decl.type_uid
|
||||
| exception Not_found -> ()
|
||||
|
||||
let mark_constructor_used usage ty_name cd =
|
||||
let name = Ident.name cd.cd_id in
|
||||
let loc = cd.cd_loc in
|
||||
let k = (ty_name, loc, name) in
|
||||
match Hashtbl.find used_constructors k with
|
||||
let mark_constructor_used usage cd =
|
||||
match Types.Uid.Tbl.find used_constructors cd.cd_uid with
|
||||
| mark -> mark usage
|
||||
| exception Not_found -> ()
|
||||
|
||||
let mark_extension_used usage name ext =
|
||||
let ty_name = Path.last ext.ext_type_path in
|
||||
let loc = ext.ext_loc in
|
||||
let k = (ty_name, loc, name) in
|
||||
match Hashtbl.find used_constructors k with
|
||||
let mark_extension_used usage ext =
|
||||
match Types.Uid.Tbl.find used_constructors ext.ext_uid with
|
||||
| mark -> mark usage
|
||||
| exception Not_found -> ()
|
||||
|
||||
|
@ -2140,9 +2156,7 @@ let mark_constructor_description_used usage env cstr =
|
|||
| _ -> assert false
|
||||
in
|
||||
mark_type_path_used env ty_path;
|
||||
let ty_name = Path.last ty_path in
|
||||
let k = (ty_name, cstr.cstr_loc, cstr.cstr_name) in
|
||||
match Hashtbl.find used_constructors k with
|
||||
match Types.Uid.Tbl.find used_constructors cstr.cstr_uid with
|
||||
| mark -> mark usage
|
||||
| exception Not_found -> ()
|
||||
|
||||
|
@ -2154,37 +2168,26 @@ let mark_label_description_used () env lbl =
|
|||
in
|
||||
mark_type_path_used env ty_path
|
||||
|
||||
let mark_class_used name cty =
|
||||
match Hashtbl.find type_declarations (name, cty.cty_loc) with
|
||||
let mark_class_used uid =
|
||||
match Types.Uid.Tbl.find type_declarations uid with
|
||||
| mark -> mark ()
|
||||
| exception Not_found -> ()
|
||||
|
||||
let mark_cltype_used name clty =
|
||||
match Hashtbl.find type_declarations (name, clty.clty_loc) with
|
||||
let mark_cltype_used uid =
|
||||
match Types.Uid.Tbl.find type_declarations uid with
|
||||
| mark -> mark ()
|
||||
| exception Not_found -> ()
|
||||
|
||||
let set_value_used_callback name vd callback =
|
||||
let key = (name, vd.val_loc) in
|
||||
try
|
||||
let old = Hashtbl.find value_declarations key in
|
||||
Hashtbl.replace value_declarations key (fun () -> old (); callback ())
|
||||
(* this is to support cases like:
|
||||
let x = let x = 1 in x in x
|
||||
where the two declarations have the same location
|
||||
(e.g. resulting from Camlp4 expansion of grammar entries) *)
|
||||
with Not_found ->
|
||||
Hashtbl.add value_declarations key callback
|
||||
let set_value_used_callback vd callback =
|
||||
Types.Uid.Tbl.add value_declarations vd.val_uid callback
|
||||
|
||||
let set_type_used_callback name td callback =
|
||||
let loc = td.type_loc in
|
||||
if loc.Location.loc_ghost then ()
|
||||
else let key = (name, loc) in
|
||||
let old =
|
||||
try Hashtbl.find type_declarations key
|
||||
with Not_found -> ignore
|
||||
in
|
||||
Hashtbl.replace type_declarations key (fun () -> callback old)
|
||||
let set_type_used_callback td callback =
|
||||
if Uid.for_actual_declaration td.type_uid then
|
||||
let old =
|
||||
try Types.Uid.Tbl.find type_declarations td.type_uid
|
||||
with Not_found -> ignore
|
||||
in
|
||||
Types.Uid.Tbl.replace type_declarations td.type_uid (fun () -> callback old)
|
||||
|
||||
(* Lookup by name *)
|
||||
|
||||
|
@ -2217,10 +2220,10 @@ let report_value_unbound ~errors ~loc env reason lid =
|
|||
in
|
||||
may_lookup_error errors loc env (Unbound_value(lid, hint))
|
||||
|
||||
let use_module ~use ~loc name path mda =
|
||||
let use_module ~use ~loc path mda =
|
||||
if use then begin
|
||||
let comps = mda.mda_components in
|
||||
mark_module_used name comps.loc;
|
||||
mark_module_used comps.uid;
|
||||
Misc.Stdlib.String.Map.iter
|
||||
(fun kind message ->
|
||||
let message = if message = "" then "" else "\n" ^ message in
|
||||
|
@ -2230,40 +2233,40 @@ let use_module ~use ~loc name path mda =
|
|||
comps.alerts
|
||||
end
|
||||
|
||||
let use_value ~use ~loc name path vda =
|
||||
let use_value ~use ~loc path vda =
|
||||
if use then begin
|
||||
let desc = vda.vda_description in
|
||||
mark_value_used name desc;
|
||||
mark_value_used desc.val_uid;
|
||||
Builtin_attributes.check_alerts loc desc.val_attributes
|
||||
(Path.name path)
|
||||
end
|
||||
|
||||
let use_type ~use ~loc name path tda =
|
||||
let use_type ~use ~loc path tda =
|
||||
if use then begin
|
||||
let decl = tda.tda_declaration in
|
||||
mark_type_used name decl;
|
||||
mark_type_used decl.type_uid;
|
||||
Builtin_attributes.check_alerts loc decl.type_attributes
|
||||
(Path.name path)
|
||||
end
|
||||
|
||||
let use_modtype ~use ~loc name path desc =
|
||||
let use_modtype ~use ~loc path desc =
|
||||
if use then begin
|
||||
mark_modtype_used name desc;
|
||||
mark_modtype_used desc.mtd_uid;
|
||||
Builtin_attributes.check_alerts loc desc.mtd_attributes
|
||||
(Path.name path)
|
||||
end
|
||||
|
||||
let use_class ~use ~loc name path clda =
|
||||
let use_class ~use ~loc path clda =
|
||||
if use then begin
|
||||
let desc = clda.clda_declaration in
|
||||
mark_class_used name desc;
|
||||
mark_class_used desc.cty_uid;
|
||||
Builtin_attributes.check_alerts loc desc.cty_attributes
|
||||
(Path.name path)
|
||||
end
|
||||
|
||||
let use_cltype ~use ~loc name path desc =
|
||||
let use_cltype ~use ~loc path desc =
|
||||
if use then begin
|
||||
mark_cltype_used name desc;
|
||||
mark_cltype_used desc.clty_uid;
|
||||
Builtin_attributes.check_alerts loc desc.clty_attributes
|
||||
(Path.name path)
|
||||
end
|
||||
|
@ -2296,7 +2299,7 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
|
|||
in
|
||||
match data with
|
||||
| Mod_local mda -> begin
|
||||
use_module ~use ~loc s path mda;
|
||||
use_module ~use ~loc path mda;
|
||||
match load with
|
||||
| Load -> path, (mda : a)
|
||||
| Don't_load -> path, (() : a)
|
||||
|
@ -2311,7 +2314,7 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
|
|||
| Load -> begin
|
||||
match find_pers_mod s with
|
||||
| mda ->
|
||||
use_module ~use ~loc s path mda;
|
||||
use_module ~use ~loc path mda;
|
||||
path, (mda : a)
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_module (Lident s))
|
||||
|
@ -2321,7 +2324,7 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
|
|||
let lookup_ident_value ~errors ~use ~loc name env =
|
||||
match IdTbl.find_name wrap_value ~mark:use name env.values with
|
||||
| (path, Val_bound vda) ->
|
||||
use_value ~use ~loc name path vda;
|
||||
use_value ~use ~loc path vda;
|
||||
path, vda.vda_description
|
||||
| (_, Val_unbound reason) ->
|
||||
report_value_unbound ~errors ~loc env reason (Lident name)
|
||||
|
@ -2331,7 +2334,7 @@ let lookup_ident_value ~errors ~use ~loc name env =
|
|||
let lookup_ident_type ~errors ~use ~loc s env =
|
||||
match IdTbl.find_name wrap_identity ~mark:use s env.types with
|
||||
| (path, data) as res ->
|
||||
use_type ~use ~loc s path data;
|
||||
use_type ~use ~loc path data;
|
||||
res
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_type (Lident s))
|
||||
|
@ -2339,7 +2342,7 @@ let lookup_ident_type ~errors ~use ~loc s env =
|
|||
let lookup_ident_modtype ~errors ~use ~loc s env =
|
||||
match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with
|
||||
| (path, data) as res ->
|
||||
use_modtype ~use ~loc s path data;
|
||||
use_modtype ~use ~loc path data;
|
||||
res
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_modtype (Lident s))
|
||||
|
@ -2347,7 +2350,7 @@ let lookup_ident_modtype ~errors ~use ~loc s env =
|
|||
let lookup_ident_class ~errors ~use ~loc s env =
|
||||
match IdTbl.find_name wrap_identity ~mark:use s env.classes with
|
||||
| (path, clda) ->
|
||||
use_class ~use ~loc s path clda;
|
||||
use_class ~use ~loc path clda;
|
||||
path, clda.clda_declaration
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_class (Lident s))
|
||||
|
@ -2355,7 +2358,7 @@ let lookup_ident_class ~errors ~use ~loc s env =
|
|||
let lookup_ident_cltype ~errors ~use ~loc s env =
|
||||
match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with
|
||||
| (path, data) as res ->
|
||||
use_cltype ~use ~loc s path data;
|
||||
use_cltype ~use ~loc path data;
|
||||
res
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_cltype (Lident s))
|
||||
|
@ -2464,7 +2467,7 @@ and lookup_dot_module ~errors ~use ~loc l s env =
|
|||
match NameMap.find s comps.comp_modules with
|
||||
| mda ->
|
||||
let path = Pdot(p, s) in
|
||||
use_module ~use ~loc s path mda;
|
||||
use_module ~use ~loc path mda;
|
||||
(path, mda)
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_module (Ldot(l, s)))
|
||||
|
@ -2476,7 +2479,7 @@ let lookup_dot_value ~errors ~use ~loc l s env =
|
|||
match NameMap.find s comps.comp_values with
|
||||
| vda ->
|
||||
let path = Pdot(path, s) in
|
||||
use_value ~use ~loc s path vda;
|
||||
use_value ~use ~loc path vda;
|
||||
(path, vda.vda_description)
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_value (Ldot(l, s), No_hint))
|
||||
|
@ -2486,7 +2489,7 @@ let lookup_dot_type ~errors ~use ~loc l s env =
|
|||
match NameMap.find s comps.comp_types with
|
||||
| tda ->
|
||||
let path = Pdot(p, s) in
|
||||
use_type ~use ~loc s path tda;
|
||||
use_type ~use ~loc path tda;
|
||||
(path, tda)
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_type (Ldot(l, s)))
|
||||
|
@ -2496,7 +2499,7 @@ let lookup_dot_modtype ~errors ~use ~loc l s env =
|
|||
match NameMap.find s comps.comp_modtypes with
|
||||
| desc ->
|
||||
let path = Pdot(p, s) in
|
||||
use_modtype ~use ~loc s path desc;
|
||||
use_modtype ~use ~loc path desc;
|
||||
(path, desc)
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s)))
|
||||
|
@ -2506,7 +2509,7 @@ let lookup_dot_class ~errors ~use ~loc l s env =
|
|||
match NameMap.find s comps.comp_classes with
|
||||
| clda ->
|
||||
let path = Pdot(p, s) in
|
||||
use_class ~use ~loc s path clda;
|
||||
use_class ~use ~loc path clda;
|
||||
(path, clda.clda_declaration)
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_class (Ldot(l, s)))
|
||||
|
@ -2516,7 +2519,7 @@ let lookup_dot_cltype ~errors ~use ~loc l s env =
|
|||
match NameMap.find s comps.comp_cltypes with
|
||||
| desc ->
|
||||
let path = Pdot(p, s) in
|
||||
use_cltype ~use ~loc s path desc;
|
||||
use_cltype ~use ~loc path desc;
|
||||
(path, desc)
|
||||
| exception Not_found ->
|
||||
may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s)))
|
||||
|
@ -2735,7 +2738,7 @@ let lookup_instance_variable ?(use=true) ~loc name env =
|
|||
let desc = vda.vda_description in
|
||||
match desc.val_kind with
|
||||
| Val_ivar(mut, cl_num) ->
|
||||
use_value ~use ~loc name path vda;
|
||||
use_value ~use ~loc path vda;
|
||||
path, mut, cl_num, desc.val_type
|
||||
| _ ->
|
||||
lookup_error loc env (Not_an_instance_variable name)
|
||||
|
|
|
@ -129,15 +129,15 @@ val add_required_global: Ident.t -> unit
|
|||
val has_local_constraints: t -> bool
|
||||
|
||||
(* Mark definitions as used *)
|
||||
val mark_value_used: string -> value_description -> unit
|
||||
val mark_module_used: string -> Location.t -> unit
|
||||
val mark_type_used: string -> type_declaration -> unit
|
||||
val mark_value_used: Uid.t -> unit
|
||||
val mark_module_used: Uid.t -> unit
|
||||
val mark_type_used: Uid.t -> unit
|
||||
|
||||
type constructor_usage = Positive | Pattern | Privatize
|
||||
val mark_constructor_used:
|
||||
constructor_usage -> string -> constructor_declaration -> unit
|
||||
constructor_usage -> constructor_declaration -> unit
|
||||
val mark_extension_used:
|
||||
constructor_usage -> string -> extension_constructor -> unit
|
||||
constructor_usage -> extension_constructor -> unit
|
||||
|
||||
(* Lookup by long identifiers *)
|
||||
|
||||
|
@ -405,9 +405,9 @@ val in_signature: bool -> t -> t
|
|||
val is_in_signature: t -> bool
|
||||
|
||||
val set_value_used_callback:
|
||||
string -> value_description -> (unit -> unit) -> unit
|
||||
value_description -> (unit -> unit) -> unit
|
||||
val set_type_used_callback:
|
||||
string -> type_declaration -> ((unit -> unit) -> unit) -> unit
|
||||
type_declaration -> ((unit -> unit) -> unit) -> unit
|
||||
|
||||
(* Forward declaration to break mutual recursion with Includemod. *)
|
||||
val check_functor_application:
|
||||
|
|
|
@ -419,18 +419,15 @@ let type_declarations ?(equality = false) ~loc env ~mark name
|
|||
(_, Type_abstract) -> None
|
||||
| (Type_variant cstrs1, Type_variant cstrs2) ->
|
||||
if mark then begin
|
||||
let mark usage name cstrs =
|
||||
List.iter
|
||||
(fun cstr ->
|
||||
Env.mark_constructor_used usage name cstr)
|
||||
cstrs
|
||||
let mark usage cstrs =
|
||||
List.iter (Env.mark_constructor_used usage) cstrs
|
||||
in
|
||||
let usage =
|
||||
if decl2.type_private = Public then Env.Positive
|
||||
else Env.Privatize
|
||||
in
|
||||
mark usage name cstrs1;
|
||||
if equality then mark Env.Positive (Path.name path) cstrs2
|
||||
mark usage cstrs1;
|
||||
if equality then mark Env.Positive cstrs2
|
||||
end;
|
||||
Option.map
|
||||
(fun var_err -> Variant_mismatch var_err)
|
||||
|
@ -487,7 +484,7 @@ let extension_constructors ~loc env ~mark id ext1 ext2 =
|
|||
if ext2.ext_private = Public then Env.Positive
|
||||
else Env.Privatize
|
||||
in
|
||||
Env.mark_extension_used usage (Ident.name id) ext1
|
||||
Env.mark_extension_used usage ext1
|
||||
end;
|
||||
let ty1 =
|
||||
Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
|
||||
|
|
|
@ -75,7 +75,7 @@ let mark_positive = function
|
|||
let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 =
|
||||
Cmt_format.record_value_dependency vd1 vd2;
|
||||
if mark_positive mark then
|
||||
Env.mark_value_used (Ident.name id) vd1;
|
||||
Env.mark_value_used vd1.val_uid;
|
||||
let vd2 = Subst.value_description subst vd2 in
|
||||
try
|
||||
Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2
|
||||
|
@ -87,7 +87,7 @@ let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 =
|
|||
let type_declarations ~loc env ~mark ?old_env:_ cxt subst id decl1 decl2 =
|
||||
let mark = mark_positive mark in
|
||||
if mark then
|
||||
Env.mark_type_used (Ident.name id) decl1;
|
||||
Env.mark_type_used decl1.type_uid;
|
||||
let decl2 = Subst.type_declaration subst decl2 in
|
||||
match
|
||||
Includecore.type_declarations ~loc env ~mark
|
||||
|
@ -515,7 +515,7 @@ and module_declarations ~loc env ~mark cxt subst id1 md1 md2 =
|
|||
(Ident.name id1);
|
||||
let p1 = Path.Pident id1 in
|
||||
if mark_positive mark then
|
||||
Env.mark_module_used (Ident.name id1) md1.md_loc;
|
||||
Env.mark_module_used md1.md_uid;
|
||||
strengthened_modtypes ~loc ~aliasable:true env ~mark (Module id1::cxt) subst
|
||||
md1.md_type p1 md2.md_type
|
||||
|
||||
|
|
|
@ -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
159
typing/predef.ml
|
@ -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 =
|
||||
|
|
|
@ -1596,6 +1596,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
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
@ -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 ();
|
||||
|
|
|
@ -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
|
||||
|
@ -1892,7 +1893,11 @@ let type_pattern_list
|
|||
in
|
||||
let patl = List.map2 type_pat spatl expected_tys in
|
||||
let pvs = get_ref pattern_variables in
|
||||
let unpacks = get_ref module_variables in
|
||||
let unpacks =
|
||||
List.map (fun (name, loc) ->
|
||||
name, loc, Uid.mk ~current_unit:(Env.get_unit_name ())
|
||||
) (get_ref module_variables)
|
||||
in
|
||||
let new_env = add_pattern_variables !new_env pvs in
|
||||
(patl, new_env, get_ref pattern_force, pvs, unpacks)
|
||||
|
||||
|
@ -1907,23 +1912,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 +1967,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,
|
||||
|
@ -2325,20 +2346,6 @@ let create_package_type loc env (p, l) =
|
|||
in
|
||||
(s, fields, ty)
|
||||
|
||||
let wrap_unpacks sexp unpacks =
|
||||
let open Ast_helper in
|
||||
List.fold_left
|
||||
(fun sexp (name, loc) ->
|
||||
Exp.letmodule ~loc:{ sexp.pexp_loc with loc_ghost = true }
|
||||
~attrs:[Attr.mk (mknoloc "#modulepat") (PStr [])]
|
||||
{ name with txt = Some name.txt }
|
||||
(Mod.unpack ~loc
|
||||
(Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
|
||||
name.loc)))
|
||||
sexp
|
||||
)
|
||||
sexp unpacks
|
||||
|
||||
(* Helpers for type_cases *)
|
||||
|
||||
let contains_variant_either ty =
|
||||
|
@ -2600,9 +2607,7 @@ and type_expect_
|
|||
in
|
||||
let (pat_exp_list, new_env, unpacks) =
|
||||
type_let existential_context env rec_flag spat_sexp_list scp true in
|
||||
let body =
|
||||
type_expect new_env (wrap_unpacks sbody unpacks)
|
||||
ty_expected_explained in
|
||||
let body = type_unpacks new_env unpacks sbody ty_expected_explained in
|
||||
let () =
|
||||
if rec_flag = Recursive then
|
||||
check_recursive_bindings env pat_exp_list
|
||||
|
@ -2997,9 +3002,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 +3163,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 +3330,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 +3471,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 +4110,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=[];
|
||||
|
@ -4443,6 +4458,59 @@ and type_statement ?explanation env sexp =
|
|||
exp
|
||||
end
|
||||
|
||||
and type_unpacks ?in_function env unpacks sbody expected_ty =
|
||||
let ty = newvar() in
|
||||
(* remember original level *)
|
||||
let extended_env, tunpacks =
|
||||
List.fold_left (fun (env, unpacks) (name, loc, uid) ->
|
||||
begin_def ();
|
||||
let context = Typetexp.narrow () in
|
||||
let modl =
|
||||
!type_module env
|
||||
Ast_helper.(
|
||||
Mod.unpack ~loc
|
||||
(Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt)
|
||||
name.loc)))
|
||||
in
|
||||
Mtype.lower_nongen ty.level modl.mod_type;
|
||||
let pres =
|
||||
match modl.mod_type with
|
||||
| Mty_alias _ -> Mp_absent
|
||||
| _ -> Mp_present
|
||||
in
|
||||
let scope = create_scope () in
|
||||
let md =
|
||||
{ md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
|
||||
md_uid = uid; }
|
||||
in
|
||||
let (id, env) =
|
||||
Env.enter_module_declaration ~scope name.txt pres md env
|
||||
in
|
||||
Typetexp.widen context;
|
||||
env, (id, name, pres, modl) :: unpacks
|
||||
) (env, []) unpacks
|
||||
in
|
||||
(* ideally, we should catch Expr_type_clash errors
|
||||
in type_expect triggered by escaping identifiers from the local module
|
||||
and refine them into Scoping_let_module errors
|
||||
*)
|
||||
let body = type_expect ?in_function extended_env sbody expected_ty in
|
||||
let exp_loc = { body.exp_loc with loc_ghost = true } in
|
||||
let exp_attributes = [Ast_helper.Attr.mk (mknoloc "#modulepat") (PStr [])] in
|
||||
List.fold_left (fun body (id, name, pres, modl) ->
|
||||
(* go back to parent level *)
|
||||
end_def ();
|
||||
Ctype.unify_var extended_env ty body.exp_type;
|
||||
re {
|
||||
exp_desc = Texp_letmodule(Some id, { name with txt = Some name.txt },
|
||||
pres, modl, body);
|
||||
exp_loc;
|
||||
exp_attributes;
|
||||
exp_extra = [];
|
||||
exp_type = ty;
|
||||
exp_env = env }
|
||||
) body tunpacks
|
||||
|
||||
(* Typing of match cases *)
|
||||
and type_cases
|
||||
: type k . k pattern_category ->
|
||||
|
@ -4572,7 +4640,11 @@ and type_cases
|
|||
~check:(fun s -> Warnings.Unused_var_strict s)
|
||||
~check_as:(fun s -> Warnings.Unused_var s)
|
||||
in
|
||||
let sexp = wrap_unpacks pc_rhs unpacks in
|
||||
let unpacks =
|
||||
List.map (fun (name, loc) ->
|
||||
name, loc, Uid.mk ~current_unit:(Env.get_unit_name ())
|
||||
) unpacks
|
||||
in
|
||||
let ty_res' =
|
||||
if !Clflags.principal then begin
|
||||
begin_def ();
|
||||
|
@ -4594,11 +4666,12 @@ and type_cases
|
|||
| None -> None
|
||||
| Some scond ->
|
||||
Some
|
||||
(type_expect ext_env (wrap_unpacks scond unpacks)
|
||||
(type_unpacks ext_env unpacks scond
|
||||
(mk_expected ~explanation:When_guard Predef.type_bool))
|
||||
in
|
||||
let exp =
|
||||
type_expect ?in_function ext_env sexp (mk_expected ty_res') in
|
||||
type_unpacks ?in_function ext_env unpacks pc_rhs (mk_expected ty_res')
|
||||
in
|
||||
{
|
||||
c_lhs = pat;
|
||||
c_guard = guard;
|
||||
|
@ -4804,15 +4877,13 @@ and type_let
|
|||
((if !some_used then check_strict else check) name)
|
||||
);
|
||||
Env.set_value_used_callback
|
||||
name vd
|
||||
vd
|
||||
(fun () ->
|
||||
match !current_slot with
|
||||
| Some slot ->
|
||||
slot := (name, vd) :: !slot; rec_needed := true
|
||||
slot := vd.val_uid :: !slot; rec_needed := true
|
||||
| None ->
|
||||
List.iter
|
||||
(fun (name, vd) -> Env.mark_value_used name vd)
|
||||
(get_ref slot);
|
||||
List.iter Env.mark_value_used (get_ref slot);
|
||||
used := true;
|
||||
some_used := true
|
||||
)
|
||||
|
@ -4826,8 +4897,6 @@ and type_let
|
|||
let exp_list =
|
||||
List.map2
|
||||
(fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) ->
|
||||
let sexp =
|
||||
if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
|
||||
if is_recursive then current_slot := slot;
|
||||
match pat.pat_type.desc with
|
||||
| Tpoly (ty, tl) ->
|
||||
|
@ -4838,14 +4907,21 @@ and type_let
|
|||
generalize_structure ty'
|
||||
end;
|
||||
let exp =
|
||||
Builtin_attributes.warning_scope pvb_attributes
|
||||
(fun () -> type_expect exp_env sexp (mk_expected ty'))
|
||||
Builtin_attributes.warning_scope pvb_attributes (fun () ->
|
||||
if rec_flag = Recursive then
|
||||
type_unpacks exp_env unpacks sexp (mk_expected ty')
|
||||
else
|
||||
type_expect exp_env sexp (mk_expected ty')
|
||||
)
|
||||
in
|
||||
exp, Some vars
|
||||
| _ ->
|
||||
let exp =
|
||||
Builtin_attributes.warning_scope pvb_attributes
|
||||
(fun () -> type_expect exp_env sexp (mk_expected pat.pat_type))
|
||||
Builtin_attributes.warning_scope pvb_attributes (fun () ->
|
||||
if rec_flag = Recursive then
|
||||
type_unpacks exp_env unpacks sexp (mk_expected pat.pat_type)
|
||||
else
|
||||
type_expect exp_env sexp (mk_expected pat.pat_type))
|
||||
in
|
||||
exp, None)
|
||||
spat_sexp_list pat_slot_list in
|
||||
|
|
|
@ -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,38 +828,38 @@ 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
|
||||
to detect unused declarations in a set of recursive definitions. *)
|
||||
let slot = ref [] in
|
||||
let td = Env.find_type (Path.Pident id) temp_env in
|
||||
let name = Ident.name id in
|
||||
Env.set_type_used_callback
|
||||
name td
|
||||
td
|
||||
(fun old_callback ->
|
||||
match !current_slot with
|
||||
| Some slot -> slot := (name, td) :: !slot
|
||||
| Some slot -> slot := td.type_uid :: !slot
|
||||
| None ->
|
||||
List.iter (fun (name, d) -> Env.mark_type_used name d)
|
||||
(get_ref slot);
|
||||
List.iter Env.mark_type_used (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 +868,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 +881,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 +1049,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 +1315,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 +1345,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
|
||||
|
@ -1362,7 +1372,7 @@ let transl_value_decl env loc valdecl =
|
|||
(* Translate a "with" constraint -- much simplified version of
|
||||
transl_type_decl. *)
|
||||
let transl_with_constraint env id row_path orig_decl sdecl =
|
||||
Env.mark_type_used (Ident.name id) orig_decl;
|
||||
Env.mark_type_used orig_decl.type_uid;
|
||||
reset_type_variables();
|
||||
Ctype.begin_def();
|
||||
let tparams = make_params env sdecl.ptype_params in
|
||||
|
@ -1420,6 +1430,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 +1484,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;
|
||||
|
|
|
@ -22,7 +22,6 @@
|
|||
*)
|
||||
|
||||
open Asttypes
|
||||
open Types
|
||||
|
||||
(* Value expressions for the core language *)
|
||||
|
||||
|
@ -49,7 +48,7 @@ and 'a pattern_data =
|
|||
{ pat_desc: 'a;
|
||||
pat_loc: Location.t;
|
||||
pat_extra : (pat_extra * Location.t * attributes) list;
|
||||
pat_type: type_expr;
|
||||
pat_type: Types.type_expr;
|
||||
pat_env: Env.t;
|
||||
pat_attributes: attributes;
|
||||
}
|
||||
|
@ -89,14 +88,15 @@ and 'k pattern_desc =
|
|||
Invariant: n >= 2
|
||||
*)
|
||||
| Tpat_construct :
|
||||
Longident.t loc * constructor_description * value general_pattern list ->
|
||||
Longident.t loc * Types.constructor_description *
|
||||
value general_pattern list ->
|
||||
value pattern_desc
|
||||
(** C []
|
||||
C P [P]
|
||||
C (P1, ..., Pn) [P1; ...; Pn]
|
||||
*)
|
||||
| Tpat_variant :
|
||||
label * value general_pattern option * row_desc ref ->
|
||||
label * value general_pattern option * Types.row_desc ref ->
|
||||
value pattern_desc
|
||||
(** `A (None)
|
||||
`A P (Some P)
|
||||
|
@ -104,7 +104,7 @@ and 'k pattern_desc =
|
|||
See {!Types.row_desc} for an explanation of the last parameter.
|
||||
*)
|
||||
| Tpat_record :
|
||||
(Longident.t loc * label_description * value general_pattern) list *
|
||||
(Longident.t loc * Types.label_description * value general_pattern) list *
|
||||
closed_flag ->
|
||||
value pattern_desc
|
||||
(** { l1=P1; ...; ln=Pn } (flag = Closed)
|
||||
|
@ -135,7 +135,7 @@ and 'k pattern_desc =
|
|||
(** exception P *)
|
||||
(* generic constructions *)
|
||||
| Tpat_or :
|
||||
'k general_pattern * 'k general_pattern * row_desc option ->
|
||||
'k general_pattern * 'k general_pattern * Types.row_desc option ->
|
||||
'k pattern_desc
|
||||
(** P1 | P2
|
||||
|
||||
|
@ -149,7 +149,7 @@ and expression =
|
|||
{ exp_desc: expression_desc;
|
||||
exp_loc: Location.t;
|
||||
exp_extra: (exp_extra * Location.t * attributes) list;
|
||||
exp_type: type_expr;
|
||||
exp_type: Types.type_expr;
|
||||
exp_env: Env.t;
|
||||
exp_attributes: attributes;
|
||||
}
|
||||
|
@ -219,7 +219,7 @@ and expression_desc =
|
|||
| Texp_tuple of expression list
|
||||
(** (E1, ..., EN) *)
|
||||
| Texp_construct of
|
||||
Longident.t loc * constructor_description * expression list
|
||||
Longident.t loc * Types.constructor_description * expression list
|
||||
(** C []
|
||||
C E [E]
|
||||
C (E1, ..., En) [E1;...;En]
|
||||
|
@ -241,9 +241,9 @@ and expression_desc =
|
|||
{ fields = [| l1, Kept t1; l2 Override P2 |]; representation;
|
||||
extended_expression = Some E0 }
|
||||
*)
|
||||
| Texp_field of expression * Longident.t loc * label_description
|
||||
| Texp_field of expression * Longident.t loc * Types.label_description
|
||||
| Texp_setfield of
|
||||
expression * Longident.t loc * label_description * expression
|
||||
expression * Longident.t loc * Types.label_description * expression
|
||||
| Texp_array of expression list
|
||||
| Texp_ifthenelse of expression * expression * expression option
|
||||
| Texp_sequence of expression * expression
|
||||
|
@ -324,7 +324,7 @@ and class_expr_desc =
|
|||
| Tcl_let of rec_flag * value_binding list *
|
||||
(Ident.t * expression) list * class_expr
|
||||
| Tcl_constraint of
|
||||
class_expr * class_type option * string list * string list * Concr.t
|
||||
class_expr * class_type option * string list * string list * Types.Concr.t
|
||||
(* Visible instance variables, methods and concrete methods *)
|
||||
| Tcl_open of open_description * class_expr
|
||||
|
||||
|
@ -333,7 +333,7 @@ and class_structure =
|
|||
cstr_self: pattern;
|
||||
cstr_fields: class_field list;
|
||||
cstr_type: Types.class_signature;
|
||||
cstr_meths: Ident.t Meths.t;
|
||||
cstr_meths: Ident.t Types.Meths.t;
|
||||
}
|
||||
|
||||
and class_field =
|
||||
|
@ -423,7 +423,7 @@ and module_binding =
|
|||
{
|
||||
mb_id: Ident.t option;
|
||||
mb_name: string option loc;
|
||||
mb_presence: module_presence;
|
||||
mb_presence: Types.module_presence;
|
||||
mb_expr: module_expr;
|
||||
mb_attributes: attributes;
|
||||
mb_loc: Location.t;
|
||||
|
@ -464,7 +464,7 @@ and module_type_desc =
|
|||
and primitive_coercion =
|
||||
{
|
||||
pc_desc: Primitive.description;
|
||||
pc_type: type_expr;
|
||||
pc_type: Types.type_expr;
|
||||
pc_env: Env.t;
|
||||
pc_loc : Location.t;
|
||||
}
|
||||
|
@ -500,7 +500,7 @@ and module_declaration =
|
|||
{
|
||||
md_id: Ident.t option;
|
||||
md_name: string option loc;
|
||||
md_presence: module_presence;
|
||||
md_presence: Types.module_presence;
|
||||
md_type: module_type;
|
||||
md_attributes: attributes;
|
||||
md_loc: Location.t;
|
||||
|
@ -561,7 +561,7 @@ and with_constraint =
|
|||
and core_type =
|
||||
{ mutable ctyp_desc : core_type_desc;
|
||||
(** mutable because of [Typeclass.declare_method] *)
|
||||
mutable ctyp_type : type_expr;
|
||||
mutable ctyp_type : Types.type_expr;
|
||||
(** mutable because of [Typeclass.declare_method] *)
|
||||
ctyp_env : Env.t; (* BINANNOT ADDED *)
|
||||
ctyp_loc : Location.t;
|
||||
|
@ -787,7 +787,7 @@ val map_general_pattern:
|
|||
|
||||
val let_bound_idents: value_binding list -> Ident.t list
|
||||
val let_bound_idents_full:
|
||||
value_binding list -> (Ident.t * string loc * type_expr) list
|
||||
value_binding list -> (Ident.t * string loc * Types.type_expr) list
|
||||
|
||||
(** Alpha conversion of patterns *)
|
||||
val alpha_pat:
|
||||
|
@ -798,7 +798,7 @@ val mkloc: 'a -> Location.t -> 'a Asttypes.loc
|
|||
|
||||
val pat_bound_idents: 'k general_pattern -> Ident.t list
|
||||
val pat_bound_idents_full:
|
||||
'k general_pattern -> (Ident.t * string loc * type_expr) list
|
||||
'k general_pattern -> (Ident.t * string loc * Types.type_expr) list
|
||||
|
||||
(** Splits an or pattern into its value (left) and exception (right) parts. *)
|
||||
val split_pattern:
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -79,6 +79,58 @@ 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
|
||||
|
||||
include Identifiable.Make(struct
|
||||
type nonrec t = t
|
||||
|
||||
let equal (x : t) y = x = y
|
||||
let compare (x : t) y = compare x y
|
||||
let hash (x : t) = Hashtbl.hash x
|
||||
|
||||
let print fmt = function
|
||||
| Internal -> Format.pp_print_string fmt "<internal>"
|
||||
| Predef name -> Format.fprintf fmt "<predef:%s>" name
|
||||
| Compilation_unit s -> Format.pp_print_string fmt s
|
||||
| Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id
|
||||
|
||||
let output oc t =
|
||||
let fmt = Format.formatter_of_out_channel oc in
|
||||
print fmt t
|
||||
end)
|
||||
|
||||
let id = ref (-1)
|
||||
|
||||
let reinit () = id := (-1)
|
||||
|
||||
let mk ~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
|
||||
|
||||
let for_actual_declaration = function
|
||||
| Item _ -> true
|
||||
| _ -> false
|
||||
end
|
||||
|
||||
(* Maps of methods and instance variables *)
|
||||
|
||||
module Meths = Misc.Stdlib.String.Map
|
||||
|
@ -91,7 +143,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 +231,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 +254,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 +264,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 +283,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 +322,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 +332,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 +372,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 +380,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 +412,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 +446,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
|
||||
|
|
|
@ -240,6 +240,23 @@ module TypeOps : sig
|
|||
val hash : t -> int
|
||||
end
|
||||
|
||||
(* *)
|
||||
|
||||
module Uid : sig
|
||||
type t
|
||||
|
||||
val reinit : unit -> unit
|
||||
|
||||
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
|
||||
|
||||
val for_actual_declaration : t -> bool
|
||||
|
||||
include Identifiable.S with type t := t
|
||||
end
|
||||
|
||||
(* Maps of methods and instance variables *)
|
||||
|
||||
module Meths : Map.S with type key = string
|
||||
|
@ -252,7 +269,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 +352,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 +375,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 +385,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 +407,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 +447,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 +457,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 +497,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 +505,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 +537,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 +565,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.
|
||||
|
|
Loading…
Reference in New Issue