2016-02-18 07:11:59 -08:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* OCaml *)
|
|
|
|
(* *)
|
|
|
|
(* Xavier Leroy and Jerome Vouillon, 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
|
|
|
|
1997-02-20 12:39:02 -08:00
|
|
|
(**** Typing of type definitions ****)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1997-02-20 12:39:02 -08:00
|
|
|
open Misc
|
2000-09-06 03:21:07 -07:00
|
|
|
open Asttypes
|
1995-05-04 03:15:53 -07:00
|
|
|
open Parsetree
|
2000-06-05 05:18:30 -07:00
|
|
|
open Primitive
|
1996-09-23 04:33:27 -07:00
|
|
|
open Types
|
1995-05-04 03:15:53 -07:00
|
|
|
open Typetexp
|
|
|
|
|
2018-07-23 05:19:41 -07:00
|
|
|
module String = Misc.Stdlib.String
|
|
|
|
|
2015-08-25 09:18:46 -07:00
|
|
|
type native_repr_kind = Unboxed | Untagged
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
type error =
|
|
|
|
Repeated_parameter
|
|
|
|
| Duplicate_constructor of string
|
1995-05-22 08:43:44 -07:00
|
|
|
| Too_many_constructors
|
1995-05-04 03:15:53 -07:00
|
|
|
| Duplicate_label of string
|
|
|
|
| Recursive_abbrev of string
|
2014-08-22 06:45:02 -07:00
|
|
|
| Cycle_in_def of string * type_expr
|
2018-08-08 09:07:53 -07:00
|
|
|
| Definition_mismatch of type_expr * Includecore.type_mismatch option
|
2000-05-24 01:06:33 -07:00
|
|
|
| Constraint_failed of type_expr * type_expr
|
2018-09-10 13:15:45 -07:00
|
|
|
| Inconsistent_constraint of Env.t * Ctype.Unification_trace.t
|
|
|
|
| Type_clash of Env.t * Ctype.Unification_trace.t
|
2003-07-01 06:05:43 -07:00
|
|
|
| Parameters_differ of Path.t * type_expr * type_expr
|
1997-05-13 07:07:00 -07:00
|
|
|
| Null_arity_external
|
2000-06-05 05:18:30 -07:00
|
|
|
| Missing_native_external
|
2005-08-13 13:59:37 -07:00
|
|
|
| Unbound_type_var of type_expr * type_declaration
|
2017-07-20 08:33:41 -07:00
|
|
|
| Cannot_extend_private_type of Path.t
|
2014-05-04 16:08:45 -07:00
|
|
|
| Not_extensible_type of Path.t
|
2018-08-08 09:07:53 -07:00
|
|
|
| Extension_mismatch of Path.t * Includecore.type_mismatch
|
2018-09-10 13:15:45 -07:00
|
|
|
| Rebind_wrong_type of Longident.t * Env.t * Ctype.Unification_trace.t
|
2014-05-04 16:08:45 -07:00
|
|
|
| Rebind_mismatch of Longident.t * Path.t * Path.t
|
|
|
|
| Rebind_private of Longident.t
|
2018-11-20 07:10:19 -08:00
|
|
|
| Variance of Typedecl_variance.error
|
2001-09-28 15:55:27 -07:00
|
|
|
| Unavailable_type_constructor of Path.t
|
2005-03-22 19:08:37 -08:00
|
|
|
| Bad_fixed_type of string
|
2014-05-04 16:08:45 -07:00
|
|
|
| Unbound_type_var_ext of type_expr * extension_constructor
|
2014-12-10 05:37:50 -08:00
|
|
|
| Val_in_structure
|
2015-08-25 09:18:46 -07:00
|
|
|
| Multiple_native_repr_attributes
|
|
|
|
| Cannot_unbox_or_untag_type of native_repr_kind
|
2016-01-18 09:34:02 -08:00
|
|
|
| Deep_unbox_or_untag_attribute of native_repr_kind
|
2018-11-20 07:28:15 -08:00
|
|
|
| Immediacy of Typedecl_immediacy.error
|
2016-05-25 07:29:05 -07:00
|
|
|
| Bad_unboxed_attribute of string
|
|
|
|
| Wrong_unboxed_type_float
|
|
|
|
| Boxed_and_unboxed
|
2017-03-15 16:34:10 -07:00
|
|
|
| Nonrec_gadt
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2012-05-30 07:52:37 -07:00
|
|
|
open Typedtree
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
exception Error of Location.t * error
|
|
|
|
|
2016-05-25 07:29:05 -07:00
|
|
|
(* Note: do not factor the branches in the following pattern-matching:
|
|
|
|
the records must be constants for the compiler to do sharing on them.
|
|
|
|
*)
|
|
|
|
let get_unboxed_from_attributes sdecl =
|
|
|
|
let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in
|
|
|
|
let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in
|
|
|
|
match boxed, unboxed, !Clflags.unboxed_types with
|
|
|
|
| true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed))
|
2016-09-01 09:39:32 -07:00
|
|
|
| true, false, _ -> unboxed_false_default_false
|
|
|
|
| false, true, _ -> unboxed_true_default_false
|
|
|
|
| false, false, false -> unboxed_false_default_true
|
|
|
|
| false, false, true -> unboxed_true_default_true
|
2016-05-25 07:29:05 -07:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Enter all declared types in the environment as abstract types *)
|
|
|
|
|
2018-08-09 03:42:48 -07:00
|
|
|
let add_type ~check id decl env =
|
2018-08-09 04:41:49 -07:00
|
|
|
Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
|
2018-08-09 03:42:48 -07:00
|
|
|
(fun () -> Env.add_type ~check id decl env)
|
|
|
|
|
2016-12-25 23:55:43 -08:00
|
|
|
let enter_type rec_flag env sdecl id =
|
|
|
|
let needed =
|
|
|
|
match rec_flag with
|
2017-03-15 16:34:10 -07:00
|
|
|
| Asttypes.Nonrecursive ->
|
|
|
|
begin match sdecl.ptype_kind with
|
|
|
|
| Ptype_variant scds ->
|
|
|
|
List.iter (fun cd ->
|
|
|
|
if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt)))
|
|
|
|
scds
|
|
|
|
| _ -> ()
|
|
|
|
end;
|
|
|
|
Btype.is_row_name (Ident.name id)
|
2016-12-25 23:55:43 -08:00
|
|
|
| Asttypes.Recursive -> true
|
|
|
|
in
|
|
|
|
if not needed then env else
|
2000-05-23 23:19:39 -07:00
|
|
|
let decl =
|
|
|
|
{ type_params =
|
|
|
|
List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params;
|
|
|
|
type_arity = List.length sdecl.ptype_params;
|
|
|
|
type_kind = Type_abstract;
|
2007-10-09 03:29:37 -07:00
|
|
|
type_private = sdecl.ptype_private;
|
2000-08-03 20:29:42 -07:00
|
|
|
type_manifest =
|
2000-09-06 03:21:07 -07:00
|
|
|
begin match sdecl.ptype_manifest with None -> None
|
|
|
|
| Some _ -> Some(Ctype.newvar ()) end;
|
2013-05-03 06:38:30 -07:00
|
|
|
type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params;
|
2018-02-12 08:37:35 -08:00
|
|
|
type_is_newtype = false;
|
2018-09-26 15:14:43 -07:00
|
|
|
type_expansion_scope = Btype.lowest_level;
|
2010-05-21 08:06:01 -07:00
|
|
|
type_loc = sdecl.ptype_loc;
|
2013-09-27 03:54:55 -07:00
|
|
|
type_attributes = sdecl.ptype_attributes;
|
2015-05-27 07:30:33 -07:00
|
|
|
type_immediate = false;
|
2016-09-01 09:39:32 -07:00
|
|
|
type_unboxed = unboxed_false_default_false;
|
2000-09-06 03:21:07 -07:00
|
|
|
}
|
2000-05-23 23:19:39 -07:00
|
|
|
in
|
2018-08-09 03:42:48 -07:00
|
|
|
add_type ~check:true id decl env
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2000-08-03 20:29:42 -07:00
|
|
|
let update_type temp_env env id loc =
|
|
|
|
let path = Path.Pident id in
|
|
|
|
let decl = Env.find_type path temp_env in
|
|
|
|
match decl.type_manifest with None -> ()
|
|
|
|
| Some ty ->
|
|
|
|
let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
|
|
|
|
try Ctype.unify env (Ctype.newconstr path params) ty
|
|
|
|
with Ctype.Unify trace ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error(loc, Type_clash (env, trace)))
|
2000-08-03 20:29:42 -07:00
|
|
|
|
2018-11-20 07:28:15 -08:00
|
|
|
let get_unboxed_type_representation =
|
|
|
|
Typedecl_unboxed.get_unboxed_type_representation
|
2016-05-25 07:29:05 -07:00
|
|
|
|
|
|
|
(* Determine if a type's values are represented by floats at run-time. *)
|
2000-03-21 06:43:25 -08:00
|
|
|
let is_float env ty =
|
2016-05-25 07:29:05 -07:00
|
|
|
match get_unboxed_type_representation env ty with
|
|
|
|
Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float
|
2000-03-21 06:43:25 -08:00
|
|
|
| _ -> false
|
|
|
|
|
2007-10-09 03:29:37 -07:00
|
|
|
(* Determine if a type definition defines a fixed type. (PW) *)
|
|
|
|
let is_fixed_type sd =
|
2014-02-25 00:16:25 -08:00
|
|
|
let rec has_row_var sty =
|
|
|
|
match sty.ptyp_desc with
|
|
|
|
Ptyp_alias (sty, _) -> has_row_var sty
|
|
|
|
| Ptyp_class _
|
|
|
|
| Ptyp_object (_, Open)
|
|
|
|
| Ptyp_variant (_, Open, _)
|
|
|
|
| Ptyp_variant (_, Closed, Some _) -> true
|
|
|
|
| _ -> false
|
|
|
|
in
|
|
|
|
match sd.ptype_manifest with
|
|
|
|
None -> false
|
|
|
|
| Some sty ->
|
|
|
|
sd.ptype_kind = Ptype_abstract &&
|
|
|
|
sd.ptype_private = Private &&
|
|
|
|
has_row_var sty
|
2007-10-09 03:29:37 -07:00
|
|
|
|
2005-03-22 19:08:37 -08:00
|
|
|
(* Set the row variable in a fixed type *)
|
|
|
|
let set_fixed_row env loc p decl =
|
|
|
|
let tm =
|
|
|
|
match decl.type_manifest with
|
|
|
|
None -> assert false
|
|
|
|
| Some t -> Ctype.expand_head env t
|
|
|
|
in
|
|
|
|
let rv =
|
|
|
|
match tm.desc with
|
|
|
|
Tvariant row ->
|
2005-07-12 16:50:45 -07:00
|
|
|
let row = Btype.row_repr row in
|
2019-07-12 08:47:25 -07:00
|
|
|
tm.desc <- Tvariant {row with row_fixed = Some Fixed_private};
|
2005-08-13 13:59:37 -07:00
|
|
|
if Btype.static_row row then Btype.newgenty Tnil
|
2005-07-12 16:50:45 -07:00
|
|
|
else row.row_more
|
2005-03-22 19:08:37 -08:00
|
|
|
| Tobject (ty, _) ->
|
2005-08-13 13:59:37 -07:00
|
|
|
snd (Ctype.flatten_fields ty)
|
2005-03-22 19:08:37 -08:00
|
|
|
| _ ->
|
|
|
|
raise (Error (loc, Bad_fixed_type "is not an object or variant"))
|
|
|
|
in
|
2011-09-22 02:05:42 -07:00
|
|
|
if not (Btype.is_Tvar rv) then
|
2005-03-22 19:08:37 -08:00
|
|
|
raise (Error (loc, Bad_fixed_type "has no row variable"));
|
|
|
|
rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Translate one type declaration *)
|
|
|
|
|
2014-05-04 16:08:45 -07:00
|
|
|
let make_params env params =
|
|
|
|
let make_param (sty, v) =
|
|
|
|
try
|
|
|
|
(transl_type_param env sty, v)
|
|
|
|
with Already_bound ->
|
|
|
|
raise(Error(sty.ptyp_loc, Repeated_parameter))
|
|
|
|
in
|
|
|
|
List.map make_param params
|
|
|
|
|
2016-03-09 02:40:16 -08:00
|
|
|
let transl_labels env closed lbls =
|
2016-01-04 05:07:38 -08:00
|
|
|
assert (lbls <> []);
|
2018-07-23 05:19:41 -07:00
|
|
|
let all_labels = ref String.Set.empty in
|
2014-10-03 08:24:50 -07:00
|
|
|
List.iter
|
|
|
|
(fun {pld_name = {txt=name; loc}} ->
|
2018-07-23 05:19:41 -07:00
|
|
|
if String.Set.mem name !all_labels then
|
2014-10-03 08:24:50 -07:00
|
|
|
raise(Error(loc, Duplicate_label name));
|
2018-07-23 05:19:41 -07:00
|
|
|
all_labels := String.Set.add name !all_labels)
|
2014-10-03 08:24:50 -07:00
|
|
|
lbls;
|
2015-09-11 04:58:31 -07:00
|
|
|
let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;
|
|
|
|
pld_attributes=attrs} =
|
2017-07-18 02:22:57 -07:00
|
|
|
Builtin_attributes.warning_scope attrs
|
|
|
|
(fun () ->
|
|
|
|
let arg = Ast_helper.Typ.force_poly arg in
|
|
|
|
let cty = transl_simple_type env closed arg in
|
2018-08-28 09:07:01 -07:00
|
|
|
{ld_id = Ident.create_local name.txt;
|
2018-08-28 09:06:45 -07:00
|
|
|
ld_name = name; ld_mutable = mut;
|
2017-07-18 02:22:57 -07:00
|
|
|
ld_type = cty; ld_loc = loc; ld_attributes = attrs}
|
|
|
|
)
|
2014-10-03 08:24:50 -07:00
|
|
|
in
|
|
|
|
let lbls = List.map mk lbls in
|
|
|
|
let lbls' =
|
|
|
|
List.map
|
|
|
|
(fun ld ->
|
|
|
|
let ty = ld.ld_type.ctyp_type in
|
|
|
|
let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in
|
|
|
|
{Types.ld_id = ld.ld_id;
|
|
|
|
ld_mutable = ld.ld_mutable;
|
|
|
|
ld_type = ty;
|
|
|
|
ld_loc = ld.ld_loc;
|
|
|
|
ld_attributes = ld.ld_attributes
|
|
|
|
}
|
|
|
|
)
|
|
|
|
lbls in
|
|
|
|
lbls, lbls'
|
|
|
|
|
2016-03-09 02:40:16 -08:00
|
|
|
let transl_constructor_arguments env closed = function
|
2014-10-14 08:51:30 -07:00
|
|
|
| Pcstr_tuple l ->
|
|
|
|
let l = List.map (transl_simple_type env closed) l in
|
|
|
|
Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l),
|
|
|
|
Cstr_tuple l
|
|
|
|
| Pcstr_record l ->
|
2016-03-09 02:40:16 -08:00
|
|
|
let lbls, lbls' = transl_labels env closed l in
|
2014-10-14 08:51:30 -07:00
|
|
|
Types.Cstr_record lbls',
|
|
|
|
Cstr_record lbls
|
|
|
|
|
2016-03-09 02:40:16 -08:00
|
|
|
let make_constructor env type_path type_params sargs sret_type =
|
2014-05-04 16:08:45 -07:00
|
|
|
match sret_type with
|
|
|
|
| None ->
|
2014-10-03 08:24:50 -07:00
|
|
|
let args, targs =
|
2016-03-09 02:40:16 -08:00
|
|
|
transl_constructor_arguments env true sargs
|
2014-10-03 08:24:50 -07:00
|
|
|
in
|
2017-10-02 06:56:02 -07:00
|
|
|
targs, None, args, None, type_params
|
2014-05-04 16:08:45 -07:00
|
|
|
| Some sret_type ->
|
|
|
|
(* if it's a generalized constructor we must first narrow and
|
|
|
|
then widen so as to not introduce any new constraints *)
|
|
|
|
let z = narrow () in
|
|
|
|
reset_type_variables ();
|
2014-10-03 08:24:50 -07:00
|
|
|
let args, targs =
|
2016-03-09 02:40:16 -08:00
|
|
|
transl_constructor_arguments env false sargs
|
2014-10-03 08:24:50 -07:00
|
|
|
in
|
2014-05-04 16:08:45 -07:00
|
|
|
let tret_type = transl_simple_type env false sret_type in
|
|
|
|
let ret_type = tret_type.ctyp_type in
|
2017-10-02 06:56:02 -07:00
|
|
|
let params =
|
2014-05-04 16:08:45 -07:00
|
|
|
match (Ctype.repr ret_type).desc with
|
2017-10-02 06:56:02 -07:00
|
|
|
| Tconstr (p', params, _) when Path.same type_path p' ->
|
|
|
|
params
|
2014-08-22 06:45:02 -07:00
|
|
|
| _ ->
|
|
|
|
raise (Error (sret_type.ptyp_loc, Constraint_failed
|
|
|
|
(ret_type, Ctype.newconstr type_path type_params)))
|
2017-10-02 06:56:02 -07:00
|
|
|
in
|
2014-05-04 16:08:45 -07:00
|
|
|
widen z;
|
2017-10-02 06:56:02 -07:00
|
|
|
targs, Some tret_type, args, Some ret_type, params
|
2010-11-10 02:38:18 -08:00
|
|
|
|
2017-06-20 02:23:29 -07:00
|
|
|
(* Check that the variable [id] is present in the [univ] list. *)
|
|
|
|
let check_type_var loc univ id =
|
|
|
|
let f t = (Btype.repr t).id = id in
|
|
|
|
if not (List.exists f univ) then raise (Error (loc, Wrong_unboxed_type_float))
|
|
|
|
|
|
|
|
(* Check that all the variables found in [ty] are in [univ].
|
|
|
|
Because [ty] is the argument to an abstract type, the representation
|
|
|
|
of that abstract type could be any subexpression of [ty], in particular
|
|
|
|
any type variable present in [ty].
|
|
|
|
*)
|
|
|
|
let rec check_unboxed_abstract_arg loc univ ty =
|
|
|
|
match ty.desc with
|
|
|
|
| Tvar _ -> check_type_var loc univ ty.id
|
|
|
|
| Tarrow (_, t1, t2, _)
|
|
|
|
| Tfield (_, _, t1, t2) ->
|
|
|
|
check_unboxed_abstract_arg loc univ t1;
|
|
|
|
check_unboxed_abstract_arg loc univ t2
|
|
|
|
| Ttuple args
|
|
|
|
| Tconstr (_, args, _)
|
|
|
|
| Tpackage (_, _, args) ->
|
|
|
|
List.iter (check_unboxed_abstract_arg loc univ) args
|
|
|
|
| Tobject (fields, r) ->
|
|
|
|
check_unboxed_abstract_arg loc univ fields;
|
|
|
|
begin match !r with
|
|
|
|
| None -> ()
|
|
|
|
| Some (_, args) -> List.iter (check_unboxed_abstract_arg loc univ) args
|
|
|
|
end
|
|
|
|
| Tnil
|
|
|
|
| Tunivar _ -> ()
|
|
|
|
| Tlink e -> check_unboxed_abstract_arg loc univ e
|
|
|
|
| Tsubst _ -> assert false
|
|
|
|
| Tvariant { row_fields; row_more; row_name } ->
|
|
|
|
List.iter (check_unboxed_abstract_row_field loc univ) row_fields;
|
|
|
|
check_unboxed_abstract_arg loc univ row_more;
|
|
|
|
begin match row_name with
|
|
|
|
| None -> ()
|
|
|
|
| Some (_, args) -> List.iter (check_unboxed_abstract_arg loc univ) args
|
|
|
|
end
|
|
|
|
| Tpoly (t, _) -> check_unboxed_abstract_arg loc univ t
|
|
|
|
|
|
|
|
and check_unboxed_abstract_row_field loc univ (_, field) =
|
|
|
|
match field with
|
|
|
|
| Rpresent (Some ty) -> check_unboxed_abstract_arg loc univ ty
|
|
|
|
| Reither (_, args, _, r) ->
|
|
|
|
List.iter (check_unboxed_abstract_arg loc univ) args;
|
|
|
|
begin match !r with
|
|
|
|
| None -> ()
|
|
|
|
| Some f -> check_unboxed_abstract_row_field loc univ ("", f)
|
|
|
|
end
|
|
|
|
| Rabsent
|
|
|
|
| Rpresent None -> ()
|
|
|
|
|
2016-05-25 07:29:05 -07:00
|
|
|
(* Check that the argument to a GADT constructor is compatible with unboxing
|
2017-06-20 02:23:29 -07:00
|
|
|
the type, given the universal parameters of the type. *)
|
|
|
|
let rec check_unboxed_gadt_arg loc univ env ty =
|
2016-05-25 07:29:05 -07:00
|
|
|
match get_unboxed_type_representation env ty with
|
2017-06-20 02:23:29 -07:00
|
|
|
| Some {desc = Tvar _; id} -> check_type_var loc univ id
|
2016-05-25 07:29:05 -07:00
|
|
|
| Some {desc = Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil
|
|
|
|
| Tvariant _; _} ->
|
|
|
|
()
|
|
|
|
(* A comment in [Translcore.transl_exp0] claims the above cannot be
|
|
|
|
represented by floats. *)
|
|
|
|
| Some {desc = Tconstr (p, args, _); _} ->
|
|
|
|
let tydecl = Env.find_type p env in
|
|
|
|
assert (not tydecl.type_unboxed.unboxed);
|
|
|
|
if tydecl.type_kind = Type_abstract then
|
2017-06-20 02:23:29 -07:00
|
|
|
List.iter (check_unboxed_abstract_arg loc univ) args
|
2016-05-25 07:29:05 -07:00
|
|
|
| Some {desc = Tfield _ | Tlink _ | Tsubst _; _} -> assert false
|
|
|
|
| Some {desc = Tunivar _; _} -> ()
|
2017-06-20 02:23:29 -07:00
|
|
|
| Some {desc = Tpoly (t2, _); _} -> check_unboxed_gadt_arg loc univ env t2
|
2016-05-25 07:29:05 -07:00
|
|
|
| None -> ()
|
|
|
|
(* This case is tricky: the argument is another (or the same) type
|
|
|
|
in the same recursive definition. In this case we don't have to
|
|
|
|
check because we will also check that other type for correctness. *)
|
|
|
|
|
2013-03-06 03:47:59 -08:00
|
|
|
let transl_declaration env sdecl id =
|
1997-04-24 06:41:16 -07:00
|
|
|
(* Bind type parameters *)
|
|
|
|
reset_type_variables();
|
2002-04-18 00:27:47 -07:00
|
|
|
Ctype.begin_def ();
|
2014-05-04 16:08:45 -07:00
|
|
|
let tparams = make_params env sdecl.ptype_params in
|
|
|
|
let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
|
2002-04-18 00:27:47 -07:00
|
|
|
let cstrs = List.map
|
2012-05-30 07:52:37 -07:00
|
|
|
(fun (sty, sty', loc) ->
|
|
|
|
transl_simple_type env false sty,
|
|
|
|
transl_simple_type env false sty', loc)
|
|
|
|
sdecl.ptype_cstrs
|
2002-04-18 00:27:47 -07:00
|
|
|
in
|
2016-05-25 07:29:05 -07:00
|
|
|
let raw_status = get_unboxed_from_attributes sdecl in
|
|
|
|
if raw_status.unboxed && not raw_status.default then begin
|
|
|
|
match sdecl.ptype_kind with
|
|
|
|
| Ptype_abstract ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
|
|
|
|
"it is abstract"))
|
|
|
|
| Ptype_variant [{pcd_args = Pcstr_tuple []; _}] ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
|
|
|
|
"its constructor has no argument"))
|
|
|
|
| Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] -> ()
|
|
|
|
| Ptype_variant [{pcd_args = Pcstr_tuple _; _}] ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
|
|
|
|
"its constructor has more than one argument"))
|
|
|
|
| Ptype_variant [{pcd_args = Pcstr_record
|
|
|
|
[{pld_mutable=Immutable; _}]; _}] -> ()
|
|
|
|
| Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Mutable; _}]; _}] ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable"))
|
|
|
|
| Ptype_variant [{pcd_args = Pcstr_record _; _}] ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
|
|
|
|
"its constructor has more than one argument"))
|
|
|
|
| Ptype_variant _ ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
|
|
|
|
"it has more than one constructor"))
|
|
|
|
| Ptype_record [{pld_mutable=Immutable; _}] -> ()
|
|
|
|
| Ptype_record [{pld_mutable=Mutable; _}] ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
|
|
|
|
"it is mutable"))
|
|
|
|
| Ptype_record _ ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
|
|
|
|
"it has more than one field"))
|
|
|
|
| Ptype_open ->
|
|
|
|
raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute
|
|
|
|
"extensible variant types cannot be unboxed"))
|
|
|
|
end;
|
|
|
|
let unboxed_status =
|
|
|
|
match sdecl.ptype_kind with
|
|
|
|
| Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}]
|
|
|
|
| Ptype_variant [{pcd_args = Pcstr_record
|
|
|
|
[{pld_mutable = Immutable; _}]; _}]
|
|
|
|
| Ptype_record [{pld_mutable = Immutable; _}] ->
|
|
|
|
raw_status
|
|
|
|
| _ -> (* The type is not unboxable, mark it as boxed *)
|
2016-09-01 09:39:32 -07:00
|
|
|
unboxed_false_default_false
|
2016-05-25 07:29:05 -07:00
|
|
|
in
|
|
|
|
let unbox = unboxed_status.unboxed in
|
2012-05-30 07:52:37 -07:00
|
|
|
let (tkind, kind) =
|
|
|
|
match sdecl.ptype_kind with
|
2016-05-25 07:29:05 -07:00
|
|
|
| Ptype_abstract -> Ttype_abstract, Type_abstract
|
2014-05-04 16:08:45 -07:00
|
|
|
| Ptype_variant scstrs ->
|
2017-03-13 21:03:19 -07:00
|
|
|
if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin
|
|
|
|
match cstrs with
|
|
|
|
[] -> ()
|
|
|
|
| (_,_,loc)::_ ->
|
|
|
|
Location.prerr_warning loc Warnings.Constraint_on_gadt
|
|
|
|
end;
|
2018-07-23 05:19:41 -07:00
|
|
|
let all_constrs = ref String.Set.empty in
|
2012-05-30 07:52:37 -07:00
|
|
|
List.iter
|
2013-03-04 07:35:47 -08:00
|
|
|
(fun {pcd_name = {txt = name}} ->
|
2018-07-23 05:19:41 -07:00
|
|
|
if String.Set.mem name !all_constrs then
|
2012-05-30 07:52:37 -07:00
|
|
|
raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
|
2018-07-23 05:19:41 -07:00
|
|
|
all_constrs := String.Set.add name !all_constrs)
|
2014-05-04 16:08:45 -07:00
|
|
|
scstrs;
|
2012-05-30 07:52:37 -07:00
|
|
|
if List.length
|
2016-05-25 07:29:05 -07:00
|
|
|
(List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs)
|
|
|
|
> (Config.max_tag + 1) then
|
2012-05-30 07:52:37 -07:00
|
|
|
raise(Error(sdecl.ptype_loc, Too_many_constructors));
|
2014-05-04 16:08:45 -07:00
|
|
|
let make_cstr scstr =
|
2018-08-28 09:07:01 -07:00
|
|
|
let name = Ident.create_local scstr.pcd_name.txt in
|
2017-10-02 06:56:02 -07:00
|
|
|
let targs, tret_type, args, ret_type, cstr_params =
|
2016-03-09 02:40:16 -08:00
|
|
|
make_constructor env (Path.Pident id) params
|
2014-05-04 16:08:45 -07:00
|
|
|
scstr.pcd_args scstr.pcd_res
|
|
|
|
in
|
2017-08-31 06:25:15 -07:00
|
|
|
if Config.flat_float_array && unbox then begin
|
2016-05-25 07:29:05 -07:00
|
|
|
(* Cannot unbox a type when the argument can be both float and
|
|
|
|
non-float because it interferes with the dynamic float array
|
|
|
|
optimization. This can only happen when the type is a GADT
|
|
|
|
and the argument is an existential type variable or an
|
|
|
|
unboxed (or abstract) type constructor applied to some
|
|
|
|
existential type variable. Of course we also have to rule
|
|
|
|
out any abstract type constructor applied to anything that
|
2017-06-20 02:23:29 -07:00
|
|
|
might be an existential type variable.
|
|
|
|
There is a difficulty with existential variables created
|
|
|
|
out of thin air (rather than bound by the declaration).
|
|
|
|
See PR#7511 and GPR#1133 for details. *)
|
2016-05-25 07:29:05 -07:00
|
|
|
match Datarepr.constructor_existentials args ret_type with
|
|
|
|
| _, [] -> ()
|
2017-06-20 02:23:29 -07:00
|
|
|
| [argty], _ex ->
|
2017-10-02 06:56:02 -07:00
|
|
|
check_unboxed_gadt_arg sdecl.ptype_loc cstr_params env argty
|
2016-05-25 07:29:05 -07:00
|
|
|
| _ -> assert false
|
|
|
|
end;
|
2014-05-04 16:08:45 -07:00
|
|
|
let tcstr =
|
|
|
|
{ cd_id = name;
|
|
|
|
cd_name = scstr.pcd_name;
|
|
|
|
cd_args = targs;
|
|
|
|
cd_res = tret_type;
|
|
|
|
cd_loc = scstr.pcd_loc;
|
|
|
|
cd_attributes = scstr.pcd_attributes }
|
|
|
|
in
|
|
|
|
let cstr =
|
|
|
|
{ Types.cd_id = name;
|
|
|
|
cd_args = args;
|
|
|
|
cd_res = ret_type;
|
|
|
|
cd_loc = scstr.pcd_loc;
|
|
|
|
cd_attributes = scstr.pcd_attributes }
|
|
|
|
in
|
|
|
|
tcstr, cstr
|
2012-07-30 11:04:46 -07:00
|
|
|
in
|
2017-07-18 02:22:57 -07:00
|
|
|
let make_cstr scstr =
|
|
|
|
Builtin_attributes.warning_scope scstr.pcd_attributes
|
|
|
|
(fun () -> make_cstr scstr)
|
|
|
|
in
|
2014-05-04 16:08:45 -07:00
|
|
|
let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in
|
|
|
|
Ttype_variant tcstrs, Type_variant cstrs
|
2012-05-30 07:52:37 -07:00
|
|
|
| Ptype_record lbls ->
|
2016-03-09 02:40:16 -08:00
|
|
|
let lbls, lbls' = transl_labels env true lbls in
|
2014-10-03 08:24:50 -07:00
|
|
|
let rep =
|
2016-05-25 07:29:05 -07:00
|
|
|
if unbox then Record_unboxed false
|
|
|
|
else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls'
|
2014-10-03 08:24:50 -07:00
|
|
|
then Record_float
|
|
|
|
else Record_regular
|
|
|
|
in
|
|
|
|
Ttype_record lbls, Type_record(lbls', rep)
|
2014-05-04 16:08:45 -07:00
|
|
|
| Ptype_open -> Ttype_open, Type_open
|
2012-05-30 07:52:37 -07:00
|
|
|
in
|
|
|
|
let (tman, man) = match sdecl.ptype_manifest with
|
|
|
|
None -> None, None
|
|
|
|
| Some sty ->
|
|
|
|
let no_row = not (is_fixed_type sdecl) in
|
|
|
|
let cty = transl_simple_type env no_row sty in
|
|
|
|
Some cty, Some cty.ctyp_type
|
|
|
|
in
|
|
|
|
let decl =
|
|
|
|
{ type_params = params;
|
|
|
|
type_arity = List.length params;
|
|
|
|
type_kind = kind;
|
|
|
|
type_private = sdecl.ptype_private;
|
|
|
|
type_manifest = man;
|
2013-05-03 06:38:30 -07:00
|
|
|
type_variance = List.map (fun _ -> Variance.full) params;
|
2018-02-12 08:37:35 -08:00
|
|
|
type_is_newtype = false;
|
2018-09-26 15:14:43 -07:00
|
|
|
type_expansion_scope = Btype.lowest_level;
|
2012-05-30 07:52:37 -07:00
|
|
|
type_loc = sdecl.ptype_loc;
|
2013-09-27 03:54:55 -07:00
|
|
|
type_attributes = sdecl.ptype_attributes;
|
2015-05-27 07:30:33 -07:00
|
|
|
type_immediate = false;
|
2016-05-25 07:29:05 -07:00
|
|
|
type_unboxed = unboxed_status;
|
2012-05-30 07:52:37 -07:00
|
|
|
} in
|
2000-05-23 23:19:39 -07:00
|
|
|
|
|
|
|
(* Check constraints *)
|
2012-05-30 07:52:37 -07:00
|
|
|
List.iter
|
|
|
|
(fun (cty, cty', loc) ->
|
|
|
|
let ty = cty.ctyp_type in
|
|
|
|
let ty' = cty'.ctyp_type in
|
|
|
|
try Ctype.unify env ty ty' with Ctype.Unify tr ->
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, Inconsistent_constraint (env, tr))))
|
2012-05-30 07:52:37 -07:00
|
|
|
cstrs;
|
|
|
|
Ctype.end_def ();
|
2010-01-20 08:26:46 -08:00
|
|
|
(* Add abstract row *)
|
2012-05-30 07:52:37 -07:00
|
|
|
if is_fixed_type sdecl then begin
|
2016-05-12 00:56:34 -07:00
|
|
|
let p =
|
2012-05-30 07:52:37 -07:00
|
|
|
try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env
|
|
|
|
with Not_found -> assert false in
|
|
|
|
set_fixed_row env sdecl.ptype_loc p decl
|
|
|
|
end;
|
2010-01-20 08:26:46 -08:00
|
|
|
(* Check for cyclic abbreviations *)
|
2012-05-30 07:52:37 -07:00
|
|
|
begin match decl.type_manifest with None -> ()
|
|
|
|
| Some ty ->
|
|
|
|
if Ctype.cyclic_abbrev env id ty then
|
2013-03-06 03:47:59 -08:00
|
|
|
raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt));
|
2012-05-30 07:52:37 -07:00
|
|
|
end;
|
2013-03-25 11:20:11 -07:00
|
|
|
{
|
|
|
|
typ_id = id;
|
|
|
|
typ_name = sdecl.ptype_name;
|
2014-05-04 16:08:45 -07:00
|
|
|
typ_params = tparams;
|
2012-05-30 07:52:37 -07:00
|
|
|
typ_type = decl;
|
|
|
|
typ_cstrs = cstrs;
|
|
|
|
typ_loc = sdecl.ptype_loc;
|
|
|
|
typ_manifest = tman;
|
|
|
|
typ_kind = tkind;
|
|
|
|
typ_private = sdecl.ptype_private;
|
2013-03-25 07:16:07 -07:00
|
|
|
typ_attributes = sdecl.ptype_attributes;
|
2013-03-25 11:20:11 -07:00
|
|
|
}
|
1997-02-20 12:39:02 -08:00
|
|
|
|
|
|
|
(* Generalize a type declaration *)
|
|
|
|
|
|
|
|
let generalize_decl decl =
|
|
|
|
List.iter Ctype.generalize decl.type_params;
|
2014-10-03 08:24:50 -07:00
|
|
|
Btype.iter_type_expr_kind Ctype.generalize decl.type_kind;
|
1996-04-22 04:15:41 -07:00
|
|
|
begin match decl.type_manifest with
|
2003-05-01 15:22:37 -07:00
|
|
|
| None -> ()
|
1996-04-22 04:15:41 -07:00
|
|
|
| Some ty -> Ctype.generalize ty
|
1997-02-20 12:39:02 -08:00
|
|
|
end
|
|
|
|
|
2000-05-23 23:19:39 -07:00
|
|
|
(* Check that all constraints are enforced *)
|
|
|
|
|
2010-11-07 22:59:46 -08:00
|
|
|
module TypeSet = Btype.TypeSet
|
2014-08-22 06:45:02 -07:00
|
|
|
module TypeMap = Btype.TypeMap
|
2000-05-24 01:06:33 -07:00
|
|
|
|
2003-06-28 03:46:32 -07:00
|
|
|
let rec check_constraints_rec env loc visited ty =
|
2000-05-23 23:19:39 -07:00
|
|
|
let ty = Ctype.repr ty in
|
2000-05-24 01:06:33 -07:00
|
|
|
if TypeSet.mem ty !visited then () else begin
|
|
|
|
visited := TypeSet.add ty !visited;
|
2000-05-23 23:19:39 -07:00
|
|
|
match ty.desc with
|
|
|
|
| Tconstr (path, args, _) ->
|
|
|
|
let args' = List.map (fun _ -> Ctype.newvar ()) args in
|
2000-05-24 19:09:13 -07:00
|
|
|
let ty' = Ctype.newconstr path args' in
|
2003-06-28 03:46:32 -07:00
|
|
|
begin try Ctype.enforce_constraints env ty'
|
2000-05-23 23:19:39 -07:00
|
|
|
with Ctype.Unify _ -> assert false
|
2001-09-28 15:55:27 -07:00
|
|
|
| Not_found -> raise (Error(loc, Unavailable_type_constructor path))
|
2000-05-23 23:19:39 -07:00
|
|
|
end;
|
2003-06-30 01:04:42 -07:00
|
|
|
if not (Ctype.matches env ty ty') then
|
|
|
|
raise (Error(loc, Constraint_failed (ty, ty')));
|
2003-06-28 03:46:32 -07:00
|
|
|
List.iter (check_constraints_rec env loc visited) args
|
2002-04-18 00:27:47 -07:00
|
|
|
| Tpoly (ty, tl) ->
|
|
|
|
let _, ty = Ctype.instance_poly false tl ty in
|
2003-06-28 03:46:32 -07:00
|
|
|
check_constraints_rec env loc visited ty
|
2000-05-23 23:19:39 -07:00
|
|
|
| _ ->
|
2003-06-28 03:46:32 -07:00
|
|
|
Btype.iter_type_expr (check_constraints_rec env loc visited) ty
|
2000-05-24 01:06:33 -07:00
|
|
|
end
|
2000-05-23 23:19:39 -07:00
|
|
|
|
2014-10-03 08:30:39 -07:00
|
|
|
let check_constraints_labels env visited l pl =
|
|
|
|
let rec get_loc name = function
|
|
|
|
[] -> assert false
|
|
|
|
| pld :: tl ->
|
|
|
|
if name = pld.pld_name.txt then pld.pld_type.ptyp_loc
|
|
|
|
else get_loc name tl
|
|
|
|
in
|
|
|
|
List.iter
|
|
|
|
(fun {Types.ld_id=name; ld_type=ty} ->
|
|
|
|
check_constraints_rec env (get_loc (Ident.name name) pl) visited ty)
|
|
|
|
l
|
|
|
|
|
2013-03-06 03:47:59 -08:00
|
|
|
let check_constraints env sdecl (_, decl) =
|
2000-05-24 01:06:33 -07:00
|
|
|
let visited = ref TypeSet.empty in
|
2003-07-02 02:14:35 -07:00
|
|
|
begin match decl.type_kind with
|
2000-05-23 23:19:39 -07:00
|
|
|
| Type_abstract -> ()
|
2007-10-09 03:29:37 -07:00
|
|
|
| Type_variant l ->
|
2012-05-29 06:41:14 -07:00
|
|
|
let find_pl = function
|
2007-10-09 03:29:37 -07:00
|
|
|
Ptype_variant pl -> pl
|
2014-05-04 16:08:45 -07:00
|
|
|
| Ptype_record _ | Ptype_abstract | Ptype_open -> assert false
|
2000-05-23 23:19:39 -07:00
|
|
|
in
|
2003-02-27 22:59:19 -08:00
|
|
|
let pl = find_pl sdecl.ptype_kind in
|
2013-04-22 17:18:15 -07:00
|
|
|
let pl_index =
|
2013-07-16 06:34:30 -07:00
|
|
|
let foldf acc x =
|
2018-07-23 05:19:41 -07:00
|
|
|
String.Map.add x.pcd_name.txt x acc
|
2013-04-22 17:18:15 -07:00
|
|
|
in
|
2018-07-23 05:19:41 -07:00
|
|
|
List.fold_left foldf String.Map.empty pl
|
2013-04-22 17:18:15 -07:00
|
|
|
in
|
2000-05-23 23:19:39 -07:00
|
|
|
List.iter
|
2014-10-03 08:30:39 -07:00
|
|
|
(fun {Types.cd_id=name; cd_args; cd_res} ->
|
|
|
|
let {pcd_args; pcd_res; _} =
|
2018-07-23 05:19:41 -07:00
|
|
|
try String.Map.find (Ident.name name) pl_index
|
2004-10-06 06:06:11 -07:00
|
|
|
with Not_found -> assert false in
|
2014-10-14 08:51:30 -07:00
|
|
|
begin match cd_args, pcd_args with
|
|
|
|
| Cstr_tuple tyl, Pcstr_tuple styl ->
|
|
|
|
List.iter2
|
|
|
|
(fun sty ty ->
|
|
|
|
check_constraints_rec env sty.ptyp_loc visited ty)
|
|
|
|
styl tyl
|
|
|
|
| Cstr_record tyl, Pcstr_record styl ->
|
|
|
|
check_constraints_labels env visited tyl styl
|
|
|
|
| _ -> assert false
|
|
|
|
end;
|
2014-10-03 08:30:39 -07:00
|
|
|
match pcd_res, cd_res with
|
2012-07-30 11:04:46 -07:00
|
|
|
| Some sr, Some r ->
|
|
|
|
check_constraints_rec env sr.ptyp_loc visited r
|
|
|
|
| _ ->
|
|
|
|
() )
|
|
|
|
l
|
2007-10-09 03:29:37 -07:00
|
|
|
| Type_record (l, _) ->
|
2012-05-29 06:41:14 -07:00
|
|
|
let find_pl = function
|
2007-10-09 03:29:37 -07:00
|
|
|
Ptype_record pl -> pl
|
2014-05-04 16:08:45 -07:00
|
|
|
| Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false
|
2000-05-23 23:19:39 -07:00
|
|
|
in
|
2003-02-27 22:59:19 -08:00
|
|
|
let pl = find_pl sdecl.ptype_kind in
|
2014-10-03 08:30:39 -07:00
|
|
|
check_constraints_labels env visited l pl
|
2014-05-04 16:08:45 -07:00
|
|
|
| Type_open -> ()
|
2003-07-02 02:14:35 -07:00
|
|
|
end;
|
2000-05-23 23:19:39 -07:00
|
|
|
begin match decl.type_manifest with
|
|
|
|
| None -> ()
|
|
|
|
| Some ty ->
|
|
|
|
let sty =
|
|
|
|
match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
|
|
|
|
in
|
2003-06-28 03:46:32 -07:00
|
|
|
check_constraints_rec env sty.ptyp_loc visited ty
|
2000-05-23 23:19:39 -07:00
|
|
|
end
|
|
|
|
|
1997-02-20 12:39:02 -08:00
|
|
|
(*
|
|
|
|
If both a variant/record definition and a type equation are given,
|
|
|
|
need to check that the equation refers to a type of the same kind
|
|
|
|
with the same constructors and labels.
|
|
|
|
*)
|
2019-04-18 18:57:55 -07:00
|
|
|
let check_coherence env loc dpath decl =
|
1997-02-20 12:39:02 -08:00
|
|
|
match decl with
|
2014-05-04 16:08:45 -07:00
|
|
|
{ type_kind = (Type_variant _ | Type_record _| Type_open);
|
|
|
|
type_manifest = Some ty } ->
|
1997-02-20 12:39:02 -08:00
|
|
|
begin match (Ctype.repr ty).desc with
|
1996-04-22 04:15:41 -07:00
|
|
|
Tconstr(path, args, _) ->
|
1995-11-03 05:23:03 -08:00
|
|
|
begin try
|
|
|
|
let decl' = Env.find_type path env in
|
2010-05-20 20:36:52 -07:00
|
|
|
let err =
|
|
|
|
if List.length args <> List.length decl.type_params
|
2018-08-08 09:07:53 -07:00
|
|
|
then Some Includecore.Arity
|
2010-05-20 20:36:52 -07:00
|
|
|
else if not (Ctype.equal env false args decl.type_params)
|
2018-08-08 09:07:53 -07:00
|
|
|
then Some Includecore.Constraint
|
2010-05-20 20:36:52 -07:00
|
|
|
else
|
2017-05-09 04:17:41 -07:00
|
|
|
Includecore.type_declarations ~loc ~equality:true env
|
2018-03-14 09:57:31 -07:00
|
|
|
~mark:true
|
2012-04-12 10:21:39 -07:00
|
|
|
(Path.last path)
|
2010-05-20 20:36:52 -07:00
|
|
|
decl'
|
2019-04-18 18:57:55 -07:00
|
|
|
dpath
|
2010-05-20 20:36:52 -07:00
|
|
|
(Subst.type_declaration
|
2019-04-18 18:57:55 -07:00
|
|
|
(Subst.add_type_path dpath path Subst.identity) decl)
|
2010-05-20 20:36:52 -07:00
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
if err <> None then
|
2013-05-03 07:40:11 -07:00
|
|
|
raise(Error(loc, Definition_mismatch (ty, err)))
|
1995-11-03 05:23:03 -08:00
|
|
|
with Not_found ->
|
2013-05-03 07:40:11 -07:00
|
|
|
raise(Error(loc, Unavailable_type_constructor path))
|
1995-11-03 05:23:03 -08:00
|
|
|
end
|
2018-08-08 09:07:53 -07:00
|
|
|
| _ -> raise(Error(loc, Definition_mismatch (ty, None)))
|
1995-11-03 05:23:03 -08:00
|
|
|
end
|
|
|
|
| _ -> ()
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2013-07-16 06:34:30 -07:00
|
|
|
let check_abbrev env sdecl (id, decl) =
|
2019-04-18 18:57:55 -07:00
|
|
|
check_coherence env sdecl.ptype_loc (Path.Pident id) decl
|
2013-05-03 07:40:11 -07:00
|
|
|
|
2012-06-14 03:42:56 -07:00
|
|
|
(* Check that recursion is well-founded *)
|
|
|
|
|
2014-08-22 06:45:02 -07:00
|
|
|
let check_well_founded env loc path to_check ty =
|
|
|
|
let visited = ref TypeMap.empty in
|
2016-07-05 02:04:20 -07:00
|
|
|
let rec check ty0 parents ty =
|
2014-08-22 06:45:02 -07:00
|
|
|
let ty = Btype.repr ty in
|
2016-07-05 02:04:20 -07:00
|
|
|
if TypeSet.mem ty parents then begin
|
2014-08-22 06:45:02 -07:00
|
|
|
(*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*)
|
|
|
|
if match ty0.desc with
|
|
|
|
| Tconstr (p, _, _) -> Path.same p path
|
|
|
|
| _ -> false
|
|
|
|
then raise (Error (loc, Recursive_abbrev (Path.name path)))
|
|
|
|
else raise (Error (loc, Cycle_in_def (Path.name path, ty0)))
|
|
|
|
end;
|
2016-07-05 02:04:20 -07:00
|
|
|
let (fini, parents) =
|
2014-08-22 06:45:02 -07:00
|
|
|
try
|
|
|
|
let prev = TypeMap.find ty !visited in
|
2016-07-05 02:04:20 -07:00
|
|
|
if TypeSet.subset parents prev then (true, parents) else
|
|
|
|
(false, TypeSet.union parents prev)
|
2014-08-22 06:45:02 -07:00
|
|
|
with Not_found ->
|
2016-07-05 02:04:20 -07:00
|
|
|
(false, parents)
|
2014-08-22 06:45:02 -07:00
|
|
|
in
|
2016-07-05 02:04:20 -07:00
|
|
|
if fini then () else
|
|
|
|
let rec_ok =
|
2014-08-22 06:45:02 -07:00
|
|
|
match ty.desc with
|
2016-07-05 02:04:20 -07:00
|
|
|
Tconstr(p,_,_) ->
|
|
|
|
!Clflags.recursive_types && Ctype.is_contractive env p
|
|
|
|
| Tobject _ | Tvariant _ -> true
|
|
|
|
| _ -> !Clflags.recursive_types
|
|
|
|
in
|
|
|
|
let visited' = TypeMap.add ty parents !visited in
|
|
|
|
let arg_exn =
|
|
|
|
try
|
|
|
|
visited := visited';
|
|
|
|
let parents =
|
|
|
|
if rec_ok then TypeSet.empty else TypeSet.add ty parents in
|
|
|
|
Btype.iter_type_expr (check ty0 parents) ty;
|
|
|
|
None
|
|
|
|
with e ->
|
|
|
|
visited := visited'; Some e
|
|
|
|
in
|
|
|
|
match ty.desc with
|
|
|
|
| Tconstr(p, _, _) when arg_exn <> None || to_check p ->
|
2019-05-23 08:27:58 -07:00
|
|
|
if to_check p then Option.iter raise arg_exn
|
2016-07-05 02:04:20 -07:00
|
|
|
else Btype.iter_type_expr (check ty0 TypeSet.empty) ty;
|
|
|
|
begin try
|
2014-08-22 06:45:02 -07:00
|
|
|
let ty' = Ctype.try_expand_once_opt env ty in
|
2016-07-05 02:04:20 -07:00
|
|
|
let ty0 = if TypeSet.is_empty parents then ty else ty0 in
|
|
|
|
check ty0 (TypeSet.add ty parents) ty'
|
|
|
|
with
|
2019-05-23 08:27:58 -07:00
|
|
|
Ctype.Cannot_expand -> Option.iter raise arg_exn
|
2016-07-05 02:04:20 -07:00
|
|
|
end
|
2019-05-23 08:27:58 -07:00
|
|
|
| _ -> Option.iter raise arg_exn
|
2014-08-22 06:45:02 -07:00
|
|
|
in
|
2016-07-05 02:04:20 -07:00
|
|
|
let snap = Btype.snapshot () in
|
|
|
|
try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty
|
|
|
|
with Ctype.Unify _ ->
|
|
|
|
(* Will be detected by check_recursion *)
|
|
|
|
Btype.backtrack snap
|
2014-08-22 06:45:02 -07:00
|
|
|
|
|
|
|
let check_well_founded_manifest env loc path decl =
|
|
|
|
if decl.type_manifest = None then () else
|
|
|
|
let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in
|
|
|
|
check_well_founded env loc path (Path.same path) (Ctype.newconstr path args)
|
|
|
|
|
|
|
|
let check_well_founded_decl env loc path decl to_check =
|
|
|
|
let open Btype in
|
|
|
|
let it =
|
|
|
|
{type_iterators with
|
|
|
|
it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in
|
2018-09-13 07:39:59 -07:00
|
|
|
it.it_type_declaration it (Ctype.generic_instance_declaration decl)
|
2012-06-14 03:42:56 -07:00
|
|
|
|
1996-04-22 04:15:41 -07:00
|
|
|
(* Check for ill-defined abbrevs *)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2003-07-03 03:00:53 -07:00
|
|
|
let check_recursion env loc path decl to_check =
|
|
|
|
(* to_check is true for potentially mutually recursive paths.
|
|
|
|
(path, decl) is the type declaration to be checked. *)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2012-06-14 03:42:56 -07:00
|
|
|
if decl.type_params = [] then () else
|
|
|
|
|
2003-07-03 03:00:53 -07:00
|
|
|
let visited = ref [] in
|
2000-05-24 19:09:13 -07:00
|
|
|
|
2003-07-03 03:00:53 -07:00
|
|
|
let rec check_regular cpath args prev_exp ty =
|
|
|
|
let ty = Ctype.repr ty in
|
|
|
|
if not (List.memq ty !visited) then begin
|
|
|
|
visited := ty :: !visited;
|
|
|
|
match ty.desc with
|
|
|
|
| Tconstr(path', args', _) ->
|
|
|
|
if Path.same path path' then begin
|
|
|
|
if not (Ctype.equal env false args args') then
|
2005-08-13 13:59:37 -07:00
|
|
|
raise (Error(loc,
|
2003-07-03 03:00:53 -07:00
|
|
|
Parameters_differ(cpath, ty, Ctype.newconstr path args)))
|
|
|
|
end
|
|
|
|
(* Attempt to expand a type abbreviation if:
|
2003-07-03 07:35:35 -07:00
|
|
|
1- [to_check path'] holds
|
|
|
|
(otherwise the expansion cannot involve [path]);
|
2003-07-03 03:00:53 -07:00
|
|
|
2- we haven't expanded this type constructor before
|
2005-08-13 13:59:37 -07:00
|
|
|
(otherwise we could loop if [path'] is itself
|
2003-07-03 03:00:53 -07:00
|
|
|
a non-regular abbreviation). *)
|
|
|
|
else if to_check path' && not (List.mem path' prev_exp) then begin
|
|
|
|
try
|
|
|
|
(* Attempt expansion *)
|
2011-11-24 01:02:48 -08:00
|
|
|
let (params0, body0, _) = Env.find_type_expansion path' env in
|
2005-08-13 13:59:37 -07:00
|
|
|
let (params, body) =
|
2003-11-06 16:19:08 -08:00
|
|
|
Ctype.instance_parameterized_type params0 body0 in
|
2003-07-03 03:00:53 -07:00
|
|
|
begin
|
|
|
|
try List.iter2 (Ctype.unify env) params args'
|
2003-11-06 16:19:08 -08:00
|
|
|
with Ctype.Unify _ ->
|
|
|
|
raise (Error(loc, Constraint_failed
|
|
|
|
(ty, Ctype.newconstr path' params0)));
|
2003-07-03 03:00:53 -07:00
|
|
|
end;
|
|
|
|
check_regular path' args (path' :: prev_exp) body
|
|
|
|
with Not_found -> ()
|
2001-01-08 16:18:52 -08:00
|
|
|
end;
|
2003-07-03 03:00:53 -07:00
|
|
|
List.iter (check_regular cpath args prev_exp) args'
|
|
|
|
| Tpoly (ty, tl) ->
|
2012-05-31 22:12:44 -07:00
|
|
|
let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in
|
2003-07-03 03:00:53 -07:00
|
|
|
check_regular cpath args prev_exp ty
|
|
|
|
| _ ->
|
|
|
|
Btype.iter_type_expr (check_regular cpath args prev_exp) ty
|
|
|
|
end in
|
2000-05-24 19:09:13 -07:00
|
|
|
|
2019-05-23 08:27:58 -07:00
|
|
|
Option.iter
|
2012-06-14 03:42:56 -07:00
|
|
|
(fun body ->
|
2000-05-24 19:09:13 -07:00
|
|
|
let (args, body) =
|
2012-05-31 22:12:44 -07:00
|
|
|
Ctype.instance_parameterized_type
|
|
|
|
~keep_names:true decl.type_params body in
|
2012-06-14 03:42:56 -07:00
|
|
|
check_regular path args [] body)
|
|
|
|
decl.type_manifest
|
2003-07-03 03:00:53 -07:00
|
|
|
|
2014-08-22 06:45:02 -07:00
|
|
|
let check_abbrev_recursion env id_loc_list to_check tdecl =
|
2012-05-30 07:52:37 -07:00
|
|
|
let decl = tdecl.typ_type in
|
2013-03-25 11:20:11 -07:00
|
|
|
let id = tdecl.typ_id in
|
2014-08-22 06:45:02 -07:00
|
|
|
check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check
|
2000-05-24 19:09:13 -07:00
|
|
|
|
2010-04-29 23:26:51 -07:00
|
|
|
(* Check multiple declarations of labels/constructors *)
|
2010-04-29 22:59:40 -07:00
|
|
|
|
2013-03-06 03:47:59 -08:00
|
|
|
let check_duplicates sdecl_list =
|
2010-04-29 23:26:51 -07:00
|
|
|
let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in
|
2010-04-29 22:59:40 -07:00
|
|
|
List.iter
|
2013-03-06 03:47:59 -08:00
|
|
|
(fun sdecl -> match sdecl.ptype_kind with
|
2010-04-29 22:59:40 -07:00
|
|
|
Ptype_variant cl ->
|
|
|
|
List.iter
|
2013-03-04 07:35:47 -08:00
|
|
|
(fun pcd ->
|
2010-04-29 22:59:40 -07:00
|
|
|
try
|
2013-03-04 07:35:47 -08:00
|
|
|
let name' = Hashtbl.find constrs pcd.pcd_name.txt in
|
|
|
|
Location.prerr_warning pcd.pcd_loc
|
2010-04-29 23:26:51 -07:00
|
|
|
(Warnings.Duplicate_definitions
|
2014-08-22 06:45:02 -07:00
|
|
|
("constructor", pcd.pcd_name.txt, name',
|
|
|
|
sdecl.ptype_name.txt))
|
|
|
|
with Not_found ->
|
|
|
|
Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt)
|
2010-04-29 22:59:40 -07:00
|
|
|
cl
|
|
|
|
| Ptype_record fl ->
|
|
|
|
List.iter
|
2013-03-06 05:51:18 -08:00
|
|
|
(fun {pld_name=cname;pld_loc=loc} ->
|
2010-04-29 22:59:40 -07:00
|
|
|
try
|
2012-05-30 07:52:37 -07:00
|
|
|
let name' = Hashtbl.find labels cname.txt in
|
2010-04-29 23:26:51 -07:00
|
|
|
Location.prerr_warning loc
|
2012-05-31 01:07:31 -07:00
|
|
|
(Warnings.Duplicate_definitions
|
2013-03-06 03:47:59 -08:00
|
|
|
("label", cname.txt, name', sdecl.ptype_name.txt))
|
|
|
|
with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt)
|
2010-04-29 22:59:40 -07:00
|
|
|
fl
|
2014-05-04 16:08:45 -07:00
|
|
|
| Ptype_abstract -> ()
|
|
|
|
| Ptype_open -> ())
|
2013-03-06 03:47:59 -08:00
|
|
|
sdecl_list
|
2010-04-29 22:59:40 -07:00
|
|
|
|
2006-11-01 17:10:04 -08:00
|
|
|
(* Force recursion to go through id for private types*)
|
|
|
|
let name_recursion sdecl id decl =
|
|
|
|
match decl with
|
2007-10-09 03:29:37 -07:00
|
|
|
| { type_kind = Type_abstract;
|
|
|
|
type_manifest = Some ty;
|
|
|
|
type_private = Private; } when is_fixed_type sdecl ->
|
|
|
|
let ty = Ctype.repr ty in
|
|
|
|
let ty' = Btype.newty2 ty.level ty.desc in
|
|
|
|
if Ctype.deep_occur ty ty' then
|
|
|
|
let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in
|
|
|
|
Btype.link_type ty (Btype.newty2 ty.level td);
|
|
|
|
{decl with type_manifest = Some ty'}
|
|
|
|
else decl
|
2006-11-01 17:10:04 -08:00
|
|
|
| _ -> decl
|
|
|
|
|
2018-11-18 06:56:53 -08:00
|
|
|
let name_recursion_decls sdecls decls =
|
|
|
|
List.map2 (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl))
|
|
|
|
sdecls decls
|
|
|
|
|
2018-10-04 10:08:39 -07:00
|
|
|
(* Warn on definitions of type "type foo = ()" which redefine a different unit
|
|
|
|
type and are likely a mistake. *)
|
|
|
|
let check_redefined_unit (td: Parsetree.type_declaration) =
|
|
|
|
let open Parsetree in
|
|
|
|
let is_unit_constructor cd = cd.pcd_name.txt = "()" in
|
|
|
|
match td with
|
|
|
|
| { ptype_name = { txt = name };
|
|
|
|
ptype_manifest = None;
|
|
|
|
ptype_kind = Ptype_variant [ cd ] }
|
|
|
|
when is_unit_constructor cd ->
|
|
|
|
Location.prerr_warning td.ptype_loc (Warnings.Redefining_unit name)
|
|
|
|
| _ ->
|
|
|
|
()
|
|
|
|
|
2018-11-20 07:10:19 -08:00
|
|
|
let add_types_to_env decls env =
|
|
|
|
List.fold_right
|
|
|
|
(fun (id, decl) env -> add_type ~check:true id decl env)
|
|
|
|
decls env
|
|
|
|
|
2015-03-13 04:08:30 -07:00
|
|
|
(* Translate a set of type declarations, mutually recursive or not *)
|
|
|
|
let transl_type_decl env rec_flag sdecl_list =
|
2018-10-04 10:08:39 -07:00
|
|
|
List.iter check_redefined_unit sdecl_list;
|
2005-03-22 19:08:37 -08:00
|
|
|
(* Add dummy types for fixed rows *)
|
2013-03-06 03:47:59 -08:00
|
|
|
let fixed_types = List.filter is_fixed_type sdecl_list in
|
|
|
|
let sdecl_list =
|
2005-03-22 19:08:37 -08:00
|
|
|
List.map
|
2013-03-06 03:47:59 -08:00
|
|
|
(fun sdecl ->
|
2014-08-22 06:45:02 -07:00
|
|
|
let ptype_name =
|
|
|
|
mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in
|
|
|
|
{sdecl with
|
|
|
|
ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None})
|
2005-03-22 19:08:37 -08:00
|
|
|
fixed_types
|
2013-03-06 03:47:59 -08:00
|
|
|
@ sdecl_list
|
2005-03-22 19:08:37 -08:00
|
|
|
in
|
2014-03-31 05:20:22 -07:00
|
|
|
|
1997-02-20 12:39:02 -08:00
|
|
|
(* Create identifiers. *)
|
2018-09-14 05:04:49 -07:00
|
|
|
let scope = Ctype.create_scope () in
|
1997-02-20 12:39:02 -08:00
|
|
|
let id_list =
|
2018-08-28 09:07:01 -07:00
|
|
|
List.map (fun sdecl -> Ident.create_scoped ~scope sdecl.ptype_name.txt)
|
|
|
|
sdecl_list
|
1997-02-20 12:39:02 -08:00
|
|
|
in
|
|
|
|
Ctype.begin_def();
|
|
|
|
(* Enter types. *)
|
2015-03-13 04:08:30 -07:00
|
|
|
let temp_env =
|
2016-12-25 23:55:43 -08:00
|
|
|
List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in
|
1997-02-20 12:39:02 -08:00
|
|
|
(* Translate each declaration. *)
|
2011-12-28 06:20:53 -08:00
|
|
|
let current_slot = ref None in
|
|
|
|
let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
|
|
|
|
let id_slots id =
|
2015-05-01 14:45:10 -07:00
|
|
|
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
|
|
|
|
(fun old_callback ->
|
|
|
|
match !current_slot with
|
|
|
|
| Some slot -> slot := (name, td) :: !slot
|
|
|
|
| None ->
|
2018-03-14 09:57:31 -07:00
|
|
|
List.iter (fun (name, d) -> Env.mark_type_used name d)
|
2015-05-01 14:45:10 -07:00
|
|
|
(get_ref slot);
|
|
|
|
old_callback ()
|
|
|
|
);
|
|
|
|
id, Some slot
|
|
|
|
| Asttypes.Recursive | Asttypes.Nonrecursive ->
|
|
|
|
id, None
|
2011-12-28 06:20:53 -08:00
|
|
|
in
|
2012-04-25 00:51:29 -07:00
|
|
|
let transl_declaration name_sdecl (id, slot) =
|
2017-07-17 15:02:26 -07:00
|
|
|
current_slot := slot;
|
|
|
|
Builtin_attributes.warning_scope
|
|
|
|
name_sdecl.ptype_attributes
|
|
|
|
(fun () -> transl_declaration temp_env name_sdecl id)
|
|
|
|
in
|
2012-05-30 07:52:37 -07:00
|
|
|
let tdecls =
|
2013-03-06 03:47:59 -08:00
|
|
|
List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in
|
2012-05-31 01:07:31 -07:00
|
|
|
let decls =
|
2013-03-25 11:20:11 -07:00
|
|
|
List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
|
2011-12-28 06:20:53 -08:00
|
|
|
current_slot := None;
|
2010-04-29 22:59:40 -07:00
|
|
|
(* Check for duplicates *)
|
2013-03-06 03:47:59 -08:00
|
|
|
check_duplicates sdecl_list;
|
1997-02-20 12:39:02 -08:00
|
|
|
(* Build the final env. *)
|
2018-11-06 05:36:22 -08:00
|
|
|
let new_env = add_types_to_env decls env in
|
2000-08-03 20:29:42 -07:00
|
|
|
(* Update stubs *)
|
2015-03-13 04:08:30 -07:00
|
|
|
begin match rec_flag with
|
|
|
|
| Asttypes.Nonrecursive -> ()
|
|
|
|
| Asttypes.Recursive ->
|
|
|
|
List.iter2
|
2018-11-06 05:36:22 -08:00
|
|
|
(fun id sdecl -> update_type temp_env new_env id sdecl.ptype_loc)
|
2015-03-13 04:08:30 -07:00
|
|
|
id_list sdecl_list
|
|
|
|
end;
|
2000-08-03 20:29:42 -07:00
|
|
|
(* Generalize type declarations. *)
|
|
|
|
Ctype.end_def();
|
|
|
|
List.iter (fun (_, decl) -> generalize_decl decl) decls;
|
2003-07-03 03:00:53 -07:00
|
|
|
(* Check for ill-formed abbrevs *)
|
|
|
|
let id_loc_list =
|
2013-03-06 03:47:59 -08:00
|
|
|
List.map2 (fun id sdecl -> (id, sdecl.ptype_loc))
|
|
|
|
id_list sdecl_list
|
2003-07-03 03:00:53 -07:00
|
|
|
in
|
2012-06-14 03:42:56 -07:00
|
|
|
List.iter (fun (id, decl) ->
|
2018-11-06 05:36:22 -08:00
|
|
|
check_well_founded_manifest new_env (List.assoc id id_loc_list)
|
2014-08-22 06:45:02 -07:00
|
|
|
(Path.Pident id) decl)
|
2012-06-14 03:42:56 -07:00
|
|
|
decls;
|
2014-08-22 06:45:02 -07:00
|
|
|
let to_check =
|
|
|
|
function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in
|
|
|
|
List.iter (fun (id, decl) ->
|
2018-11-06 05:36:22 -08:00
|
|
|
check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
|
2014-08-22 06:45:02 -07:00
|
|
|
decl to_check)
|
|
|
|
decls;
|
2018-11-06 05:36:22 -08:00
|
|
|
List.iter (check_abbrev_recursion new_env id_loc_list to_check) tdecls;
|
2017-08-10 03:59:23 -07:00
|
|
|
(* Check that all type variables are closed *)
|
1998-06-24 12:22:26 -07:00
|
|
|
List.iter2
|
2013-03-25 11:20:11 -07:00
|
|
|
(fun sdecl tdecl ->
|
2012-05-30 07:52:37 -07:00
|
|
|
let decl = tdecl.typ_type in
|
1998-06-24 12:22:26 -07:00
|
|
|
match Ctype.closed_type_decl decl with
|
2005-08-13 13:59:37 -07:00
|
|
|
Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
|
1998-06-24 12:22:26 -07:00
|
|
|
| None -> ())
|
2013-03-06 03:47:59 -08:00
|
|
|
sdecl_list tdecls;
|
2000-05-23 23:19:39 -07:00
|
|
|
(* Check that constraints are enforced *)
|
2018-11-06 05:36:22 -08:00
|
|
|
List.iter2 (check_constraints new_env) sdecl_list decls;
|
2018-11-18 06:56:53 -08:00
|
|
|
(* Add type properties to declarations *)
|
2006-11-01 17:10:04 -08:00
|
|
|
let decls =
|
2018-11-20 07:10:19 -08:00
|
|
|
try
|
|
|
|
decls
|
|
|
|
|> name_recursion_decls sdecl_list
|
|
|
|
|> Typedecl_variance.update_decls env sdecl_list
|
2018-11-20 07:28:15 -08:00
|
|
|
|> Typedecl_immediacy.update_decls env
|
2018-11-20 07:10:19 -08:00
|
|
|
with
|
2018-11-20 07:28:15 -08:00
|
|
|
| Typedecl_variance.Error (loc, err) -> raise (Error (loc, Variance err))
|
|
|
|
| Typedecl_immediacy.Error (loc, err) -> raise (Error (loc, Immediacy err))
|
|
|
|
in
|
2018-11-06 05:36:22 -08:00
|
|
|
(* Compute the final environment with variance and immediacy *)
|
|
|
|
let final_env = add_types_to_env decls env in
|
2013-05-03 06:38:30 -07:00
|
|
|
(* Check re-exportation *)
|
2018-11-06 05:36:22 -08:00
|
|
|
List.iter2 (check_abbrev final_env) sdecl_list decls;
|
2013-05-03 06:38:30 -07:00
|
|
|
(* Keep original declaration *)
|
2013-03-25 11:20:11 -07:00
|
|
|
let final_decls =
|
|
|
|
List.map2
|
2016-03-09 02:40:16 -08:00
|
|
|
(fun tdecl (_id2, decl) ->
|
2013-03-25 11:20:11 -07:00
|
|
|
{ tdecl with typ_type = decl }
|
2018-11-06 05:36:22 -08:00
|
|
|
) tdecls decls
|
2013-03-25 11:20:11 -07:00
|
|
|
in
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Done *)
|
2000-09-06 03:21:07 -07:00
|
|
|
(final_decls, final_env)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2014-05-04 16:08:45 -07:00
|
|
|
(* Translating type extensions *)
|
2009-07-20 04:51:50 -07:00
|
|
|
|
2014-10-03 08:16:45 -07:00
|
|
|
let transl_extension_constructor env type_path type_params
|
2014-05-04 16:08:45 -07:00
|
|
|
typext_params priv sext =
|
2018-09-14 05:04:49 -07:00
|
|
|
let scope = Ctype.create_scope () in
|
2018-09-13 07:39:59 -07:00
|
|
|
let id = Ident.create_scoped ~scope sext.pext_name.txt in
|
2014-05-04 16:08:45 -07:00
|
|
|
let args, ret_type, kind =
|
|
|
|
match sext.pext_kind with
|
|
|
|
Pext_decl(sargs, sret_type) ->
|
2017-10-02 06:56:02 -07:00
|
|
|
let targs, tret_type, args, ret_type, _ =
|
2016-03-09 02:40:16 -08:00
|
|
|
make_constructor env type_path typext_params
|
2014-10-14 08:51:30 -07:00
|
|
|
sargs sret_type
|
2014-05-04 16:08:45 -07:00
|
|
|
in
|
|
|
|
args, ret_type, Text_decl(targs, tret_type)
|
|
|
|
| Pext_rebind lid ->
|
2016-08-04 01:50:27 -07:00
|
|
|
let cdescr = Typetexp.find_constructor env lid.loc lid.txt in
|
2014-05-04 16:08:45 -07:00
|
|
|
let usage =
|
|
|
|
if cdescr.cstr_private = Private || priv = Public
|
|
|
|
then Env.Positive else Env.Privatize
|
|
|
|
in
|
|
|
|
Env.mark_constructor usage env (Longident.last lid.txt) cdescr;
|
|
|
|
let (args, cstr_res) = Ctype.instance_constructor cdescr in
|
|
|
|
let res, ret_type =
|
|
|
|
if cdescr.cstr_generalized then
|
2018-02-12 08:37:35 -08:00
|
|
|
let params = Ctype.instance_list type_params in
|
2014-05-04 16:08:45 -07:00
|
|
|
let res = Ctype.newconstr type_path params in
|
|
|
|
let ret_type = Some (Ctype.newconstr type_path params) in
|
|
|
|
res, ret_type
|
|
|
|
else (Ctype.newconstr type_path typext_params), None
|
|
|
|
in
|
|
|
|
begin
|
|
|
|
try
|
|
|
|
Ctype.unify env cstr_res res
|
|
|
|
with Ctype.Unify trace ->
|
|
|
|
raise (Error(lid.loc,
|
|
|
|
Rebind_wrong_type(lid.txt, env, trace)))
|
|
|
|
end;
|
|
|
|
(* Remove "_" names from parameters used in the constructor *)
|
|
|
|
if not cdescr.cstr_generalized then begin
|
|
|
|
let vars =
|
|
|
|
Ctype.free_variables (Btype.newgenty (Ttuple args))
|
|
|
|
in
|
|
|
|
List.iter
|
|
|
|
(function {desc = Tvar (Some "_")} as ty ->
|
|
|
|
if List.memq ty vars then ty.desc <- Tvar None
|
|
|
|
| _ -> ())
|
|
|
|
typext_params
|
|
|
|
end;
|
|
|
|
(* Ensure that constructor's type matches the type being extended *)
|
|
|
|
let cstr_type_path, cstr_type_params =
|
|
|
|
match cdescr.cstr_res.desc with
|
|
|
|
Tconstr (p, _, _) ->
|
|
|
|
let decl = Env.find_type p env in
|
|
|
|
p, decl.type_params
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
|
|
|
let cstr_types =
|
|
|
|
(Btype.newgenty
|
|
|
|
(Tconstr(cstr_type_path, cstr_type_params, ref Mnil)))
|
|
|
|
:: cstr_type_params
|
|
|
|
in
|
|
|
|
let ext_types =
|
|
|
|
(Btype.newgenty
|
|
|
|
(Tconstr(type_path, type_params, ref Mnil)))
|
|
|
|
:: type_params
|
|
|
|
in
|
|
|
|
if not (Ctype.equal env true cstr_types ext_types) then
|
|
|
|
raise (Error(lid.loc,
|
|
|
|
Rebind_mismatch(lid.txt, cstr_type_path, type_path)));
|
|
|
|
(* Disallow rebinding private constructors to non-private *)
|
|
|
|
begin
|
|
|
|
match cdescr.cstr_private, priv with
|
|
|
|
Private, Public ->
|
|
|
|
raise (Error(lid.loc, Rebind_private lid.txt))
|
|
|
|
| _ -> ()
|
|
|
|
end;
|
|
|
|
let path =
|
|
|
|
match cdescr.cstr_tag with
|
|
|
|
Cstr_extension(path, _) -> path
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
2014-10-14 08:51:30 -07:00
|
|
|
let args =
|
|
|
|
match cdescr.cstr_inlined with
|
|
|
|
| None ->
|
|
|
|
Types.Cstr_tuple args
|
|
|
|
| Some decl ->
|
|
|
|
let tl =
|
|
|
|
match args with
|
|
|
|
| [ {desc=Tconstr(_, tl, _)} ] -> tl
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
|
|
|
let decl = Ctype.instance_declaration decl in
|
|
|
|
assert (List.length decl.type_params = List.length tl);
|
|
|
|
List.iter2 (Ctype.unify env) decl.type_params tl;
|
|
|
|
let lbls =
|
|
|
|
match decl.type_kind with
|
2018-02-08 09:51:47 -08:00
|
|
|
| Type_record (lbls, Record_extension _) -> lbls
|
2014-10-14 08:51:30 -07:00
|
|
|
| _ -> assert false
|
|
|
|
in
|
|
|
|
Types.Cstr_record lbls
|
|
|
|
in
|
|
|
|
args, ret_type, Text_rebind(path, lid)
|
2014-05-04 16:08:45 -07:00
|
|
|
in
|
|
|
|
let ext =
|
|
|
|
{ ext_type_path = type_path;
|
|
|
|
ext_type_params = typext_params;
|
|
|
|
ext_args = args;
|
|
|
|
ext_ret_type = ret_type;
|
|
|
|
ext_private = priv;
|
|
|
|
Types.ext_loc = sext.pext_loc;
|
|
|
|
Types.ext_attributes = sext.pext_attributes; }
|
|
|
|
in
|
|
|
|
{ ext_id = id;
|
|
|
|
ext_name = sext.pext_name;
|
|
|
|
ext_type = ext;
|
|
|
|
ext_kind = kind;
|
|
|
|
Typedtree.ext_loc = sext.pext_loc;
|
|
|
|
Typedtree.ext_attributes = sext.pext_attributes; }
|
|
|
|
|
2017-07-18 02:04:35 -07:00
|
|
|
let transl_extension_constructor env type_path type_params
|
|
|
|
typext_params priv sext =
|
|
|
|
Builtin_attributes.warning_scope sext.pext_attributes
|
|
|
|
(fun () -> transl_extension_constructor env type_path type_params
|
|
|
|
typext_params priv sext)
|
|
|
|
|
2017-07-20 08:33:41 -07:00
|
|
|
let transl_type_extension extend env loc styext =
|
1995-05-04 03:15:53 -07:00
|
|
|
reset_type_variables();
|
1997-02-20 12:39:02 -08:00
|
|
|
Ctype.begin_def();
|
2014-05-04 16:08:45 -07:00
|
|
|
let (type_path, type_decl) =
|
2016-08-04 01:50:27 -07:00
|
|
|
let lid = styext.ptyext_path in
|
|
|
|
Typetexp.find_type env lid.loc lid.txt
|
2013-09-27 03:54:55 -07:00
|
|
|
in
|
2014-05-04 16:08:45 -07:00
|
|
|
begin
|
|
|
|
match type_decl.type_kind with
|
2017-07-20 08:33:41 -07:00
|
|
|
| Type_open -> begin
|
|
|
|
match type_decl.type_private with
|
|
|
|
| Private when extend -> begin
|
|
|
|
match
|
|
|
|
List.find
|
|
|
|
(function {pext_kind = Pext_decl _} -> true
|
|
|
|
| {pext_kind = Pext_rebind _} -> false)
|
|
|
|
styext.ptyext_constructors
|
|
|
|
with
|
|
|
|
| {pext_loc} ->
|
|
|
|
raise (Error(pext_loc, Cannot_extend_private_type type_path))
|
|
|
|
| exception Not_found -> ()
|
|
|
|
end
|
|
|
|
| _ -> ()
|
|
|
|
end
|
|
|
|
| _ ->
|
|
|
|
raise (Error(loc, Not_extensible_type type_path))
|
2014-05-04 16:08:45 -07:00
|
|
|
end;
|
|
|
|
let type_variance =
|
|
|
|
List.map (fun v ->
|
|
|
|
let (co, cn) = Variance.get_upper v in
|
|
|
|
(not cn, not co, false))
|
|
|
|
type_decl.type_variance
|
2013-03-25 11:42:45 -07:00
|
|
|
in
|
2014-05-04 16:08:45 -07:00
|
|
|
let err =
|
|
|
|
if type_decl.type_arity <> List.length styext.ptyext_params then
|
2018-08-08 09:07:53 -07:00
|
|
|
Some Includecore.Arity
|
2014-05-04 16:08:45 -07:00
|
|
|
else
|
|
|
|
if List.for_all2
|
|
|
|
(fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1))
|
|
|
|
type_variance
|
2018-11-20 07:10:19 -08:00
|
|
|
(Typedecl_variance.variance_of_params styext.ptyext_params)
|
2018-08-08 09:07:53 -07:00
|
|
|
then None else Some Includecore.Variance
|
2014-04-15 04:26:00 -07:00
|
|
|
in
|
2018-08-08 09:07:53 -07:00
|
|
|
begin match err with
|
|
|
|
| None -> ()
|
|
|
|
| Some err -> raise (Error(loc, Extension_mismatch (type_path, err)))
|
|
|
|
end;
|
2014-05-04 16:08:45 -07:00
|
|
|
let ttype_params = make_params env styext.ptyext_params in
|
|
|
|
let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
|
|
|
|
List.iter2 (Ctype.unify_var env)
|
2018-02-12 08:37:35 -08:00
|
|
|
(Ctype.instance_list type_decl.type_params)
|
2014-05-04 16:08:45 -07:00
|
|
|
type_params;
|
|
|
|
let constructors =
|
2014-10-03 08:16:45 -07:00
|
|
|
List.map (transl_extension_constructor env type_path
|
2014-05-04 16:08:45 -07:00
|
|
|
type_decl.type_params type_params styext.ptyext_private)
|
|
|
|
styext.ptyext_constructors
|
|
|
|
in
|
|
|
|
Ctype.end_def();
|
|
|
|
(* Generalize types *)
|
|
|
|
List.iter Ctype.generalize type_params;
|
|
|
|
List.iter
|
|
|
|
(fun ext ->
|
2014-10-14 08:51:30 -07:00
|
|
|
Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
|
2019-05-23 08:27:58 -07:00
|
|
|
Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
|
2014-05-04 16:08:45 -07:00
|
|
|
constructors;
|
2017-08-10 03:59:23 -07:00
|
|
|
(* Check that all type variables are closed *)
|
2014-05-04 16:08:45 -07:00
|
|
|
List.iter
|
|
|
|
(fun ext ->
|
|
|
|
match Ctype.closed_extension_constructor ext.ext_type with
|
2014-08-22 06:45:02 -07:00
|
|
|
Some ty ->
|
|
|
|
raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
|
2014-05-04 16:08:45 -07:00
|
|
|
| None -> ())
|
|
|
|
constructors;
|
|
|
|
(* Check variances are correct *)
|
|
|
|
List.iter
|
|
|
|
(fun ext->
|
2018-11-20 07:10:19 -08:00
|
|
|
(* Note that [loc] here is distinct from [type_decl.type_loc], which
|
|
|
|
makes the [loc] parameter to this function useful. [loc] is the
|
|
|
|
location of the extension, while [type_decl] points to the original
|
|
|
|
type declaration being extended. *)
|
|
|
|
try Typedecl_variance.check_variance_extension
|
|
|
|
env type_decl ext (type_variance, loc)
|
|
|
|
with Typedecl_variance.Error (loc, err) ->
|
|
|
|
raise (Error (loc, Variance err)))
|
2014-05-04 16:08:45 -07:00
|
|
|
constructors;
|
|
|
|
(* Add extension constructors to the environment *)
|
|
|
|
let newenv =
|
|
|
|
List.fold_left
|
|
|
|
(fun env ext ->
|
|
|
|
Env.add_extension ~check:true ext.ext_id ext.ext_type env)
|
|
|
|
env constructors
|
2014-04-15 04:26:00 -07:00
|
|
|
in
|
2014-05-04 16:08:45 -07:00
|
|
|
let tyext =
|
|
|
|
{ tyext_path = type_path;
|
|
|
|
tyext_txt = styext.ptyext_path;
|
|
|
|
tyext_params = ttype_params;
|
|
|
|
tyext_constructors = constructors;
|
|
|
|
tyext_private = styext.ptyext_private;
|
2018-07-14 14:10:39 -07:00
|
|
|
tyext_loc = styext.ptyext_loc;
|
2014-05-04 16:08:45 -07:00
|
|
|
tyext_attributes = styext.ptyext_attributes; }
|
2014-04-15 04:26:00 -07:00
|
|
|
in
|
2014-05-04 16:08:45 -07:00
|
|
|
(tyext, newenv)
|
|
|
|
|
2017-07-18 02:04:35 -07:00
|
|
|
let transl_type_extension extend env loc styext =
|
|
|
|
Builtin_attributes.warning_scope styext.ptyext_attributes
|
|
|
|
(fun () -> transl_type_extension extend env loc styext)
|
|
|
|
|
2014-05-04 16:08:45 -07:00
|
|
|
let transl_exception env sext =
|
|
|
|
reset_type_variables();
|
|
|
|
Ctype.begin_def();
|
|
|
|
let ext =
|
2014-10-03 08:16:45 -07:00
|
|
|
transl_extension_constructor env
|
2014-05-04 16:08:45 -07:00
|
|
|
Predef.path_exn [] [] Asttypes.Public sext
|
|
|
|
in
|
|
|
|
Ctype.end_def();
|
|
|
|
(* Generalize types *)
|
2014-10-14 08:51:30 -07:00
|
|
|
Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
|
2019-05-23 08:27:58 -07:00
|
|
|
Option.iter Ctype.generalize ext.ext_type.ext_ret_type;
|
2017-08-10 03:59:23 -07:00
|
|
|
(* Check that all type variables are closed *)
|
2014-05-04 16:08:45 -07:00
|
|
|
begin match Ctype.closed_extension_constructor ext.ext_type with
|
|
|
|
Some ty ->
|
|
|
|
raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
|
|
|
|
| None -> ()
|
|
|
|
end;
|
|
|
|
let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in
|
2018-04-06 10:02:46 -07:00
|
|
|
ext, newenv
|
|
|
|
|
|
|
|
let transl_type_exception env t =
|
2018-11-15 00:51:35 -08:00
|
|
|
Builtin_attributes.check_no_alert t.ptyexn_attributes;
|
2018-04-06 10:02:46 -07:00
|
|
|
let contructor, newenv =
|
|
|
|
Builtin_attributes.warning_scope t.ptyexn_attributes
|
|
|
|
(fun () ->
|
|
|
|
transl_exception env t.ptyexn_constructor
|
|
|
|
)
|
|
|
|
in
|
|
|
|
{tyexn_constructor = contructor;
|
2018-07-14 14:10:39 -07:00
|
|
|
tyexn_loc = t.ptyexn_loc;
|
2018-04-06 10:02:46 -07:00
|
|
|
tyexn_attributes = t.ptyexn_attributes}, newenv
|
|
|
|
|
2000-03-12 05:10:29 -08:00
|
|
|
|
2015-08-25 09:18:46 -07:00
|
|
|
type native_repr_attribute =
|
|
|
|
| Native_repr_attr_absent
|
|
|
|
| Native_repr_attr_present of native_repr_kind
|
|
|
|
|
2015-10-06 03:58:19 -07:00
|
|
|
let get_native_repr_attribute attrs ~global_repr =
|
2015-08-25 09:18:46 -07:00
|
|
|
match
|
2015-10-06 03:58:27 -07:00
|
|
|
Attr_helper.get_no_payload_attribute ["unboxed"; "ocaml.unboxed"] attrs,
|
|
|
|
Attr_helper.get_no_payload_attribute ["untagged"; "ocaml.untagged"] attrs,
|
2015-10-06 03:58:19 -07:00
|
|
|
global_repr
|
2015-08-25 09:18:46 -07:00
|
|
|
with
|
2015-10-06 03:58:19 -07:00
|
|
|
| None, None, None -> Native_repr_attr_absent
|
|
|
|
| None, None, Some repr -> Native_repr_attr_present repr
|
|
|
|
| Some _, None, None -> Native_repr_attr_present Unboxed
|
|
|
|
| None, Some _, None -> Native_repr_attr_present Untagged
|
|
|
|
| Some { Location.loc }, _, _
|
|
|
|
| _, Some { Location.loc }, _ ->
|
2015-10-06 03:58:18 -07:00
|
|
|
raise (Error (loc, Multiple_native_repr_attributes))
|
2015-08-25 09:18:46 -07:00
|
|
|
|
|
|
|
let native_repr_of_type env kind ty =
|
|
|
|
match kind, (Ctype.expand_head_opt env ty).desc with
|
|
|
|
| Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int ->
|
|
|
|
Some Untagged_int
|
|
|
|
| Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float ->
|
|
|
|
Some Unboxed_float
|
|
|
|
| Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int32 ->
|
|
|
|
Some (Unboxed_integer Pint32)
|
|
|
|
| Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_int64 ->
|
|
|
|
Some (Unboxed_integer Pint64)
|
|
|
|
| Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_nativeint ->
|
|
|
|
Some (Unboxed_integer Pnativeint)
|
|
|
|
| _ ->
|
|
|
|
None
|
|
|
|
|
2016-01-18 09:34:02 -08:00
|
|
|
(* Raises an error when [core_type] contains an [@unboxed] or [@untagged]
|
|
|
|
attribute in a strict sub-term. *)
|
|
|
|
let error_if_has_deep_native_repr_attributes core_type =
|
2016-01-27 13:53:00 -08:00
|
|
|
let open Ast_iterator in
|
|
|
|
let this_iterator =
|
|
|
|
{ default_iterator with typ = fun iterator core_type ->
|
2016-01-18 09:34:02 -08:00
|
|
|
begin
|
|
|
|
match
|
|
|
|
get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
|
|
|
|
with
|
|
|
|
| Native_repr_attr_present kind ->
|
2016-02-16 04:23:31 -08:00
|
|
|
raise (Error (core_type.ptyp_loc,
|
|
|
|
Deep_unbox_or_untag_attribute kind))
|
2016-01-18 09:34:02 -08:00
|
|
|
| Native_repr_attr_absent -> ()
|
|
|
|
end;
|
2016-01-27 13:53:00 -08:00
|
|
|
default_iterator.typ iterator core_type }
|
2016-01-18 09:34:02 -08:00
|
|
|
in
|
2016-01-27 13:53:00 -08:00
|
|
|
default_iterator.typ this_iterator core_type
|
2016-01-18 09:34:02 -08:00
|
|
|
|
2015-10-06 03:58:19 -07:00
|
|
|
let make_native_repr env core_type ty ~global_repr =
|
2016-01-18 09:34:02 -08:00
|
|
|
error_if_has_deep_native_repr_attributes core_type;
|
2015-10-06 03:58:19 -07:00
|
|
|
match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with
|
2016-01-18 09:34:02 -08:00
|
|
|
| Native_repr_attr_absent ->
|
|
|
|
Same_as_ocaml_repr
|
2015-08-25 09:18:46 -07:00
|
|
|
| Native_repr_attr_present kind ->
|
|
|
|
begin match native_repr_of_type env kind ty with
|
|
|
|
| None ->
|
|
|
|
raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
|
|
|
|
| Some repr -> repr
|
|
|
|
end
|
|
|
|
|
2015-10-06 03:58:19 -07:00
|
|
|
let rec parse_native_repr_attributes env core_type ty ~global_repr =
|
2016-01-18 09:34:02 -08:00
|
|
|
match core_type.ptyp_desc, (Ctype.repr ty).desc,
|
|
|
|
get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None
|
|
|
|
with
|
|
|
|
| Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind ->
|
|
|
|
raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind))
|
|
|
|
| Ptyp_arrow (_, ct1, ct2), Tarrow (_, t1, t2, _), _ ->
|
2015-10-06 03:58:19 -07:00
|
|
|
let repr_arg = make_native_repr env ct1 t1 ~global_repr in
|
|
|
|
let repr_args, repr_res =
|
|
|
|
parse_native_repr_attributes env ct2 t2 ~global_repr
|
|
|
|
in
|
2015-08-25 09:18:46 -07:00
|
|
|
(repr_arg :: repr_args, repr_res)
|
2016-01-18 09:34:02 -08:00
|
|
|
| Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
|
2015-10-06 03:58:19 -07:00
|
|
|
| _ -> ([], make_native_repr env core_type ty ~global_repr)
|
2015-08-25 09:18:46 -07:00
|
|
|
|
2016-05-25 07:29:05 -07:00
|
|
|
|
|
|
|
let check_unboxable env loc ty =
|
2018-07-30 02:57:54 -07:00
|
|
|
let check_type acc ty : Path.Set.t =
|
|
|
|
let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
|
|
|
|
try match ty.desc with
|
|
|
|
| Tconstr (p, _, _) ->
|
|
|
|
let tydecl = Env.find_type p env in
|
|
|
|
if tydecl.type_unboxed.default then
|
|
|
|
Path.Set.add p acc
|
|
|
|
else acc
|
|
|
|
| _ -> acc
|
|
|
|
with Not_found -> acc
|
|
|
|
in
|
|
|
|
let all_unboxable_types = Btype.fold_type_expr check_type Path.Set.empty ty in
|
|
|
|
Path.Set.fold
|
|
|
|
(fun p () ->
|
|
|
|
Location.prerr_warning loc
|
|
|
|
(Warnings.Unboxable_type_in_prim_decl (Path.name p))
|
|
|
|
)
|
|
|
|
all_unboxable_types
|
|
|
|
()
|
2016-05-25 07:29:05 -07:00
|
|
|
|
1995-07-25 04:40:07 -07:00
|
|
|
(* Translate a value declaration *)
|
2011-10-20 20:26:35 -07:00
|
|
|
let transl_value_decl env loc valdecl =
|
2012-05-30 07:52:37 -07:00
|
|
|
let cty = Typetexp.transl_type_scheme env valdecl.pval_type in
|
|
|
|
let ty = cty.ctyp_type in
|
|
|
|
let v =
|
1997-05-13 07:07:00 -07:00
|
|
|
match valdecl.pval_prim with
|
2014-12-10 05:37:50 -08:00
|
|
|
[] when Env.is_in_signature env ->
|
2013-09-26 08:24:11 -07:00
|
|
|
{ val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
|
|
|
|
val_attributes = valdecl.pval_attributes }
|
2014-12-10 05:37:50 -08:00
|
|
|
| [] ->
|
|
|
|
raise (Error(valdecl.pval_loc, Val_in_structure))
|
2015-08-25 09:18:46 -07:00
|
|
|
| _ ->
|
2015-10-06 03:58:19 -07:00
|
|
|
let global_repr =
|
|
|
|
match
|
|
|
|
get_native_repr_attribute valdecl.pval_attributes ~global_repr:None
|
|
|
|
with
|
|
|
|
| Native_repr_attr_present repr -> Some repr
|
|
|
|
| Native_repr_attr_absent -> None
|
|
|
|
in
|
2015-08-25 09:18:46 -07:00
|
|
|
let native_repr_args, native_repr_res =
|
2015-10-06 03:58:19 -07:00
|
|
|
parse_native_repr_attributes env valdecl.pval_type ty ~global_repr
|
2015-08-25 09:18:46 -07:00
|
|
|
in
|
|
|
|
let prim =
|
|
|
|
Primitive.parse_declaration valdecl
|
|
|
|
~native_repr_args
|
|
|
|
~native_repr_res
|
|
|
|
in
|
|
|
|
if prim.prim_arity = 0 &&
|
|
|
|
(prim.prim_name = "" || prim.prim_name.[0] <> '%') then
|
2014-04-10 07:11:25 -07:00
|
|
|
raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
|
2000-06-05 05:18:30 -07:00
|
|
|
if !Clflags.native_code
|
|
|
|
&& prim.prim_arity > 5
|
|
|
|
&& prim.prim_native_name = ""
|
|
|
|
then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
|
2018-07-30 02:57:54 -07:00
|
|
|
check_unboxable env loc ty;
|
2013-09-26 08:24:11 -07:00
|
|
|
{ val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc;
|
|
|
|
val_attributes = valdecl.pval_attributes }
|
2012-05-30 07:52:37 -07:00
|
|
|
in
|
2013-03-25 11:04:40 -07:00
|
|
|
let (id, newenv) =
|
|
|
|
Env.enter_value valdecl.pval_name.txt v env
|
|
|
|
~check:(fun s -> Warnings.Unused_value_declaration s)
|
|
|
|
in
|
|
|
|
let desc =
|
|
|
|
{
|
|
|
|
val_id = id;
|
|
|
|
val_name = valdecl.pval_name;
|
|
|
|
val_desc = cty; val_val = v;
|
|
|
|
val_prim = valdecl.pval_prim;
|
|
|
|
val_loc = valdecl.pval_loc;
|
|
|
|
val_attributes = valdecl.pval_attributes;
|
|
|
|
}
|
|
|
|
in
|
|
|
|
desc, newenv
|
1995-07-25 04:40:07 -07:00
|
|
|
|
2017-07-17 15:02:26 -07:00
|
|
|
let transl_value_decl env loc valdecl =
|
|
|
|
Builtin_attributes.warning_scope valdecl.pval_attributes
|
|
|
|
(fun () -> transl_value_decl env loc valdecl)
|
|
|
|
|
1995-09-28 03:42:38 -07:00
|
|
|
(* Translate a "with" constraint -- much simplified version of
|
|
|
|
transl_type_decl. *)
|
2011-07-20 02:17:07 -07:00
|
|
|
let transl_with_constraint env id row_path orig_decl sdecl =
|
2018-03-14 09:57:31 -07:00
|
|
|
Env.mark_type_used (Ident.name id) orig_decl;
|
1995-09-28 03:42:38 -07:00
|
|
|
reset_type_variables();
|
1996-04-22 04:15:41 -07:00
|
|
|
Ctype.begin_def();
|
2014-05-04 16:08:45 -07:00
|
|
|
let tparams = make_params env sdecl.ptype_params in
|
|
|
|
let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
|
2011-07-20 02:17:07 -07:00
|
|
|
let orig_decl = Ctype.instance_declaration orig_decl in
|
|
|
|
let arity_ok = List.length params = orig_decl.type_arity in
|
|
|
|
if arity_ok then
|
|
|
|
List.iter2 (Ctype.unify_var env) params orig_decl.type_params;
|
2012-05-30 07:52:37 -07:00
|
|
|
let constraints = List.map
|
1998-06-24 12:22:26 -07:00
|
|
|
(function (ty, ty', loc) ->
|
1997-02-20 12:39:02 -08:00
|
|
|
try
|
2012-07-30 11:04:46 -07:00
|
|
|
let cty = transl_simple_type env false ty in
|
|
|
|
let cty' = transl_simple_type env false ty' in
|
2012-05-30 07:52:37 -07:00
|
|
|
let ty = cty.ctyp_type in
|
|
|
|
let ty' = cty'.ctyp_type in
|
|
|
|
Ctype.unify env ty ty';
|
|
|
|
(cty, cty', loc)
|
2001-12-25 19:43:41 -08:00
|
|
|
with Ctype.Unify tr ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, Inconsistent_constraint (env, tr))))
|
2012-05-30 07:52:37 -07:00
|
|
|
sdecl.ptype_cstrs
|
|
|
|
in
|
2007-10-09 03:29:37 -07:00
|
|
|
let no_row = not (is_fixed_type sdecl) in
|
2012-05-30 07:52:37 -07:00
|
|
|
let (tman, man) = match sdecl.ptype_manifest with
|
|
|
|
None -> None, None
|
|
|
|
| Some sty ->
|
|
|
|
let cty = transl_simple_type env no_row sty in
|
|
|
|
Some cty, Some cty.ctyp_type
|
|
|
|
in
|
2013-07-26 16:04:51 -07:00
|
|
|
let priv =
|
2013-07-30 19:49:13 -07:00
|
|
|
if sdecl.ptype_private = Private then Private else
|
|
|
|
if arity_ok && orig_decl.type_kind <> Type_abstract
|
2013-07-26 16:04:51 -07:00
|
|
|
then orig_decl.type_private else sdecl.ptype_private
|
|
|
|
in
|
2013-07-30 19:49:13 -07:00
|
|
|
if arity_ok && orig_decl.type_kind <> Type_abstract
|
|
|
|
&& sdecl.ptype_private = Private then
|
2017-04-05 10:13:59 -07:00
|
|
|
Location.deprecated sdecl.ptype_loc "spurious use of private";
|
2016-05-25 07:29:05 -07:00
|
|
|
let type_kind, type_unboxed =
|
|
|
|
if arity_ok && man <> None then
|
|
|
|
orig_decl.type_kind, orig_decl.type_unboxed
|
|
|
|
else
|
2016-09-01 09:39:32 -07:00
|
|
|
Type_abstract, unboxed_false_default_false
|
2016-05-25 07:29:05 -07:00
|
|
|
in
|
1997-02-20 12:39:02 -08:00
|
|
|
let decl =
|
|
|
|
{ type_params = params;
|
|
|
|
type_arity = List.length params;
|
2016-05-25 07:29:05 -07:00
|
|
|
type_kind;
|
2013-07-26 16:04:51 -07:00
|
|
|
type_private = priv;
|
2012-05-30 07:52:37 -07:00
|
|
|
type_manifest = man;
|
2000-09-06 03:21:07 -07:00
|
|
|
type_variance = [];
|
2018-02-12 08:37:35 -08:00
|
|
|
type_is_newtype = false;
|
2018-09-26 15:14:43 -07:00
|
|
|
type_expansion_scope = Btype.lowest_level;
|
2010-05-21 08:06:01 -07:00
|
|
|
type_loc = sdecl.ptype_loc;
|
2013-09-27 03:54:55 -07:00
|
|
|
type_attributes = sdecl.ptype_attributes;
|
2015-05-27 07:30:33 -07:00
|
|
|
type_immediate = false;
|
2016-05-25 07:29:05 -07:00
|
|
|
type_unboxed;
|
2000-09-06 03:21:07 -07:00
|
|
|
}
|
1997-02-20 12:39:02 -08:00
|
|
|
in
|
2005-03-22 19:08:37 -08:00
|
|
|
begin match row_path with None -> ()
|
|
|
|
| Some p -> set_fixed_row env sdecl.ptype_loc p decl
|
|
|
|
end;
|
2005-08-13 13:59:37 -07:00
|
|
|
begin match Ctype.closed_type_decl decl with None -> ()
|
|
|
|
| Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
|
|
|
|
end;
|
2006-11-01 17:10:04 -08:00
|
|
|
let decl = name_recursion sdecl id decl in
|
2015-05-27 07:30:33 -07:00
|
|
|
let type_variance =
|
2018-11-20 07:10:19 -08:00
|
|
|
try Typedecl_variance.compute_decl
|
|
|
|
env ~check:true decl (Typedecl_variance.variance_of_sdecl sdecl)
|
|
|
|
with Typedecl_variance.Error (loc, err) ->
|
|
|
|
raise (Error (loc, Variance err)) in
|
2018-11-20 07:28:15 -08:00
|
|
|
let type_immediate =
|
|
|
|
(* Typedecl_immediacy.compute_decl never raises *)
|
|
|
|
Typedecl_immediacy.compute_decl env decl in
|
2015-05-27 07:30:33 -07:00
|
|
|
let decl = {decl with type_variance; type_immediate} in
|
1997-02-20 12:39:02 -08:00
|
|
|
Ctype.end_def();
|
|
|
|
generalize_decl decl;
|
2012-05-30 07:52:37 -07:00
|
|
|
{
|
2013-03-25 11:20:11 -07:00
|
|
|
typ_id = id;
|
|
|
|
typ_name = sdecl.ptype_name;
|
2014-05-04 16:08:45 -07:00
|
|
|
typ_params = tparams;
|
2012-05-30 07:52:37 -07:00
|
|
|
typ_type = decl;
|
|
|
|
typ_cstrs = constraints;
|
|
|
|
typ_loc = sdecl.ptype_loc;
|
|
|
|
typ_manifest = tman;
|
|
|
|
typ_kind = Ttype_abstract;
|
|
|
|
typ_private = sdecl.ptype_private;
|
2013-03-25 07:16:07 -07:00
|
|
|
typ_attributes = sdecl.ptype_attributes;
|
2012-05-30 07:52:37 -07:00
|
|
|
}
|
1995-09-28 03:42:38 -07:00
|
|
|
|
2003-06-19 08:53:53 -07:00
|
|
|
(* Approximate a type declaration: just make all types abstract *)
|
|
|
|
|
|
|
|
let abstract_type_decl arity =
|
|
|
|
let rec make_params n =
|
|
|
|
if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in
|
|
|
|
Ctype.begin_def();
|
|
|
|
let decl =
|
|
|
|
{ type_params = make_params arity;
|
|
|
|
type_arity = arity;
|
|
|
|
type_kind = Type_abstract;
|
2007-10-09 03:29:37 -07:00
|
|
|
type_private = Public;
|
2003-06-19 08:53:53 -07:00
|
|
|
type_manifest = None;
|
2013-05-03 06:38:30 -07:00
|
|
|
type_variance = replicate_list Variance.full arity;
|
2018-02-12 08:37:35 -08:00
|
|
|
type_is_newtype = false;
|
2018-09-26 15:14:43 -07:00
|
|
|
type_expansion_scope = Btype.lowest_level;
|
2010-05-21 08:06:01 -07:00
|
|
|
type_loc = Location.none;
|
2013-09-27 03:54:55 -07:00
|
|
|
type_attributes = [];
|
2015-05-27 07:30:33 -07:00
|
|
|
type_immediate = false;
|
2016-09-01 09:39:32 -07:00
|
|
|
type_unboxed = unboxed_false_default_false;
|
2010-05-21 08:06:01 -07:00
|
|
|
} in
|
2003-06-19 08:53:53 -07:00
|
|
|
Ctype.end_def();
|
|
|
|
generalize_decl decl;
|
|
|
|
decl
|
|
|
|
|
2016-03-09 02:40:16 -08:00
|
|
|
let approx_type_decl sdecl_list =
|
2018-09-14 05:04:49 -07:00
|
|
|
let scope = Ctype.create_scope () in
|
2003-06-19 08:53:53 -07:00
|
|
|
List.map
|
2013-03-06 03:47:59 -08:00
|
|
|
(fun sdecl ->
|
2018-08-28 09:07:01 -07:00
|
|
|
(Ident.create_scoped ~scope sdecl.ptype_name.txt,
|
2003-06-19 08:53:53 -07:00
|
|
|
abstract_type_decl (List.length sdecl.ptype_params)))
|
2013-03-06 03:47:59 -08:00
|
|
|
sdecl_list
|
2003-06-19 08:53:53 -07:00
|
|
|
|
2003-07-03 03:00:53 -07:00
|
|
|
(* Variant of check_abbrev_recursion to check the well-formedness
|
|
|
|
conditions on type abbreviations defined within recursive modules. *)
|
2003-07-01 06:05:43 -07:00
|
|
|
|
|
|
|
let check_recmod_typedecl env loc recmod_ids path decl =
|
|
|
|
(* recmod_ids is the list of recursively-defined module idents.
|
|
|
|
(path, decl) is the type declaration to be checked. *)
|
2018-07-06 00:45:25 -07:00
|
|
|
let to_check path = Path.exists_free recmod_ids path in
|
2014-08-22 06:45:02 -07:00
|
|
|
check_well_founded_decl env loc path decl to_check;
|
2019-04-18 18:57:55 -07:00
|
|
|
check_recursion env loc path decl to_check;
|
|
|
|
(* additionally check coherece, as one might build an incoherent signature,
|
|
|
|
and use it to build an incoherent module, cf. #7851 *)
|
|
|
|
check_coherence env loc path decl
|
2003-07-01 06:05:43 -07:00
|
|
|
|
|
|
|
|
1997-02-20 12:39:02 -08:00
|
|
|
(**** Error report ****)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2000-03-06 14:12:09 -08:00
|
|
|
open Format
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2014-10-14 08:51:30 -07:00
|
|
|
let explain_unbound_gen ppf tv tl typ kwd pr =
|
2009-07-20 04:51:50 -07:00
|
|
|
try
|
|
|
|
let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in
|
|
|
|
let ty0 = (* Hack to force aliasing when needed *)
|
|
|
|
Btype.newgenty (Tobject(tv, ref None)) in
|
|
|
|
Printtyp.reset_and_mark_loops_list [typ ti; ty0];
|
|
|
|
fprintf ppf
|
2014-10-14 08:51:30 -07:00
|
|
|
".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]"
|
|
|
|
kwd pr ti Printtyp.type_expr tv
|
2009-07-20 04:51:50 -07:00
|
|
|
with Not_found -> ()
|
|
|
|
|
2014-10-14 08:51:30 -07:00
|
|
|
let explain_unbound ppf tv tl typ kwd lab =
|
|
|
|
explain_unbound_gen ppf tv tl typ kwd
|
|
|
|
(fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti))
|
|
|
|
|
2009-07-20 04:51:50 -07:00
|
|
|
let explain_unbound_single ppf tv ty =
|
|
|
|
let trivial ty =
|
|
|
|
explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in
|
|
|
|
match (Ctype.repr ty).desc with
|
|
|
|
Tobject(fi,_) ->
|
|
|
|
let (tl, rv) = Ctype.flatten_fields fi in
|
|
|
|
if rv == tv then trivial ty else
|
|
|
|
explain_unbound ppf tv tl (fun (_,_,t) -> t)
|
|
|
|
"method" (fun (lab,_,_) -> lab ^ ": ")
|
|
|
|
| Tvariant row ->
|
|
|
|
let row = Btype.row_repr row in
|
|
|
|
if row.row_more == tv then trivial ty else
|
|
|
|
explain_unbound ppf tv row.row_fields
|
2016-03-09 02:40:16 -08:00
|
|
|
(fun (_l,f) -> match Btype.row_field_repr f with
|
2009-07-20 04:51:50 -07:00
|
|
|
Rpresent (Some t) -> t
|
|
|
|
| Reither (_,[t],_,_) -> t
|
|
|
|
| Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
|
|
|
|
| _ -> Btype.newgenty (Ttuple[]))
|
|
|
|
"case" (fun (lab,_) -> "`" ^ lab ^ " of ")
|
|
|
|
| _ -> trivial ty
|
|
|
|
|
2014-10-14 08:51:30 -07:00
|
|
|
|
|
|
|
let tys_of_constr_args = function
|
|
|
|
| Types.Cstr_tuple tl -> tl
|
|
|
|
| Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls
|
|
|
|
|
2000-03-06 14:12:09 -08:00
|
|
|
let report_error ppf = function
|
|
|
|
| Repeated_parameter ->
|
|
|
|
fprintf ppf "A type parameter occurs several times"
|
1995-05-04 03:15:53 -07:00
|
|
|
| Duplicate_constructor s ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "Two constructors are named %s" s
|
1995-05-22 08:43:44 -07:00
|
|
|
| Too_many_constructors ->
|
2010-05-21 08:13:47 -07:00
|
|
|
fprintf ppf
|
|
|
|
"@[Too many non-constant constructors@ -- maximum is %i %s@]"
|
|
|
|
(Config.max_tag + 1) "non-constant constructors"
|
1995-05-04 03:15:53 -07:00
|
|
|
| Duplicate_label s ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "Two labels are named %s" s
|
1995-05-04 03:15:53 -07:00
|
|
|
| Recursive_abbrev s ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "The type abbreviation %s is cyclic" s
|
2014-08-22 06:45:02 -07:00
|
|
|
| Cycle_in_def (s, ty) ->
|
|
|
|
Printtyp.reset_and_mark_loops ty;
|
|
|
|
fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]"
|
|
|
|
s Printtyp.type_expr ty
|
2018-08-08 09:07:53 -07:00
|
|
|
| Definition_mismatch (ty, None) ->
|
|
|
|
Printtyp.reset_and_mark_loops ty;
|
|
|
|
fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]@]"
|
|
|
|
"This variant or record definition" "does not match that of type"
|
|
|
|
Printtyp.type_expr ty
|
|
|
|
| Definition_mismatch (ty, Some err) ->
|
2000-03-06 14:12:09 -08:00
|
|
|
Printtyp.reset_and_mark_loops ty;
|
2010-05-23 23:52:16 -07:00
|
|
|
fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
|
2010-05-21 08:13:47 -07:00
|
|
|
"This variant or record definition" "does not match that of type"
|
|
|
|
Printtyp.type_expr ty
|
|
|
|
(Includecore.report_type_mismatch "the original" "this" "definition")
|
2018-08-08 09:07:53 -07:00
|
|
|
err
|
2000-05-24 01:06:33 -07:00
|
|
|
| Constraint_failed (ty, ty') ->
|
2000-05-23 23:19:39 -07:00
|
|
|
Printtyp.reset_and_mark_loops ty;
|
|
|
|
Printtyp.mark_loops ty';
|
2018-06-26 13:03:45 -07:00
|
|
|
Printtyp.Naming_context.reset ();
|
2010-11-07 22:59:46 -08:00
|
|
|
fprintf ppf "@[%s@ @[<hv>Type@ %a@ should be an instance of@ %a@]@]"
|
|
|
|
"Constraints are not satisfied in this type."
|
2018-06-26 13:03:45 -07:00
|
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false ty)
|
|
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false ty')
|
2003-07-01 06:05:43 -07:00
|
|
|
| Parameters_differ (path, ty, ty') ->
|
2000-05-24 19:09:13 -07:00
|
|
|
Printtyp.reset_and_mark_loops ty;
|
|
|
|
Printtyp.mark_loops ty';
|
2018-06-26 13:03:45 -07:00
|
|
|
Printtyp.Naming_context.reset ();
|
2000-05-24 19:09:13 -07:00
|
|
|
fprintf ppf
|
2003-07-01 06:05:43 -07:00
|
|
|
"@[<hv>In the definition of %s, type@ %a@ should be@ %a@]"
|
2018-06-26 13:03:45 -07:00
|
|
|
(Path.name path)
|
|
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false ty)
|
|
|
|
!Oprint.out_type (Printtyp.tree_of_typexp false ty')
|
2012-01-21 19:15:14 -08:00
|
|
|
| Inconsistent_constraint (env, trace) ->
|
2001-12-25 19:43:41 -08:00
|
|
|
fprintf ppf "The type constraints are not consistent.@.";
|
2013-01-29 06:21:12 -08:00
|
|
|
Printtyp.report_unification_error ppf env trace
|
2001-12-25 19:43:41 -08:00
|
|
|
(fun ppf -> fprintf ppf "Type")
|
|
|
|
(fun ppf -> fprintf ppf "is not compatible with type")
|
2012-01-21 19:15:14 -08:00
|
|
|
| Type_clash (env, trace) ->
|
2013-01-29 06:21:12 -08:00
|
|
|
Printtyp.report_unification_error ppf env trace
|
2000-03-06 14:12:09 -08:00
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "This type constructor expands to type")
|
|
|
|
(function ppf ->
|
2009-05-20 04:52:42 -07:00
|
|
|
fprintf ppf "but is used here with type")
|
1997-05-13 07:07:00 -07:00
|
|
|
| Null_arity_external ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "External identifiers must be functions"
|
2000-06-05 05:18:30 -07:00
|
|
|
| Missing_native_external ->
|
|
|
|
fprintf ppf "@[<hv>An external function with more than 5 arguments \
|
2009-05-20 04:52:42 -07:00
|
|
|
requires a second stub function@ \
|
2000-06-05 05:18:30 -07:00
|
|
|
for native-code compilation@]"
|
2005-08-13 13:59:37 -07:00
|
|
|
| Unbound_type_var (ty, decl) ->
|
|
|
|
fprintf ppf "A type variable is unbound in this type declaration";
|
|
|
|
let ty = Ctype.repr ty in
|
2009-07-20 04:51:50 -07:00
|
|
|
begin match decl.type_kind, decl.type_manifest with
|
2010-11-07 22:59:46 -08:00
|
|
|
| Type_variant tl, _ ->
|
2014-10-14 08:51:30 -07:00
|
|
|
explain_unbound_gen ppf ty tl (fun c ->
|
2016-01-14 06:29:41 -08:00
|
|
|
let tl = tys_of_constr_args c.Types.cd_args in
|
2014-10-14 08:51:30 -07:00
|
|
|
Btype.newgenty (Ttuple tl)
|
|
|
|
)
|
|
|
|
"case" (fun ppf c ->
|
|
|
|
fprintf ppf
|
2018-06-26 13:03:45 -07:00
|
|
|
"%a of %a" Printtyp.ident c.Types.cd_id
|
2016-01-14 06:29:41 -08:00
|
|
|
Printtyp.constructor_arguments c.Types.cd_args)
|
2007-10-09 03:29:37 -07:00
|
|
|
| Type_record (tl, _), _ ->
|
2013-09-27 03:54:55 -07:00
|
|
|
explain_unbound ppf ty tl (fun l -> l.Types.ld_type)
|
|
|
|
"field" (fun l -> Ident.name l.Types.ld_id ^ ": ")
|
2005-08-13 13:59:37 -07:00
|
|
|
| Type_abstract, Some ty' ->
|
2009-07-20 04:51:50 -07:00
|
|
|
explain_unbound_single ppf ty ty'
|
2005-08-13 13:59:37 -07:00
|
|
|
| _ -> ()
|
|
|
|
end
|
2014-05-04 16:08:45 -07:00
|
|
|
| Unbound_type_var_ext (ty, ext) ->
|
|
|
|
fprintf ppf "A type variable is unbound in this extension constructor";
|
2014-10-14 08:51:30 -07:00
|
|
|
let args = tys_of_constr_args ext.ext_args in
|
|
|
|
explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "")
|
2017-07-20 08:33:41 -07:00
|
|
|
| Cannot_extend_private_type path ->
|
2014-05-04 16:08:45 -07:00
|
|
|
fprintf ppf "@[%s@ %a@]"
|
2017-07-20 08:33:41 -07:00
|
|
|
"Cannot extend private type definition"
|
2014-05-04 16:08:45 -07:00
|
|
|
Printtyp.path path
|
|
|
|
| Not_extensible_type path ->
|
|
|
|
fprintf ppf "@[%s@ %a@ %s@]"
|
2017-07-20 08:33:41 -07:00
|
|
|
"Type definition"
|
2014-05-04 16:08:45 -07:00
|
|
|
Printtyp.path path
|
|
|
|
"is not extensible"
|
2018-08-08 09:07:53 -07:00
|
|
|
| Extension_mismatch (path, err) ->
|
2014-05-04 16:08:45 -07:00
|
|
|
fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%s@]%a@]"
|
|
|
|
"This extension" "does not match the definition of type"
|
|
|
|
(Path.name path)
|
|
|
|
(Includecore.report_type_mismatch
|
|
|
|
"the type" "this extension" "definition")
|
2018-08-08 09:07:53 -07:00
|
|
|
err
|
2014-05-04 16:08:45 -07:00
|
|
|
| Rebind_wrong_type (lid, env, trace) ->
|
|
|
|
Printtyp.report_unification_error ppf env trace
|
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "The constructor %a@ has type"
|
|
|
|
Printtyp.longident lid)
|
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "but was expected to be of type")
|
|
|
|
| Rebind_mismatch (lid, p, p') ->
|
|
|
|
fprintf ppf
|
|
|
|
"@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]"
|
|
|
|
"The constructor" Printtyp.longident lid
|
|
|
|
"extends type" (Path.name p)
|
|
|
|
"whose declaration does not match"
|
|
|
|
"the declaration of type" (Path.name p')
|
|
|
|
| Rebind_private lid ->
|
|
|
|
fprintf ppf "@[%s@ %a@ %s@]"
|
|
|
|
"The constructor"
|
2000-03-12 05:10:29 -08:00
|
|
|
Printtyp.longident lid
|
2014-05-04 16:08:45 -07:00
|
|
|
"is private"
|
2018-11-20 07:10:19 -08:00
|
|
|
| Variance (Typedecl_variance.Bad_variance (n, v1, v2)) ->
|
2013-04-29 22:26:57 -07:00
|
|
|
let variance (p,n,i) =
|
|
|
|
let inj = if i then "injective " else "" in
|
|
|
|
match p, n with
|
|
|
|
true, true -> inj ^ "invariant"
|
|
|
|
| true, false -> inj ^ "covariant"
|
|
|
|
| false, true -> inj ^ "contravariant"
|
|
|
|
| false, false -> if inj = "" then "unrestricted" else inj
|
2005-08-13 13:59:37 -07:00
|
|
|
in
|
2009-05-20 04:52:42 -07:00
|
|
|
let suffix n =
|
|
|
|
let teen = (n mod 100)/10 = 1 in
|
|
|
|
match n mod 10 with
|
|
|
|
| 1 when not teen -> "st"
|
|
|
|
| 2 when not teen -> "nd"
|
|
|
|
| 3 when not teen -> "rd"
|
|
|
|
| _ -> "th"
|
|
|
|
in
|
2019-07-31 20:14:28 -07:00
|
|
|
(match n with
|
|
|
|
| Variance_not_reflected ->
|
2013-04-29 22:26:57 -07:00
|
|
|
fprintf ppf "@[%s@ %s@ It"
|
2010-11-07 22:59:46 -08:00
|
|
|
"In this definition, a type variable has a variance that"
|
|
|
|
"is not reflected by its occurrence in type parameters."
|
2019-07-31 20:14:28 -07:00
|
|
|
| No_variable ->
|
2013-05-03 06:38:30 -07:00
|
|
|
fprintf ppf "@[%s@ %s@]"
|
2013-04-29 22:26:57 -07:00
|
|
|
"In this definition, a type variable cannot be deduced"
|
|
|
|
"from the type parameters."
|
2019-07-31 20:14:28 -07:00
|
|
|
| Variance_not_deducible ->
|
2013-04-29 22:26:57 -07:00
|
|
|
fprintf ppf "@[%s@ %s@ It"
|
|
|
|
"In this definition, a type variable has a variance that"
|
|
|
|
"cannot be deduced from the type parameters."
|
2019-07-31 20:14:28 -07:00
|
|
|
| Variance_not_satisfied n ->
|
2013-04-29 22:26:57 -07:00
|
|
|
fprintf ppf "@[%s@ %s@ The %d%s type parameter"
|
2005-08-13 13:59:37 -07:00
|
|
|
"In this definition, expected parameter"
|
|
|
|
"variances are not satisfied."
|
2019-07-31 20:14:28 -07:00
|
|
|
n (suffix n));
|
|
|
|
(match n with
|
|
|
|
| No_variable -> ()
|
|
|
|
| _ ->
|
2013-05-03 06:38:30 -07:00
|
|
|
fprintf ppf " was expected to be %s,@ but it is %s.@]"
|
2019-07-31 20:14:28 -07:00
|
|
|
(variance v2) (variance v1))
|
2001-09-28 15:55:27 -07:00
|
|
|
| Unavailable_type_constructor p ->
|
|
|
|
fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
|
2005-03-22 19:08:37 -08:00
|
|
|
| Bad_fixed_type r ->
|
|
|
|
fprintf ppf "This fixed type %s" r
|
2018-11-20 07:10:19 -08:00
|
|
|
| Variance Typedecl_variance.Varying_anonymous ->
|
2010-11-07 22:59:46 -08:00
|
|
|
fprintf ppf "@[%s@ %s@ %s@]"
|
|
|
|
"In this GADT definition," "the variance of some parameter"
|
|
|
|
"cannot be checked"
|
2014-12-10 05:37:50 -08:00
|
|
|
| Val_in_structure ->
|
|
|
|
fprintf ppf "Value declarations are only allowed in signatures"
|
2015-08-25 09:18:46 -07:00
|
|
|
| Multiple_native_repr_attributes ->
|
2015-09-22 08:07:19 -07:00
|
|
|
fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
|
2015-08-25 09:18:46 -07:00
|
|
|
| Cannot_unbox_or_untag_type Unboxed ->
|
2018-08-02 06:58:43 -07:00
|
|
|
fprintf ppf "@[Don't know how to unbox this type.@ \
|
2018-07-30 03:40:12 -07:00
|
|
|
Only float, int32, int64 and nativeint can be unboxed.@]"
|
2015-08-25 09:18:46 -07:00
|
|
|
| Cannot_unbox_or_untag_type Untagged ->
|
2018-08-02 06:58:43 -07:00
|
|
|
fprintf ppf "@[Don't know how to untag this type.@ \
|
2018-07-30 03:40:12 -07:00
|
|
|
Only int can be untagged.@]"
|
2016-01-18 09:34:02 -08:00
|
|
|
| Deep_unbox_or_untag_attribute kind ->
|
|
|
|
fprintf ppf
|
2018-07-30 03:40:12 -07:00
|
|
|
"@[The attribute '%s' should be attached to@ \
|
|
|
|
a direct argument or result of the primitive,@ \
|
|
|
|
it should not occur deeply into its type.@]"
|
2016-01-18 09:34:02 -08:00
|
|
|
(match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
|
2018-11-20 07:28:15 -08:00
|
|
|
| Immediacy Typedecl_immediacy.Bad_immediate_attribute ->
|
2015-05-27 07:30:33 -07:00
|
|
|
fprintf ppf "@[%s@ %s@]"
|
|
|
|
"Types marked with the immediate attribute must be"
|
|
|
|
"non-pointer types like int or bool"
|
2016-05-25 07:29:05 -07:00
|
|
|
| Bad_unboxed_attribute msg ->
|
|
|
|
fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
|
|
|
|
| Wrong_unboxed_type_float ->
|
|
|
|
fprintf ppf "@[This type cannot be unboxed because@ \
|
|
|
|
it might contain both float and non-float values.@ \
|
|
|
|
You should annotate it with [%@%@ocaml.boxed].@]"
|
|
|
|
| Boxed_and_unboxed ->
|
|
|
|
fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]"
|
2017-03-15 16:34:10 -07:00
|
|
|
| Nonrec_gadt ->
|
|
|
|
fprintf ppf
|
|
|
|
"@[GADT case syntax cannot be used in a 'nonrec' block.@]"
|
2013-09-12 07:06:48 -07:00
|
|
|
|
|
|
|
let () =
|
|
|
|
Location.register_error_of_exn
|
|
|
|
(function
|
|
|
|
| Error (loc, err) ->
|
2018-07-27 05:22:22 -07:00
|
|
|
Some (Location.error_of_printer ~loc report_error err)
|
2013-09-12 07:06:48 -07:00
|
|
|
| _ ->
|
|
|
|
None
|
|
|
|
)
|