diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 830c0181b..1c121d35a 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -99,14 +99,14 @@ let constructor_descrs ty_path decl cstrs = | _ -> (Cstr_block idx_nonconst, describe_constructors idx_const (idx_nonconst+1) rem) in - let name = Ident.name cd_id in + let cstr_name = Ident.name cd_id in let existentials, cstr_args, cstr_inlined = constructor_args cd_args cd_res - (Path.Pdot (ty_path, name, Path.nopos)) + (Path.Pdot (ty_path, cstr_name, Path.nopos)) (Record_inlined idx_nonconst) in let cstr = - { cstr_name = Ident.name cd_id; + { cstr_name; cstr_res = ty_res; cstr_existentials = existentials; cstr_args; diff --git a/typing/includecore.ml b/typing/includecore.ml index 2f913f8a7..a4da854cf 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -120,7 +120,7 @@ type type_mismatch = | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t - | Record_representation of record_representation * record_representation + | Record_representation of bool let report_type_mismatch0 first second decl ppf err = let pr fmt = Format.fprintf ppf fmt in @@ -143,15 +143,10 @@ let report_type_mismatch0 first second decl ppf err = | Field_missing (b, s) -> pr "The field %s is only present in %s %s" (Ident.name s) (if b then second else first) decl - | Record_representation (r1, r2) -> - let repr = function - | Record_regular -> "regular" - | Record_inlined _ | Record_extension -> "inlined record" - | Record_float -> "unboxed float" - in - pr "Their internal representations differ:@ %s vs %s" - (repr r1) - (repr r2) + | Record_representation b -> + pr "Their internal representations differ:@ %s %s %s" + (if b then second else first) decl + "uses unboxed float representation" let report_type_mismatch first second decl ppf = List.iter @@ -209,14 +204,6 @@ and compare_records env params1 params2 n labels1 labels2 = then compare_records env params1 params2 (n+1) rem1 rem2 else [Field_type lab1] -let record_representations r1 r2 = - match r1, r2 with - | Record_regular, Record_regular -> true - | Record_inlined i, Record_inlined j -> i = j - | Record_float, Record_float -> true - | Record_extension, Record_extension -> true - | _ -> false - let type_declarations ?(equality = false) env name decl1 id decl2 = if decl1.type_arity <> decl2.type_arity then [Arity] else if not (private_flags decl1 decl2) then [Privacy] else @@ -240,8 +227,8 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> let err = compare_records env decl1.type_params decl2.type_params 1 labels1 labels2 in - if err <> [] || record_representations rep1 rep2 then err else - [Record_representation (rep1, rep2)] + if err <> [] || rep1 = rep2 then err else + [Record_representation (rep2 = Record_float)] | (Type_open, Type_open) -> [] | (_, _) -> [Kind] in diff --git a/typing/includecore.mli b/typing/includecore.mli index d98455380..0c8e9558f 100644 --- a/typing/includecore.mli +++ b/typing/includecore.mli @@ -29,7 +29,7 @@ type type_mismatch = | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t - | Record_representation of record_representation * record_representation + | Record_representation of bool val value_descriptions: Env.t -> value_description -> value_description -> module_coercion diff --git a/typing/mtype.ml b/typing/mtype.ml index 5f7bec327..3c3b4b8c7 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -265,6 +265,11 @@ and contains_type_item env = function {type_kind = Type_abstract; type_private = Private}),_) | Sig_modtype _ | Sig_typext (_, {ext_args = Cstr_record _}, _) -> + (* We consider that extension constructors with an inlined + record create a type (the inlined record), even though + it would be technically safe to ignore that considering + the current constraints which guarantee that this type + is kept local to expressions. *) raise Exit | Sig_module (_, {md_type = mty}, _) -> contains_type env mty diff --git a/typing/typedecl.ml b/typing/typedecl.ml index d9999cba8..90c432bc5 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -414,7 +414,7 @@ let check_constraints env sdecl (_, decl) = styl tyl | Cstr_record tyl, Pcstr_record styl -> check_constraints_labels env visited tyl styl - | _ -> assert false (* todo *) + | _ -> assert false end; match pcd_res, cd_res with | Some sr, Some r ->