2016-02-18 07:11:59 -08:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* OCaml *)
|
|
|
|
(* *)
|
|
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
|
|
(* *)
|
|
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
|
|
(* en Automatique. *)
|
|
|
|
(* *)
|
|
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
|
|
(* special exception on linking described in the file LICENSE. *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
1995-08-09 08:06:35 -07:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Inclusion checks for the core language *)
|
|
|
|
|
2003-07-02 02:14:35 -07:00
|
|
|
open Asttypes
|
1995-05-04 03:15:53 -07:00
|
|
|
open Path
|
1996-09-23 04:33:27 -07:00
|
|
|
open Types
|
1995-05-04 03:15:53 -07:00
|
|
|
open Typedtree
|
|
|
|
|
1995-05-05 03:05:18 -07:00
|
|
|
(* Inclusion between value descriptions *)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1995-10-23 09:59:41 -07:00
|
|
|
exception Dont_match
|
|
|
|
|
2017-05-09 03:57:07 -07:00
|
|
|
let value_descriptions ~loc env name
|
|
|
|
(vd1 : Types.value_description)
|
|
|
|
(vd2 : Types.value_description) =
|
2018-11-15 00:51:35 -08:00
|
|
|
Builtin_attributes.check_alerts_inclusion
|
2017-05-09 03:57:07 -07:00
|
|
|
~def:vd1.val_loc
|
|
|
|
~use:vd2.val_loc
|
|
|
|
loc
|
|
|
|
vd1.val_attributes vd2.val_attributes
|
|
|
|
name;
|
1997-04-01 12:52:36 -08:00
|
|
|
if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin
|
1996-04-22 04:15:41 -07:00
|
|
|
match (vd1.val_kind, vd2.val_kind) with
|
|
|
|
(Val_prim p1, Val_prim p2) ->
|
1995-10-23 09:59:41 -07:00
|
|
|
if p1 = p2 then Tcoerce_none else raise Dont_match
|
2014-11-17 03:55:24 -08:00
|
|
|
| (Val_prim p, _) ->
|
2016-01-14 06:29:41 -08:00
|
|
|
let pc = {pc_desc = p; pc_type = vd2.Types.val_type;
|
|
|
|
pc_env = env; pc_loc = vd1.Types.val_loc; } in
|
2014-11-17 03:55:24 -08:00
|
|
|
Tcoerce_primitive pc
|
2016-03-09 02:40:16 -08:00
|
|
|
| (_, Val_prim _) -> raise Dont_match
|
1996-04-22 04:15:41 -07:00
|
|
|
| (_, _) -> Tcoerce_none
|
1995-10-23 09:59:41 -07:00
|
|
|
end else
|
|
|
|
raise Dont_match
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2003-07-02 02:14:35 -07:00
|
|
|
(* Inclusion between "private" annotations *)
|
|
|
|
|
2007-11-28 14:27:35 -08:00
|
|
|
let private_flags decl1 decl2 =
|
|
|
|
match decl1.type_private, decl2.type_private with
|
2007-10-17 20:58:07 -07:00
|
|
|
| Private, Public ->
|
2010-01-20 08:26:46 -08:00
|
|
|
decl2.type_kind = Type_abstract &&
|
|
|
|
(decl2.type_manifest = None || decl1.type_kind <> Type_abstract)
|
2007-10-09 03:29:37 -07:00
|
|
|
| _, _ -> true
|
2003-07-02 02:14:35 -07:00
|
|
|
|
2005-08-07 22:40:52 -07:00
|
|
|
(* Inclusion between manifest types (particularly for private row types) *)
|
2005-03-22 19:08:37 -08:00
|
|
|
|
|
|
|
let is_absrow env ty =
|
|
|
|
match ty.desc with
|
2016-03-09 02:40:16 -08:00
|
|
|
Tconstr(Pident _, _, _) ->
|
2005-03-22 19:08:37 -08:00
|
|
|
begin match Ctype.expand_head env ty with
|
|
|
|
{desc=Tobject _|Tvariant _} -> true
|
|
|
|
| _ -> false
|
|
|
|
end
|
|
|
|
| _ -> false
|
|
|
|
|
2008-12-03 10:09:09 -08:00
|
|
|
let type_manifest env ty1 params1 ty2 params2 priv2 =
|
2005-03-22 19:08:37 -08:00
|
|
|
let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
|
|
|
|
match ty1'.desc, ty2'.desc with
|
|
|
|
Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
|
|
|
|
let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
|
|
|
|
Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
|
2011-11-24 01:02:48 -08:00
|
|
|
begin match row1.row_more with
|
|
|
|
{desc=Tvar _|Tconstr _|Tnil} -> true
|
|
|
|
| _ -> false
|
|
|
|
end &&
|
2005-03-22 19:08:37 -08:00
|
|
|
let r1, r2, pairs =
|
2010-01-22 04:48:24 -08:00
|
|
|
Ctype.merge_row_fields row1.row_fields row2.row_fields in
|
2005-03-22 19:08:37 -08:00
|
|
|
(not row2.row_closed ||
|
|
|
|
row1.row_closed && Ctype.filter_row_fields false r1 = []) &&
|
|
|
|
List.for_all
|
2010-01-22 04:48:24 -08:00
|
|
|
(fun (_,f) -> match Btype.row_field_repr f with
|
|
|
|
Rabsent | Reither _ -> true | Rpresent _ -> false)
|
|
|
|
r2 &&
|
2005-03-22 19:08:37 -08:00
|
|
|
let to_equal = ref (List.combine params1 params2) in
|
|
|
|
List.for_all
|
2010-01-22 04:48:24 -08:00
|
|
|
(fun (_, f1, f2) ->
|
|
|
|
match Btype.row_field_repr f1, Btype.row_field_repr f2 with
|
|
|
|
Rpresent(Some t1),
|
|
|
|
(Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
|
|
|
|
to_equal := (t1,t2) :: !to_equal; true
|
|
|
|
| Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
|
|
|
|
| Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
|
|
|
|
when List.length tl1 = List.length tl2 && c1 = c2 ->
|
|
|
|
to_equal := List.combine tl1 tl2 @ !to_equal; true
|
|
|
|
| Rabsent, (Reither _ | Rabsent) -> true
|
|
|
|
| _ -> false)
|
|
|
|
pairs &&
|
2005-03-22 19:08:37 -08:00
|
|
|
let tl1, tl2 = List.split !to_equal in
|
|
|
|
Ctype.equal env true tl1 tl2
|
|
|
|
| Tobject (fi1, _), Tobject (fi2, _)
|
|
|
|
when is_absrow env (snd(Ctype.flatten_fields fi2)) ->
|
|
|
|
let (fields2,rest2) = Ctype.flatten_fields fi2 in
|
|
|
|
Ctype.equal env true (ty1::params1) (rest2::params2) &&
|
|
|
|
let (fields1,rest1) = Ctype.flatten_fields fi1 in
|
2011-09-22 02:05:42 -07:00
|
|
|
(match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
|
2016-03-09 02:40:16 -08:00
|
|
|
let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in
|
2005-03-22 19:08:37 -08:00
|
|
|
miss2 = [] &&
|
|
|
|
let tl1, tl2 =
|
2010-01-22 04:48:24 -08:00
|
|
|
List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in
|
2005-03-22 19:08:37 -08:00
|
|
|
Ctype.equal env true (params1 @ tl1) (params2 @ tl2)
|
2007-10-09 03:29:37 -07:00
|
|
|
| _ ->
|
2008-12-03 10:09:09 -08:00
|
|
|
let rec check_super ty1 =
|
|
|
|
Ctype.equal env true (ty1 :: params1) (ty2 :: params2) ||
|
|
|
|
priv2 = Private &&
|
|
|
|
try check_super
|
|
|
|
(Ctype.try_expand_once_opt env (Ctype.expand_head env ty1))
|
|
|
|
with Ctype.Cannot_expand -> false
|
|
|
|
in check_super ty1
|
2005-03-22 19:08:37 -08:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Inclusion between type declarations *)
|
|
|
|
|
2010-05-20 20:36:52 -07:00
|
|
|
type type_mismatch =
|
|
|
|
Arity
|
|
|
|
| Privacy
|
|
|
|
| Kind
|
|
|
|
| Constraint
|
|
|
|
| Manifest
|
|
|
|
| Variance
|
2012-05-30 07:52:37 -07:00
|
|
|
| Field_type of Ident.t
|
|
|
|
| Field_mutable of Ident.t
|
|
|
|
| Field_arity of Ident.t
|
|
|
|
| Field_names of int * Ident.t * Ident.t
|
|
|
|
| Field_missing of bool * Ident.t
|
2016-05-25 07:29:05 -07:00
|
|
|
| Record_representation of bool (* true means second one is unboxed float *)
|
|
|
|
| Unboxed_representation of bool (* true means second one is unboxed *)
|
2015-05-27 07:30:33 -07:00
|
|
|
| Immediate
|
2010-05-20 20:36:52 -07:00
|
|
|
|
2010-05-21 08:13:47 -07:00
|
|
|
let report_type_mismatch0 first second decl ppf err =
|
|
|
|
let pr fmt = Format.fprintf ppf fmt in
|
|
|
|
match err with
|
|
|
|
Arity -> pr "They have different arities"
|
|
|
|
| Privacy -> pr "A private type would be revealed"
|
|
|
|
| Kind -> pr "Their kinds differ"
|
|
|
|
| Constraint -> pr "Their constraints differ"
|
|
|
|
| Manifest -> ()
|
|
|
|
| Variance -> pr "Their variances do not agree"
|
2010-05-20 20:36:52 -07:00
|
|
|
| Field_type s ->
|
2012-05-30 07:52:37 -07:00
|
|
|
pr "The types for field %s are not equal" (Ident.name s)
|
2010-05-20 20:36:52 -07:00
|
|
|
| Field_mutable s ->
|
2012-05-30 07:52:37 -07:00
|
|
|
pr "The mutability of field %s is different" (Ident.name s)
|
2010-05-20 20:36:52 -07:00
|
|
|
| Field_arity s ->
|
2012-05-30 07:52:37 -07:00
|
|
|
pr "The arities for field %s differ" (Ident.name s)
|
2010-05-20 20:36:52 -07:00
|
|
|
| Field_names (n, name1, name2) ->
|
2013-07-09 04:16:25 -07:00
|
|
|
pr "Fields number %i have different names, %s and %s"
|
|
|
|
n (Ident.name name1) (Ident.name name2)
|
2010-05-20 20:36:52 -07:00
|
|
|
| Field_missing (b, s) ->
|
2010-05-21 08:13:47 -07:00
|
|
|
pr "The field %s is only present in %s %s"
|
2012-05-30 07:52:37 -07:00
|
|
|
(Ident.name s) (if b then second else first) decl
|
2010-05-21 08:13:47 -07:00
|
|
|
| Record_representation b ->
|
|
|
|
pr "Their internal representations differ:@ %s %s %s"
|
|
|
|
(if b then second else first) decl
|
|
|
|
"uses unboxed float representation"
|
2016-05-25 07:29:05 -07:00
|
|
|
| Unboxed_representation b ->
|
|
|
|
pr "Their internal representations differ:@ %s %s %s"
|
|
|
|
(if b then second else first) decl
|
|
|
|
"uses unboxed representation"
|
2015-05-27 07:30:33 -07:00
|
|
|
| Immediate -> pr "%s is not an immediate type" first
|
2010-05-21 08:13:47 -07:00
|
|
|
|
2018-08-08 09:07:53 -07:00
|
|
|
let report_type_mismatch first second decl ppf err =
|
|
|
|
if err = Manifest then () else
|
|
|
|
Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err
|
2010-05-20 20:36:52 -07:00
|
|
|
|
2017-05-09 04:35:41 -07:00
|
|
|
let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 =
|
2014-10-14 08:51:30 -07:00
|
|
|
match arg1, arg2 with
|
|
|
|
| Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
|
2018-08-08 09:07:53 -07:00
|
|
|
if List.length arg1 <> List.length arg2 then Some (Field_arity cstr)
|
2016-09-28 03:41:22 -07:00
|
|
|
else if
|
|
|
|
(* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
|
|
|
|
Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
|
2018-08-08 09:07:53 -07:00
|
|
|
then None else Some (Field_type cstr)
|
2014-10-14 08:51:30 -07:00
|
|
|
| Types.Cstr_record l1, Types.Cstr_record l2 ->
|
2017-05-09 04:35:41 -07:00
|
|
|
compare_records env ~loc params1 params2 0 l1 l2
|
2018-08-08 09:07:53 -07:00
|
|
|
| _ -> Some (Field_type cstr)
|
2014-10-14 08:51:30 -07:00
|
|
|
|
2017-05-09 04:17:41 -07:00
|
|
|
and compare_variants ~loc env params1 params2 n
|
|
|
|
(cstrs1 : Types.constructor_declaration list)
|
|
|
|
(cstrs2 : Types.constructor_declaration list) =
|
2010-05-20 20:36:52 -07:00
|
|
|
match cstrs1, cstrs2 with
|
2018-08-08 09:07:53 -07:00
|
|
|
[], [] -> None
|
|
|
|
| [], c::_ -> Some (Field_missing (true, c.Types.cd_id))
|
|
|
|
| c::_, [] -> Some (Field_missing (false, c.Types.cd_id))
|
2017-05-09 04:17:41 -07:00
|
|
|
| cd1::rem1, cd2::rem2 ->
|
|
|
|
if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then
|
2018-08-08 09:07:53 -07:00
|
|
|
Some (Field_names (n, cd1.cd_id, cd2.cd_id))
|
2017-05-09 04:17:41 -07:00
|
|
|
else begin
|
2018-11-15 00:51:35 -08:00
|
|
|
Builtin_attributes.check_alerts_inclusion
|
2017-05-09 04:17:41 -07:00
|
|
|
~def:cd1.cd_loc
|
|
|
|
~use:cd2.cd_loc
|
|
|
|
loc
|
|
|
|
cd1.cd_attributes cd2.cd_attributes
|
|
|
|
(Ident.name cd1.cd_id);
|
2016-03-02 16:58:26 -08:00
|
|
|
let r =
|
2017-05-09 04:17:41 -07:00
|
|
|
match cd1.cd_res, cd2.cd_res with
|
2016-03-02 16:58:26 -08:00
|
|
|
| Some r1, Some r2 ->
|
|
|
|
if Ctype.equal env true [r1] [r2] then
|
2017-05-09 04:35:41 -07:00
|
|
|
compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2]
|
2017-05-09 04:17:41 -07:00
|
|
|
cd1.cd_args cd2.cd_args
|
2018-08-08 09:07:53 -07:00
|
|
|
else Some (Field_type cd1.cd_id)
|
2016-03-02 16:58:26 -08:00
|
|
|
| Some _, None | None, Some _ ->
|
2018-08-08 09:07:53 -07:00
|
|
|
Some (Field_type cd1.cd_id)
|
2016-03-02 16:58:26 -08:00
|
|
|
| _ ->
|
2017-05-09 04:35:41 -07:00
|
|
|
compare_constructor_arguments ~loc env cd1.cd_id
|
2017-05-09 04:17:41 -07:00
|
|
|
params1 params2 cd1.cd_args cd2.cd_args
|
2016-03-02 16:58:26 -08:00
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
if r <> None then r
|
2017-05-09 04:17:41 -07:00
|
|
|
else compare_variants ~loc env params1 params2 (n+1) rem1 rem2
|
|
|
|
end
|
2012-05-30 07:52:37 -07:00
|
|
|
|
|
|
|
|
2017-05-09 04:35:41 -07:00
|
|
|
and compare_records ~loc env params1 params2 n
|
|
|
|
(labels1 : Types.label_declaration list)
|
|
|
|
(labels2 : Types.label_declaration list) =
|
2010-05-20 20:36:52 -07:00
|
|
|
match labels1, labels2 with
|
2018-08-08 09:07:53 -07:00
|
|
|
[], [] -> None
|
|
|
|
| [], l::_ -> Some (Field_missing (true, l.Types.ld_id))
|
|
|
|
| l::_, [] -> Some (Field_missing (false, l.Types.ld_id))
|
2017-05-09 04:35:41 -07:00
|
|
|
| ld1::rem1, ld2::rem2 ->
|
|
|
|
if Ident.name ld1.ld_id <> Ident.name ld2.ld_id
|
2018-08-08 09:07:53 -07:00
|
|
|
then Some (Field_names (n, ld1.ld_id, ld2.ld_id))
|
2017-08-12 13:24:41 -07:00
|
|
|
else if ld1.ld_mutable <> ld2.ld_mutable then
|
2018-08-08 09:07:53 -07:00
|
|
|
Some (Field_mutable ld1.ld_id)
|
2017-08-12 13:24:41 -07:00
|
|
|
else begin
|
2017-05-09 04:35:41 -07:00
|
|
|
Builtin_attributes.check_deprecated_mutable_inclusion
|
|
|
|
~def:ld1.ld_loc
|
|
|
|
~use:ld2.ld_loc
|
|
|
|
loc
|
|
|
|
ld1.ld_attributes ld2.ld_attributes
|
|
|
|
(Ident.name ld1.ld_id);
|
|
|
|
if Ctype.equal env true (ld1.ld_type::params1)(ld2.ld_type::params2)
|
|
|
|
then (* add arguments to the parameters, cf. PR#7378 *)
|
|
|
|
compare_records ~loc env
|
|
|
|
(ld1.ld_type::params1) (ld2.ld_type::params2)
|
|
|
|
(n+1)
|
|
|
|
rem1 rem2
|
|
|
|
else
|
2018-08-08 09:07:53 -07:00
|
|
|
Some (Field_type ld1.ld_id)
|
2017-05-09 04:35:41 -07:00
|
|
|
end
|
2010-05-20 20:36:52 -07:00
|
|
|
|
2019-04-18 18:57:55 -07:00
|
|
|
let type_declarations ?(equality = false) ~loc env ~mark name decl1 path decl2 =
|
2018-11-15 00:51:35 -08:00
|
|
|
Builtin_attributes.check_alerts_inclusion
|
2017-05-09 04:47:49 -07:00
|
|
|
~def:decl1.type_loc
|
|
|
|
~use:decl2.type_loc
|
|
|
|
loc
|
|
|
|
decl1.type_attributes decl2.type_attributes
|
|
|
|
name;
|
2018-08-08 09:07:53 -07:00
|
|
|
if decl1.type_arity <> decl2.type_arity then Some Arity else
|
|
|
|
if not (private_flags decl1 decl2) then Some Privacy else
|
2015-12-02 15:06:18 -08:00
|
|
|
let err = match (decl1.type_manifest, decl2.type_manifest) with
|
|
|
|
(_, None) ->
|
|
|
|
if Ctype.equal env true decl1.type_params decl2.type_params
|
2018-08-08 09:07:53 -07:00
|
|
|
then None else Some Constraint
|
2015-12-02 15:06:18 -08:00
|
|
|
| (Some ty1, Some ty2) ->
|
|
|
|
if type_manifest env ty1 decl1.type_params ty2 decl2.type_params
|
|
|
|
decl2.type_private
|
2018-08-08 09:07:53 -07:00
|
|
|
then None else Some Manifest
|
2015-12-02 15:06:18 -08:00
|
|
|
| (None, Some ty2) ->
|
|
|
|
let ty1 =
|
2019-04-18 18:57:55 -07:00
|
|
|
Btype.newgenty (Tconstr(path, decl2.type_params, ref Mnil))
|
2015-12-02 15:06:18 -08:00
|
|
|
in
|
|
|
|
if Ctype.equal env true decl1.type_params decl2.type_params then
|
2018-08-08 09:07:53 -07:00
|
|
|
if Ctype.equal env false [ty1] [ty2] then None
|
|
|
|
else Some Manifest
|
|
|
|
else Some Constraint
|
2015-12-02 15:06:18 -08:00
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
if err <> None then err else
|
2016-05-25 07:29:05 -07:00
|
|
|
let err =
|
|
|
|
match (decl2.type_kind, decl1.type_unboxed.unboxed,
|
|
|
|
decl2.type_unboxed.unboxed) with
|
2018-08-08 09:07:53 -07:00
|
|
|
| Type_abstract, _, _ -> None
|
|
|
|
| _, true, false -> Some (Unboxed_representation false)
|
|
|
|
| _, false, true -> Some (Unboxed_representation true)
|
|
|
|
| _ -> None
|
2016-05-25 07:29:05 -07:00
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
if err <> None then err else
|
2010-05-20 20:36:52 -07:00
|
|
|
let err = match (decl1.type_kind, decl2.type_kind) with
|
2018-08-08 09:07:53 -07:00
|
|
|
(_, Type_abstract) -> None
|
2007-10-09 03:29:37 -07:00
|
|
|
| (Type_variant cstrs1, Type_variant cstrs2) ->
|
2018-03-14 09:57:31 -07:00
|
|
|
if mark then begin
|
|
|
|
let mark cstrs usage name decl =
|
|
|
|
List.iter
|
|
|
|
(fun c ->
|
|
|
|
Env.mark_constructor_used usage name decl
|
|
|
|
(Ident.name c.Types.cd_id))
|
|
|
|
cstrs
|
|
|
|
in
|
|
|
|
let usage =
|
|
|
|
if decl1.type_private = Private || decl2.type_private = Public
|
|
|
|
then Env.Positive else Env.Privatize
|
|
|
|
in
|
|
|
|
mark cstrs1 usage name decl1;
|
2019-04-18 18:57:55 -07:00
|
|
|
if equality then mark cstrs2 Env.Positive (Path.name path) decl2
|
2018-03-14 09:57:31 -07:00
|
|
|
end;
|
|
|
|
compare_variants ~loc env decl1.type_params
|
|
|
|
decl2.type_params 1 cstrs1 cstrs2
|
2007-10-09 03:29:37 -07:00
|
|
|
| (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
|
2018-03-14 09:57:31 -07:00
|
|
|
let err =
|
|
|
|
compare_records ~loc env decl1.type_params
|
|
|
|
decl2.type_params 1 labels1 labels2
|
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
if err <> None || rep1 = rep2 then err else
|
|
|
|
Some (Record_representation (rep2 = Record_float))
|
|
|
|
| (Type_open, Type_open) -> None
|
|
|
|
| (_, _) -> Some Kind
|
2010-05-20 20:36:52 -07:00
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
if err <> None then err else
|
2015-05-27 07:30:33 -07:00
|
|
|
let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
|
|
|
|
(* If attempt to assign a non-immediate type (e.g. string) to a type that
|
|
|
|
* must be immediate, then we error *)
|
|
|
|
let err =
|
|
|
|
if abstr &&
|
|
|
|
not decl1.type_immediate &&
|
|
|
|
decl2.type_immediate then
|
2018-08-08 09:07:53 -07:00
|
|
|
Some Immediate
|
|
|
|
else None
|
2015-05-27 07:30:33 -07:00
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
if err <> None then err else
|
2017-03-14 19:37:31 -07:00
|
|
|
let need_variance =
|
|
|
|
abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
|
2018-08-08 09:07:53 -07:00
|
|
|
if not need_variance then None else
|
2015-05-27 07:30:33 -07:00
|
|
|
let abstr = abstr || decl2.type_private = Private in
|
2014-05-04 16:08:45 -07:00
|
|
|
let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
|
|
|
|
let constrained ty = not (Btype.(is_Tvar (repr ty))) in
|
2013-05-03 06:38:30 -07:00
|
|
|
if List.for_all2
|
|
|
|
(fun ty (v1,v2) ->
|
|
|
|
let open Variance in
|
|
|
|
let imp a b = not a || b in
|
|
|
|
let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in
|
2014-05-04 16:08:45 -07:00
|
|
|
(if abstr then (imp co1 co2 && imp cn1 cn2)
|
|
|
|
else if opn || constrained ty then (co1 = co2 && cn1 = cn2)
|
|
|
|
else true) &&
|
2013-05-03 06:38:30 -07:00
|
|
|
let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in
|
|
|
|
imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1))
|
|
|
|
decl2.type_params (List.combine decl1.type_variance decl2.type_variance)
|
2018-08-08 09:07:53 -07:00
|
|
|
then None else Some Variance
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2014-05-04 16:08:45 -07:00
|
|
|
(* Inclusion between extension constructors *)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2018-03-14 09:57:31 -07:00
|
|
|
let extension_constructors ~loc env ~mark id ext1 ext2 =
|
|
|
|
if mark then begin
|
|
|
|
let usage =
|
|
|
|
if ext1.ext_private = Private || ext2.ext_private = Public
|
|
|
|
then Env.Positive else Env.Privatize
|
|
|
|
in
|
|
|
|
Env.mark_extension_used usage ext1 (Ident.name id)
|
|
|
|
end;
|
2014-05-04 16:08:45 -07:00
|
|
|
let ty1 =
|
|
|
|
Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil))
|
|
|
|
in
|
|
|
|
let ty2 =
|
|
|
|
Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil))
|
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
if not (Ctype.equal env true (ty1 :: ext1.ext_type_params)
|
|
|
|
(ty2 :: ext2.ext_type_params))
|
2019-07-10 10:05:00 -07:00
|
|
|
then Some (Field_type id) else
|
|
|
|
let r =
|
2018-08-08 09:07:53 -07:00
|
|
|
match ext1.ext_ret_type, ext2.ext_ret_type with
|
2019-07-10 10:05:00 -07:00
|
|
|
| Some r1, Some r2 ->
|
|
|
|
if Ctype.equal env true [r1] [r2] then
|
|
|
|
compare_constructor_arguments ~loc env id [r1] [r2]
|
|
|
|
ext1.ext_args ext2.ext_args
|
|
|
|
else Some (Field_type id)
|
2018-08-08 09:07:53 -07:00
|
|
|
| Some _, None | None, Some _ ->
|
|
|
|
Some (Field_type id)
|
2019-07-10 10:05:00 -07:00
|
|
|
| None, None ->
|
|
|
|
compare_constructor_arguments ~loc env id
|
|
|
|
ext1.ext_type_params ext2.ext_type_params
|
|
|
|
ext1.ext_args ext2.ext_args
|
|
|
|
in
|
|
|
|
if r <> None then r else
|
|
|
|
match ext1.ext_private, ext2.ext_private with
|
|
|
|
| Private, Public -> Some Privacy
|
|
|
|
| _, _ -> None
|