1995-08-09 08:06:35 -07:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
2011-07-27 07:17:02 -07:00
|
|
|
(* OCaml *)
|
1995-08-09 08:06:35 -07:00
|
|
|
(* *)
|
|
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
|
|
(* *)
|
1996-04-30 07:53:58 -07:00
|
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
1999-11-17 10:59:06 -08:00
|
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
|
|
(* under the terms of the Q Public License version 1.0. *)
|
1995-08-09 08:06:35 -07:00
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Typechecking for the core language *)
|
|
|
|
|
1996-01-04 04:50:52 -08:00
|
|
|
open Misc
|
1995-05-04 03:15:53 -07:00
|
|
|
open Asttypes
|
|
|
|
open Parsetree
|
1996-09-23 04:33:27 -07:00
|
|
|
open Types
|
1995-05-04 03:15:53 -07:00
|
|
|
open Typedtree
|
1997-03-24 12:11:22 -08:00
|
|
|
open Btype
|
1995-05-04 03:15:53 -07:00
|
|
|
open Ctype
|
|
|
|
|
|
|
|
type error =
|
2010-05-18 09:46:46 -07:00
|
|
|
Polymorphic_label of Longident.t
|
1995-05-04 03:15:53 -07:00
|
|
|
| Constructor_arity_mismatch of Longident.t * int * int
|
1996-05-20 09:43:29 -07:00
|
|
|
| Label_mismatch of Longident.t * (type_expr * type_expr) list
|
|
|
|
| Pattern_type_clash of (type_expr * type_expr) list
|
2014-01-27 08:27:05 -08:00
|
|
|
| Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list
|
2008-01-11 08:13:18 -08:00
|
|
|
| Multiply_bound_variable of string
|
2000-10-02 07:18:05 -07:00
|
|
|
| Orpat_vars of Ident.t
|
1996-05-20 09:43:29 -07:00
|
|
|
| Expr_type_clash of (type_expr * type_expr) list
|
1995-05-04 03:15:53 -07:00
|
|
|
| Apply_non_function of type_expr
|
1999-11-30 08:07:38 -08:00
|
|
|
| Apply_wrong_label of label * type_expr
|
2012-11-14 08:59:33 -08:00
|
|
|
| Label_multiply_defined of string
|
2012-05-30 07:52:37 -07:00
|
|
|
| Label_missing of Ident.t list
|
1995-05-04 03:15:53 -07:00
|
|
|
| Label_not_mutable of Longident.t
|
2013-09-19 00:25:51 -07:00
|
|
|
| Wrong_name of string * type_expr * string * Path.t * Longident.t
|
2013-03-22 11:20:25 -07:00
|
|
|
| Name_type_mismatch of
|
2012-11-10 19:46:59 -08:00
|
|
|
string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list
|
2005-03-04 06:51:31 -08:00
|
|
|
| Incomplete_format of string
|
|
|
|
| Bad_conversion of string * int * char
|
1998-06-24 12:22:26 -07:00
|
|
|
| Undefined_method of type_expr * string
|
|
|
|
| Undefined_inherited_method of string
|
1996-04-22 04:15:41 -07:00
|
|
|
| Virtual_class of Longident.t
|
2003-07-02 02:14:35 -07:00
|
|
|
| Private_type of type_expr
|
|
|
|
| Private_label of Longident.t * type_expr
|
1996-04-22 04:15:41 -07:00
|
|
|
| Unbound_instance_variable of string
|
2010-04-26 05:54:11 -07:00
|
|
|
| Instance_variable_not_mutable of bool * string
|
1996-05-26 06:42:34 -07:00
|
|
|
| Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
|
1996-04-22 04:15:41 -07:00
|
|
|
| Outside_class
|
|
|
|
| Value_multiply_overridden of string
|
2002-06-12 02:52:08 -07:00
|
|
|
| Coercion_failure of
|
|
|
|
type_expr * type_expr * (type_expr * type_expr) list * bool
|
2001-11-21 22:47:29 -08:00
|
|
|
| Too_many_arguments of bool * type_expr
|
1999-11-30 08:07:38 -08:00
|
|
|
| Abstract_wrong_label of label * type_expr
|
1998-02-26 04:54:44 -08:00
|
|
|
| Scoping_let_module of string * type_expr
|
1998-06-24 12:22:26 -07:00
|
|
|
| Masked_instance_variable of Longident.t
|
2000-02-21 19:08:08 -08:00
|
|
|
| Not_a_variant_type of Longident.t
|
2001-04-19 01:34:21 -07:00
|
|
|
| Incoherent_label_order
|
2002-04-18 00:27:47 -07:00
|
|
|
| Less_general of string * (type_expr * type_expr) list
|
2010-10-21 16:59:33 -07:00
|
|
|
| Modules_not_allowed
|
|
|
|
| Cannot_infer_signature
|
|
|
|
| Not_a_packed_module of type_expr
|
2011-07-29 03:32:43 -07:00
|
|
|
| Recursive_local_constraint of (type_expr * type_expr) list
|
2010-12-03 08:13:01 -08:00
|
|
|
| Unexpected_existential
|
2012-12-07 18:40:56 -08:00
|
|
|
| Unqualified_gadt_pattern of Path.t * string
|
2013-04-16 08:34:09 -07:00
|
|
|
| Invalid_interval
|
2013-12-02 10:00:18 -08:00
|
|
|
| Invalid_for_loop_index
|
2014-05-05 04:49:37 -07:00
|
|
|
| No_value_clauses
|
|
|
|
| Exception_pattern_below_toplevel
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2012-01-21 19:15:14 -08:00
|
|
|
exception Error of Location.t * Env.t * error
|
2014-05-07 01:26:17 -07:00
|
|
|
exception Error_forward of Location.error
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1998-02-26 04:54:44 -08:00
|
|
|
(* Forward declaration, to be filled in by Typemod.type_module *)
|
|
|
|
|
|
|
|
let type_module =
|
|
|
|
ref ((fun env md -> assert false) :
|
|
|
|
Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
|
|
|
|
|
2009-11-01 13:52:29 -08:00
|
|
|
(* Forward declaration, to be filled in by Typemod.type_open *)
|
|
|
|
|
|
|
|
let type_open =
|
|
|
|
ref (fun _ -> assert false)
|
|
|
|
|
2010-10-21 16:59:33 -07:00
|
|
|
(* Forward declaration, to be filled in by Typemod.type_package *)
|
|
|
|
|
|
|
|
let type_package =
|
|
|
|
ref (fun _ -> assert false)
|
2009-11-01 13:52:29 -08:00
|
|
|
|
2003-11-25 01:20:45 -08:00
|
|
|
(* Forward declaration, to be filled in by Typeclass.class_structure *)
|
|
|
|
let type_object =
|
|
|
|
ref (fun env s -> assert false :
|
|
|
|
Env.t -> Location.t -> Parsetree.class_structure ->
|
2012-05-30 07:52:37 -07:00
|
|
|
Typedtree.class_structure * Types.class_signature * string list)
|
2003-04-01 17:32:09 -08:00
|
|
|
|
|
|
|
(*
|
|
|
|
Saving and outputting type information.
|
|
|
|
We keep these function names short, because they have to be
|
|
|
|
called each time we create a record of type [Typedtree.expression]
|
|
|
|
or [Typedtree.pattern] that will end up in the typed AST.
|
|
|
|
*)
|
|
|
|
let re node =
|
2012-05-30 07:52:37 -07:00
|
|
|
Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
|
2003-04-01 22:57:15 -08:00
|
|
|
Stypes.record (Stypes.Ti_expr node);
|
2003-04-01 17:32:09 -08:00
|
|
|
node
|
|
|
|
;;
|
|
|
|
let rp node =
|
2012-05-30 07:52:37 -07:00
|
|
|
Cmt_format.add_saved_type (Cmt_format.Partial_pattern node);
|
2003-04-01 22:57:15 -08:00
|
|
|
Stypes.record (Stypes.Ti_pat node);
|
2003-04-01 17:32:09 -08:00
|
|
|
node
|
|
|
|
;;
|
|
|
|
|
2012-05-30 07:52:37 -07:00
|
|
|
|
2013-07-04 05:27:06 -07:00
|
|
|
let fst3 (x, _, _) = x
|
2012-05-30 07:52:37 -07:00
|
|
|
let snd3 (_,x,_) = x
|
|
|
|
|
2013-04-15 09:23:22 -07:00
|
|
|
let case lhs rhs =
|
|
|
|
{c_lhs = lhs; c_guard = None; c_rhs = rhs}
|
|
|
|
|
2012-01-18 09:41:12 -08:00
|
|
|
(* Upper approximation of free identifiers on the parse tree *)
|
|
|
|
|
|
|
|
let iter_expression f e =
|
|
|
|
|
|
|
|
let rec expr e =
|
|
|
|
f e;
|
|
|
|
match e.pexp_desc with
|
2013-02-28 08:51:59 -08:00
|
|
|
| Pexp_extension _ (* we don't iterate under extension point *)
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_ident _
|
|
|
|
| Pexp_new _
|
|
|
|
| Pexp_constant _ -> ()
|
2013-04-17 04:43:29 -07:00
|
|
|
| Pexp_function pel -> List.iter case pel
|
|
|
|
| Pexp_fun (_, eo, _, e) -> may expr eo; expr e
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
|
2013-06-03 08:14:19 -07:00
|
|
|
| Pexp_let (_, pel, e) -> expr e; List.iter binding pel
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_match (e, pel)
|
2013-04-15 09:23:22 -07:00
|
|
|
| Pexp_try (e, pel) -> expr e; List.iter case pel
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_array el
|
|
|
|
| Pexp_tuple el -> List.iter expr el
|
2013-04-17 02:46:52 -07:00
|
|
|
| Pexp_construct (_, eo)
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_variant (_, eo) -> may expr eo
|
2012-01-20 19:40:37 -08:00
|
|
|
| Pexp_record (iel, eo) ->
|
|
|
|
may expr eo; List.iter (fun (_, e) -> expr e) iel
|
2013-05-16 06:34:53 -07:00
|
|
|
| Pexp_open (_, _, e)
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_newtype (_, e)
|
|
|
|
| Pexp_poly (e, _)
|
|
|
|
| Pexp_lazy e
|
|
|
|
| Pexp_assert e
|
|
|
|
| Pexp_setinstvar (_, e)
|
|
|
|
| Pexp_send (e, _)
|
2013-04-17 05:23:44 -07:00
|
|
|
| Pexp_constraint (e, _)
|
|
|
|
| Pexp_coerce (e, _, _)
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_field (e, _) -> expr e
|
|
|
|
| Pexp_while (e1, e2)
|
|
|
|
| Pexp_sequence (e1, e2)
|
|
|
|
| Pexp_setfield (e1, _, e2) -> expr e1; expr e2
|
|
|
|
| Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo
|
|
|
|
| Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3
|
|
|
|
| Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel
|
|
|
|
| Pexp_letmodule (_, me, e) -> expr e; module_expr me
|
2012-05-30 07:52:37 -07:00
|
|
|
| Pexp_object { pcstr_fields = fs } -> List.iter class_field fs
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_pack me -> module_expr me
|
|
|
|
|
2013-04-15 09:23:22 -07:00
|
|
|
and case {pc_lhs = _; pc_guard; pc_rhs} =
|
|
|
|
may expr pc_guard;
|
|
|
|
expr pc_rhs
|
|
|
|
|
2013-06-03 08:14:19 -07:00
|
|
|
and binding x =
|
|
|
|
expr x.pvb_expr
|
|
|
|
|
2012-01-18 09:41:12 -08:00
|
|
|
and module_expr me =
|
|
|
|
match me.pmod_desc with
|
2013-03-04 04:54:57 -08:00
|
|
|
| Pmod_extension _
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pmod_ident _ -> ()
|
|
|
|
| Pmod_structure str -> List.iter structure_item str
|
|
|
|
| Pmod_constraint (me, _)
|
|
|
|
| Pmod_functor (_, _, me) -> module_expr me
|
|
|
|
| Pmod_apply (me1, me2) -> module_expr me1; module_expr me2
|
|
|
|
| Pmod_unpack e -> expr e
|
|
|
|
|
2013-03-04 04:54:57 -08:00
|
|
|
|
2012-01-18 09:41:12 -08:00
|
|
|
and structure_item str =
|
|
|
|
match str.pstr_desc with
|
2013-04-11 07:07:32 -07:00
|
|
|
| Pstr_eval (e, _) -> expr e
|
2013-06-03 08:14:19 -07:00
|
|
|
| Pstr_value (_, pel) -> List.iter binding pel
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pstr_primitive _
|
|
|
|
| Pstr_type _
|
2014-05-04 16:08:45 -07:00
|
|
|
| Pstr_typext _
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pstr_exception _
|
|
|
|
| Pstr_modtype _
|
|
|
|
| Pstr_open _
|
|
|
|
| Pstr_class_type _
|
2013-03-06 04:27:32 -08:00
|
|
|
| Pstr_attribute _
|
2014-05-04 16:08:45 -07:00
|
|
|
| Pstr_extension _ -> ()
|
2014-04-15 04:26:00 -07:00
|
|
|
| Pstr_include {pincl_mod = me}
|
2013-03-05 08:50:05 -08:00
|
|
|
| Pstr_module {pmb_expr = me} -> module_expr me
|
|
|
|
| Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
|
|
|
|
|
|
|
|
and class_expr ce =
|
|
|
|
match ce.pcl_desc with
|
|
|
|
| Pcl_constr _ -> ()
|
2012-05-30 07:52:37 -07:00
|
|
|
| Pcl_structure { pcstr_fields = fs } -> List.iter class_field fs
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pcl_fun (_, eo, _, ce) -> may expr eo; class_expr ce
|
2012-01-20 19:40:37 -08:00
|
|
|
| Pcl_apply (ce, lel) ->
|
|
|
|
class_expr ce; List.iter (fun (_, e) -> expr e) lel
|
|
|
|
| Pcl_let (_, pel, ce) ->
|
2013-06-03 08:14:19 -07:00
|
|
|
List.iter binding pel; class_expr ce
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pcl_constraint (ce, _) -> class_expr ce
|
2013-04-10 10:26:55 -07:00
|
|
|
| Pcl_extension _ -> ()
|
2012-01-18 09:41:12 -08:00
|
|
|
|
2012-05-30 07:52:37 -07:00
|
|
|
and class_field cf =
|
|
|
|
match cf.pcf_desc with
|
2013-04-10 04:17:41 -07:00
|
|
|
| Pcf_inherit (_, ce, _) -> class_expr ce
|
|
|
|
| Pcf_val (_, _, Cfk_virtual _)
|
|
|
|
| Pcf_method (_, _, Cfk_virtual _ ) | Pcf_constraint _ -> ()
|
|
|
|
| Pcf_val (_, _, Cfk_concrete (_, e))
|
|
|
|
| Pcf_method (_, _, Cfk_concrete (_, e)) -> expr e
|
|
|
|
| Pcf_initializer e -> expr e
|
2014-05-04 13:42:34 -07:00
|
|
|
| Pcf_attribute _ | Pcf_extension _ -> ()
|
2012-01-18 09:41:12 -08:00
|
|
|
|
|
|
|
in
|
|
|
|
expr e
|
|
|
|
|
|
|
|
|
2013-04-15 09:23:22 -07:00
|
|
|
let all_idents_cases el =
|
2012-01-18 09:41:12 -08:00
|
|
|
let idents = Hashtbl.create 8 in
|
|
|
|
let f = function
|
2012-05-30 07:52:37 -07:00
|
|
|
| {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} ->
|
2012-01-20 06:24:54 -08:00
|
|
|
Hashtbl.replace idents id ()
|
2012-01-18 09:41:12 -08:00
|
|
|
| _ -> ()
|
|
|
|
in
|
2013-04-15 09:23:22 -07:00
|
|
|
List.iter
|
|
|
|
(fun cp ->
|
|
|
|
may (iter_expression f) cp.pc_guard;
|
|
|
|
iter_expression f cp.pc_rhs
|
|
|
|
)
|
|
|
|
el;
|
2012-01-18 09:41:12 -08:00
|
|
|
Hashtbl.fold (fun x () rest -> x :: rest) idents []
|
|
|
|
|
2003-04-01 17:32:09 -08:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Typing of constants *)
|
|
|
|
|
2013-05-23 08:12:04 -07:00
|
|
|
let type_constant = function
|
2011-11-24 01:02:48 -08:00
|
|
|
Const_int _ -> instance_def Predef.type_int
|
|
|
|
| Const_char _ -> instance_def Predef.type_char
|
|
|
|
| Const_string _ -> instance_def Predef.type_string
|
|
|
|
| Const_float _ -> instance_def Predef.type_float
|
|
|
|
| Const_int32 _ -> instance_def Predef.type_int32
|
|
|
|
| Const_int64 _ -> instance_def Predef.type_int64
|
|
|
|
| Const_nativeint _ -> instance_def Predef.type_nativeint
|
2005-08-13 13:59:37 -07:00
|
|
|
|
1999-11-30 08:07:38 -08:00
|
|
|
(* Specific version of type_option, using newty rather than newgenty *)
|
|
|
|
|
|
|
|
let type_option ty =
|
|
|
|
newty (Tconstr(Predef.path_option,[ty], ref Mnil))
|
|
|
|
|
2012-05-31 01:07:31 -07:00
|
|
|
let mkexp exp_desc exp_type exp_loc exp_env =
|
2013-03-25 07:16:07 -07:00
|
|
|
{ exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] }
|
2012-05-30 07:52:37 -07:00
|
|
|
|
1999-11-30 08:07:38 -08:00
|
|
|
let option_none ty loc =
|
2014-04-29 04:56:17 -07:00
|
|
|
let lid = Longident.Lident "None"
|
|
|
|
and env = Env.initial_safe_string in
|
|
|
|
let cnone = Env.lookup_constructor lid env in
|
|
|
|
mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env
|
1999-11-30 08:07:38 -08:00
|
|
|
|
|
|
|
let option_some texp =
|
2012-05-30 07:52:37 -07:00
|
|
|
let lid = Longident.Lident "Some" in
|
2014-04-29 04:56:17 -07:00
|
|
|
let csome = Env.lookup_constructor lid Env.initial_safe_string in
|
2013-04-17 02:46:52 -07:00
|
|
|
mkexp ( Texp_construct(mknoloc lid , csome, [texp]) )
|
2012-05-30 07:52:37 -07:00
|
|
|
(type_option texp.exp_type) texp.exp_loc texp.exp_env
|
1999-11-30 08:07:38 -08:00
|
|
|
|
|
|
|
let extract_option_type env ty =
|
|
|
|
match expand_head env ty with {desc = Tconstr(path, [ty], _)}
|
|
|
|
when Path.same path Predef.path_option -> ty
|
|
|
|
| _ -> assert false
|
|
|
|
|
2012-11-08 01:39:23 -08:00
|
|
|
let extract_concrete_record env ty =
|
|
|
|
match extract_concrete_typedecl env ty with
|
2012-11-10 19:46:59 -08:00
|
|
|
(p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields)
|
2012-11-08 01:39:23 -08:00
|
|
|
| _ -> raise Not_found
|
|
|
|
|
|
|
|
let extract_concrete_variant env ty =
|
|
|
|
match extract_concrete_typedecl env ty with
|
2014-05-04 16:08:45 -07:00
|
|
|
(p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs)
|
2012-11-08 01:39:23 -08:00
|
|
|
| _ -> raise Not_found
|
|
|
|
|
2012-10-18 00:35:30 -07:00
|
|
|
let extract_label_names sexp env ty =
|
|
|
|
try
|
2012-11-10 19:46:59 -08:00
|
|
|
let (_, _,fields) = extract_concrete_record env ty in
|
2013-09-27 03:54:55 -07:00
|
|
|
List.map (fun l -> l.Types.ld_id) fields
|
2012-10-18 00:35:30 -07:00
|
|
|
with Not_found ->
|
|
|
|
assert false
|
2001-06-28 18:46:46 -07:00
|
|
|
|
2014-04-15 02:53:51 -07:00
|
|
|
let explicit_arity =
|
2014-05-06 07:32:32 -07:00
|
|
|
List.exists
|
|
|
|
(function
|
|
|
|
| ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true
|
|
|
|
| _ -> false
|
|
|
|
)
|
2014-04-15 02:53:51 -07:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Typing of patterns *)
|
|
|
|
|
2010-11-09 00:21:44 -08:00
|
|
|
(* unification inside type_pat*)
|
2011-10-25 05:11:06 -07:00
|
|
|
let unify_pat_types loc env ty ty' =
|
2010-09-18 21:55:40 -07:00
|
|
|
try
|
|
|
|
unify env ty ty'
|
|
|
|
with
|
|
|
|
Unify trace ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env, Pattern_type_clash(trace)))
|
2010-09-18 21:55:40 -07:00
|
|
|
| Tags(l1,l2) ->
|
2013-01-29 06:21:12 -08:00
|
|
|
raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
|
2010-09-18 21:55:40 -07:00
|
|
|
|
2010-11-09 00:21:44 -08:00
|
|
|
(* unification inside type_exp and type_expect *)
|
2010-10-15 23:09:25 -07:00
|
|
|
let unify_exp_types loc env ty expected_ty =
|
|
|
|
(* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
|
|
|
|
Printtyp.raw_type_expr expected_ty; *)
|
2000-05-12 11:22:35 -07:00
|
|
|
try
|
2010-11-15 00:02:17 -08:00
|
|
|
unify env ty expected_ty
|
2002-01-03 18:02:50 -08:00
|
|
|
with
|
|
|
|
Unify trace ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env, Expr_type_clash(trace)))
|
2002-01-03 18:02:50 -08:00
|
|
|
| Tags(l1,l2) ->
|
2013-01-29 06:21:12 -08:00
|
|
|
raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
|
2010-10-15 23:09:25 -07:00
|
|
|
|
2010-11-09 00:21:44 -08:00
|
|
|
(* level at which to create the local type declarations *)
|
2010-12-13 16:53:47 -08:00
|
|
|
let newtype_level = ref None
|
2011-10-25 05:11:06 -07:00
|
|
|
let get_newtype_level () =
|
2010-12-13 16:53:47 -08:00
|
|
|
match !newtype_level with
|
2010-10-28 23:54:24 -07:00
|
|
|
Some y -> y
|
|
|
|
| None -> assert false
|
2010-10-04 01:38:22 -07:00
|
|
|
|
2011-10-25 05:11:06 -07:00
|
|
|
let unify_pat_types_gadt loc env ty ty' =
|
|
|
|
let newtype_level =
|
2010-12-13 16:53:47 -08:00
|
|
|
match !newtype_level with
|
2010-10-04 01:38:22 -07:00
|
|
|
| None -> assert false
|
|
|
|
| Some x -> x
|
|
|
|
in
|
2010-09-18 21:55:40 -07:00
|
|
|
try
|
2010-12-13 16:53:47 -08:00
|
|
|
unify_gadt ~newtype_level env ty ty'
|
2010-09-18 21:55:40 -07:00
|
|
|
with
|
|
|
|
Unify trace ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, !env, Pattern_type_clash(trace)))
|
2010-09-18 21:55:40 -07:00
|
|
|
| Tags(l1,l2) ->
|
2013-01-29 06:21:12 -08:00
|
|
|
raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
|
2010-10-24 22:25:33 -07:00
|
|
|
| Unification_recursive_abbrev trace ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, !env, Recursive_local_constraint trace))
|
2010-09-18 21:55:40 -07:00
|
|
|
|
|
|
|
|
2000-05-11 19:52:55 -07:00
|
|
|
(* Creating new conjunctive types is not allowed when typing patterns *)
|
2012-05-30 07:52:37 -07:00
|
|
|
|
2011-10-25 05:11:06 -07:00
|
|
|
let unify_pat env pat expected_ty =
|
2010-09-18 21:55:40 -07:00
|
|
|
unify_pat_types pat.pat_loc env pat.pat_type expected_ty
|
2000-05-12 11:22:35 -07:00
|
|
|
|
2003-08-18 01:26:18 -07:00
|
|
|
(* make all Reither present in open variants *)
|
|
|
|
let finalize_variant pat =
|
|
|
|
match pat.pat_desc with
|
2008-01-11 08:13:18 -08:00
|
|
|
Tpat_variant(tag, opat, r) ->
|
|
|
|
let row =
|
|
|
|
match expand_head pat.pat_env pat.pat_type with
|
|
|
|
{desc = Tvariant row} -> r := row; row_repr row
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
|
|
|
begin match row_field tag row with
|
2013-01-10 23:26:23 -08:00
|
|
|
| Rabsent -> () (* assert false *)
|
2003-08-18 01:26:18 -07:00
|
|
|
| Reither (true, [], _, e) when not row.row_closed ->
|
|
|
|
set_row_field e (Rpresent None)
|
|
|
|
| Reither (false, ty::tl, _, e) when not row.row_closed ->
|
|
|
|
set_row_field e (Rpresent (Some ty));
|
|
|
|
begin match opat with None -> assert false
|
|
|
|
| Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
|
|
|
|
end
|
2012-07-17 20:21:12 -07:00
|
|
|
| Reither (c, l, true, e) when not (row_fixed row) ->
|
2003-08-18 01:26:18 -07:00
|
|
|
set_row_field e (Reither (c, [], false, ref None))
|
|
|
|
| _ -> ()
|
|
|
|
end;
|
2008-01-11 08:13:18 -08:00
|
|
|
(* Force check of well-formedness WHY? *)
|
|
|
|
(* unify_pat pat.pat_env pat
|
2003-08-18 01:26:18 -07:00
|
|
|
(newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
|
2008-01-11 08:13:18 -08:00
|
|
|
row_bound=(); row_fixed=false; row_name=None})); *)
|
2003-08-18 01:26:18 -07:00
|
|
|
| _ -> ()
|
|
|
|
|
|
|
|
let rec iter_pattern f p =
|
|
|
|
f p;
|
|
|
|
iter_pattern_desc (iter_pattern f) p.pat_desc
|
|
|
|
|
|
|
|
let has_variants p =
|
|
|
|
try
|
|
|
|
iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ())
|
|
|
|
p;
|
|
|
|
false
|
|
|
|
with Exit ->
|
|
|
|
true
|
|
|
|
|
|
|
|
|
|
|
|
(* pattern environment *)
|
2012-05-31 01:07:31 -07:00
|
|
|
let pattern_variables = ref ([] :
|
|
|
|
(Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) list)
|
2002-06-03 00:33:48 -07:00
|
|
|
let pattern_force = ref ([] : (unit -> unit) list)
|
2007-05-16 01:21:41 -07:00
|
|
|
let pattern_scope = ref (None : Annot.ident option);;
|
2010-10-21 16:59:33 -07:00
|
|
|
let allow_modules = ref false
|
2012-05-30 07:52:37 -07:00
|
|
|
let module_variables = ref ([] : (string loc * Location.t) list)
|
2010-10-21 16:59:33 -07:00
|
|
|
let reset_pattern scope allow =
|
2002-06-03 00:33:48 -07:00
|
|
|
pattern_variables := [];
|
2007-05-16 01:21:41 -07:00
|
|
|
pattern_force := [];
|
|
|
|
pattern_scope := scope;
|
2010-10-21 16:59:33 -07:00
|
|
|
allow_modules := allow;
|
|
|
|
module_variables := [];
|
2007-05-16 01:21:41 -07:00
|
|
|
;;
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2011-12-29 09:49:58 -08:00
|
|
|
let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
|
2012-05-31 01:07:31 -07:00
|
|
|
if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt)
|
|
|
|
!pattern_variables
|
2012-08-21 00:10:35 -07:00
|
|
|
then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
|
2012-05-30 07:52:37 -07:00
|
|
|
let id = Ident.create name.txt in
|
2012-05-31 01:07:31 -07:00
|
|
|
pattern_variables :=
|
|
|
|
(id, ty, name, loc, is_as_variable) :: !pattern_variables;
|
2010-10-21 16:59:33 -07:00
|
|
|
if is_module then begin
|
|
|
|
(* Note: unpack patterns enter a variable of the same name *)
|
2012-01-21 19:15:14 -08:00
|
|
|
if not !allow_modules then
|
|
|
|
raise (Error (loc, Env.empty, Modules_not_allowed));
|
2010-10-21 16:59:33 -07:00
|
|
|
module_variables := (name, loc) :: !module_variables
|
2012-05-31 01:07:31 -07:00
|
|
|
end else
|
|
|
|
(* moved to genannot *)
|
|
|
|
may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s)))
|
|
|
|
!pattern_scope;
|
1995-05-04 03:15:53 -07:00
|
|
|
id
|
|
|
|
|
2000-10-02 07:18:05 -07:00
|
|
|
let sort_pattern_variables vs =
|
|
|
|
List.sort
|
2012-05-31 01:07:31 -07:00
|
|
|
(fun (x,_,_,_,_) (y,_,_,_,_) ->
|
|
|
|
Pervasives.compare (Ident.name x) (Ident.name y))
|
2000-10-02 07:18:05 -07:00
|
|
|
vs
|
|
|
|
|
|
|
|
let enter_orpat_variables loc env p1_vs p2_vs =
|
|
|
|
(* unify_vars operate on sorted lists *)
|
2005-08-13 13:59:37 -07:00
|
|
|
|
2000-10-02 07:18:05 -07:00
|
|
|
let p1_vs = sort_pattern_variables p1_vs
|
|
|
|
and p2_vs = sort_pattern_variables p2_vs in
|
|
|
|
|
2005-08-13 13:59:37 -07:00
|
|
|
let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
|
2012-05-30 07:52:37 -07:00
|
|
|
| (x1,t1,_,l1,a1)::rem1, (x2,t2,_,l2,a2)::rem2 when Ident.equal x1 x2 ->
|
2000-10-02 07:18:05 -07:00
|
|
|
if x1==x2 then
|
|
|
|
unify_vars rem1 rem2
|
|
|
|
else begin
|
|
|
|
begin try
|
2001-03-02 16:14:35 -08:00
|
|
|
unify env t1 t2
|
2000-10-02 07:18:05 -07:00
|
|
|
with
|
|
|
|
| Unify trace ->
|
2014-01-27 08:27:05 -08:00
|
|
|
raise(Error(loc, env, Or_pattern_type_clash(x1, trace)))
|
2011-10-25 05:11:06 -07:00
|
|
|
end;
|
2000-10-02 07:18:05 -07:00
|
|
|
(x2,x1)::unify_vars rem1 rem2
|
|
|
|
end
|
|
|
|
| [],[] -> []
|
2012-08-21 00:10:35 -07:00
|
|
|
| (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars x))
|
|
|
|
| [],(x,_,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars x))
|
2012-05-30 07:52:37 -07:00
|
|
|
| (x,_,_,_,_)::_, (y,_,_,_,_)::_ ->
|
2000-10-02 07:18:05 -07:00
|
|
|
let min_var =
|
|
|
|
if Ident.name x < Ident.name y then x
|
|
|
|
else y in
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error (loc, env, Orpat_vars min_var)) in
|
2000-10-02 07:18:05 -07:00
|
|
|
unify_vars p1_vs p2_vs
|
|
|
|
|
2000-06-29 02:11:42 -07:00
|
|
|
let rec build_as_type env p =
|
1999-11-30 08:07:38 -08:00
|
|
|
match p.pat_desc with
|
2012-05-30 07:52:37 -07:00
|
|
|
Tpat_alias(p1,_, _) -> build_as_type env p1
|
2000-06-29 02:11:42 -07:00
|
|
|
| Tpat_tuple pl ->
|
|
|
|
let tyl = List.map (build_as_type env) pl in
|
|
|
|
newty (Ttuple tyl)
|
2013-04-17 02:46:52 -07:00
|
|
|
| Tpat_construct(_, cstr, pl) ->
|
2010-12-13 22:33:06 -08:00
|
|
|
let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
|
|
|
|
if keep then p.pat_type else
|
2000-06-29 02:11:42 -07:00
|
|
|
let tyl = List.map (build_as_type env) pl in
|
|
|
|
let ty_args, ty_res = instance_constructor cstr in
|
|
|
|
List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
|
|
|
|
(List.combine pl tyl) ty_args;
|
2000-06-12 23:59:29 -07:00
|
|
|
ty_res
|
2001-09-25 02:54:18 -07:00
|
|
|
| Tpat_variant(l, p', _) ->
|
|
|
|
let ty = may_map (build_as_type env) p' in
|
|
|
|
newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
|
2008-01-11 08:13:18 -08:00
|
|
|
row_bound=(); row_name=None;
|
2002-04-18 00:27:47 -07:00
|
|
|
row_fixed=false; row_closed=false})
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tpat_record (lpl,_) ->
|
2012-10-24 05:03:00 -07:00
|
|
|
let lbl = snd3 (List.hd lpl) in
|
2005-02-18 05:38:00 -08:00
|
|
|
if lbl.lbl_private = Private then p.pat_type else
|
2000-06-29 02:11:42 -07:00
|
|
|
let ty = newvar () in
|
2012-10-24 05:03:00 -07:00
|
|
|
let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
|
2000-06-29 02:11:42 -07:00
|
|
|
let do_label lbl =
|
2002-04-18 00:27:47 -07:00
|
|
|
let _, ty_arg, ty_res = instance_label false lbl in
|
2000-06-29 02:11:42 -07:00
|
|
|
unify_pat env {p with pat_type = ty} ty_res;
|
2008-01-11 08:13:18 -08:00
|
|
|
let refinable =
|
|
|
|
lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl &&
|
|
|
|
match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in
|
|
|
|
if refinable then begin
|
2003-10-28 07:26:48 -08:00
|
|
|
let arg = List.assoc lbl.lbl_pos ppl in
|
2000-06-29 02:11:42 -07:00
|
|
|
unify_pat env {arg with pat_type = build_as_type env arg} ty_arg
|
|
|
|
end else begin
|
2002-04-18 00:27:47 -07:00
|
|
|
let _, ty_arg', ty_res' = instance_label false lbl in
|
2001-03-02 16:14:35 -08:00
|
|
|
unify env ty_arg ty_arg';
|
2000-06-29 02:11:42 -07:00
|
|
|
unify_pat env p ty_res'
|
|
|
|
end in
|
|
|
|
Array.iter do_label lbl.lbl_all;
|
|
|
|
ty
|
2008-01-11 08:13:18 -08:00
|
|
|
| Tpat_or(p1, p2, row) ->
|
|
|
|
begin match row with
|
|
|
|
None ->
|
|
|
|
let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
|
|
|
|
unify_pat env {p2 with pat_type = ty2} ty1;
|
|
|
|
ty1
|
|
|
|
| Some row ->
|
|
|
|
let row = row_repr row in
|
|
|
|
newty (Tvariant{row with row_closed=false; row_more=newvar()})
|
|
|
|
end
|
2008-07-09 06:03:38 -07:00
|
|
|
| Tpat_any | Tpat_var _ | Tpat_constant _
|
|
|
|
| Tpat_array _ | Tpat_lazy _ -> p.pat_type
|
2000-06-12 23:59:29 -07:00
|
|
|
|
2010-05-05 13:51:54 -07:00
|
|
|
let build_or_pat env loc lid =
|
2010-05-18 09:46:46 -07:00
|
|
|
let path, decl = Typetexp.find_type env loc lid
|
2000-02-21 19:08:08 -08:00
|
|
|
in
|
2000-02-24 02:18:25 -08:00
|
|
|
let tyl = List.map (fun _ -> newvar()) decl.type_params in
|
2008-01-11 08:13:18 -08:00
|
|
|
let row0 =
|
2000-02-24 02:18:25 -08:00
|
|
|
let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
|
|
|
|
match ty.desc with
|
2008-01-11 08:13:18 -08:00
|
|
|
Tvariant row when static_row row -> row
|
2012-01-21 19:15:14 -08:00
|
|
|
| _ -> raise(Error(loc, env, Not_a_variant_type lid))
|
2000-02-21 19:08:08 -08:00
|
|
|
in
|
|
|
|
let pats, fields =
|
|
|
|
List.fold_left
|
|
|
|
(fun (pats,fields) (l,f) ->
|
|
|
|
match row_field_repr f with
|
|
|
|
Rpresent None ->
|
|
|
|
(l,None) :: pats,
|
2001-03-02 16:14:35 -08:00
|
|
|
(l, Reither(true,[], true, ref None)) :: fields
|
2000-02-21 19:08:08 -08:00
|
|
|
| Rpresent (Some ty) ->
|
2003-04-01 17:32:09 -08:00
|
|
|
(l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_type=ty; pat_extra=[]; pat_attributes=[]})
|
2000-02-21 19:08:08 -08:00
|
|
|
:: pats,
|
2001-03-02 16:14:35 -08:00
|
|
|
(l, Reither(false, [ty], true, ref None)) :: fields
|
2000-02-21 19:08:08 -08:00
|
|
|
| _ -> pats, fields)
|
2008-01-11 08:13:18 -08:00
|
|
|
([],[]) (row_repr row0).row_fields in
|
2000-02-21 19:08:08 -08:00
|
|
|
let row =
|
2008-01-11 08:13:18 -08:00
|
|
|
{ row_fields = List.rev fields; row_more = newvar(); row_bound = ();
|
2002-04-18 00:27:47 -07:00
|
|
|
row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
|
2000-02-21 19:08:08 -08:00
|
|
|
in
|
|
|
|
let ty = newty (Tvariant row) in
|
2002-05-26 20:09:18 -07:00
|
|
|
let gloc = {loc with Location.loc_ghost=true} in
|
2008-01-11 08:13:18 -08:00
|
|
|
let row' = ref {row with row_more=newvar()} in
|
2000-02-21 19:08:08 -08:00
|
|
|
let pats =
|
2014-01-22 17:58:37 -08:00
|
|
|
List.map
|
|
|
|
(fun (l,p) ->
|
|
|
|
{pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
|
|
|
|
pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
|
2000-02-21 19:08:08 -08:00
|
|
|
pats
|
|
|
|
in
|
|
|
|
match pats with
|
2012-01-21 19:15:14 -08:00
|
|
|
[] -> raise(Error(loc, env, Not_a_variant_type lid))
|
2000-02-21 19:08:08 -08:00
|
|
|
| pat :: pats ->
|
2003-02-24 07:13:01 -08:00
|
|
|
let r =
|
|
|
|
List.fold_left
|
2014-01-22 17:58:37 -08:00
|
|
|
(fun pat pat0 ->
|
|
|
|
{pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
|
|
|
|
pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
|
2003-02-24 07:13:01 -08:00
|
|
|
pat pats in
|
2012-05-30 07:52:37 -07:00
|
|
|
(path, rp { r with pat_loc = loc },ty)
|
2000-02-21 19:08:08 -08:00
|
|
|
|
2012-10-29 00:54:06 -07:00
|
|
|
(* Type paths *)
|
2004-06-14 14:29:05 -07:00
|
|
|
|
2012-10-18 00:35:30 -07:00
|
|
|
let rec expand_path env p =
|
2012-10-18 20:21:27 -07:00
|
|
|
let decl =
|
|
|
|
try Some (Env.find_type p env) with Not_found -> None
|
|
|
|
in
|
|
|
|
match decl with
|
|
|
|
Some {type_manifest = Some ty} ->
|
|
|
|
begin match repr ty with
|
2013-09-04 08:12:37 -07:00
|
|
|
{desc=Tconstr(p,_,_)} -> expand_path env p
|
2014-05-07 03:55:05 -07:00
|
|
|
| _ -> p
|
|
|
|
(* PR#6394: recursive module may introduce incoherent manifest *)
|
2012-10-18 20:21:27 -07:00
|
|
|
end
|
2013-10-02 06:23:48 -07:00
|
|
|
| _ ->
|
2013-10-03 19:06:40 -07:00
|
|
|
let p' = Env.normalize_path None env p in
|
2013-10-02 06:23:48 -07:00
|
|
|
if Path.same p p' then p else expand_path env p'
|
2012-10-18 00:35:30 -07:00
|
|
|
|
2012-10-30 02:02:04 -07:00
|
|
|
let compare_type_path env tpath1 tpath2 =
|
2012-10-29 00:54:06 -07:00
|
|
|
Path.same (expand_path env tpath1) (expand_path env tpath2)
|
|
|
|
|
2011-06-15 02:26:30 -07:00
|
|
|
(* Records *)
|
2000-02-21 19:08:08 -08:00
|
|
|
|
2012-10-29 00:54:06 -07:00
|
|
|
module NameChoice(Name : sig
|
|
|
|
type t
|
2012-10-31 05:36:13 -07:00
|
|
|
val type_kind: string
|
2012-10-31 20:32:34 -07:00
|
|
|
val get_name: t -> string
|
|
|
|
val get_type: t -> type_expr
|
|
|
|
val get_descrs: Env.type_descriptions -> t list
|
|
|
|
val fold: (t -> 'a -> 'a) -> Longident.t option -> Env.t -> 'a -> 'a
|
2012-12-26 18:34:49 -08:00
|
|
|
val unbound_name_error: Env.t -> Longident.t loc -> 'a
|
2012-10-29 00:54:06 -07:00
|
|
|
end) = struct
|
|
|
|
open Name
|
|
|
|
|
2012-10-31 20:32:34 -07:00
|
|
|
let get_type_path env d =
|
|
|
|
match (get_type d).desc with
|
|
|
|
| Tconstr(p, _, _) -> p
|
|
|
|
| _ -> assert false
|
|
|
|
|
|
|
|
let spellcheck ppf env p lid =
|
|
|
|
Typetexp.spellcheck_simple ppf fold
|
|
|
|
(fun d ->
|
2013-09-04 08:12:37 -07:00
|
|
|
if compare_type_path env p (get_type_path env d)
|
|
|
|
then get_name d else "") env lid
|
2012-10-31 20:32:34 -07:00
|
|
|
|
|
|
|
let lookup_from_type env tpath lid =
|
|
|
|
let descrs = get_descrs (Env.find_type_descrs tpath env) in
|
|
|
|
Env.mark_type_used (Path.last tpath) (Env.find_type tpath env);
|
2012-11-10 19:46:59 -08:00
|
|
|
match lid.txt with
|
|
|
|
Longident.Lident s -> begin
|
|
|
|
try
|
|
|
|
List.find (fun nd -> get_name nd = s) descrs
|
2013-09-04 08:12:37 -07:00
|
|
|
with Not_found ->
|
2013-09-19 00:25:51 -07:00
|
|
|
raise (Error (lid.loc, env,
|
|
|
|
Wrong_name ("", newvar (), type_kind, tpath, lid.txt)))
|
2012-11-10 19:46:59 -08:00
|
|
|
end
|
2012-10-31 20:32:34 -07:00
|
|
|
| _ -> raise Not_found
|
|
|
|
|
2013-03-12 07:56:15 -07:00
|
|
|
let rec unique eq acc = function
|
|
|
|
[] -> List.rev acc
|
|
|
|
| x :: rem ->
|
|
|
|
if List.exists (eq x) acc then unique eq acc rem
|
|
|
|
else unique eq (x :: acc) rem
|
|
|
|
|
|
|
|
let ambiguous_types env lbl others =
|
2012-10-29 00:54:06 -07:00
|
|
|
let tpath = get_type_path env lbl in
|
2012-10-30 02:02:04 -07:00
|
|
|
let others =
|
2013-03-12 07:56:15 -07:00
|
|
|
List.map (fun (lbl, _) -> get_type_path env lbl) others in
|
|
|
|
let tpaths = unique (compare_type_path env) [tpath] others in
|
|
|
|
match tpaths with
|
|
|
|
[_] -> []
|
2013-04-26 06:09:24 -07:00
|
|
|
| _ -> List.map Printtyp.string_of_path tpaths
|
2012-10-29 00:54:06 -07:00
|
|
|
|
|
|
|
let disambiguate_by_type env tpath lbls =
|
|
|
|
let check_type (lbl, _) =
|
|
|
|
let lbl_tpath = get_type_path env lbl in
|
|
|
|
compare_type_path env tpath lbl_tpath
|
|
|
|
in
|
|
|
|
List.find check_type lbls
|
|
|
|
|
2012-12-07 18:40:56 -08:00
|
|
|
let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ())
|
|
|
|
?scope lid env opath lbls =
|
2013-02-18 18:45:09 -08:00
|
|
|
let scope = match scope with None -> lbls | Some l -> l in
|
|
|
|
let lbl = match opath with
|
2012-10-31 05:36:13 -07:00
|
|
|
None ->
|
2013-09-04 08:12:37 -07:00
|
|
|
begin match lbls with
|
2012-12-26 18:34:49 -08:00
|
|
|
[] -> unbound_name_error env lid
|
2013-09-04 08:12:37 -07:00
|
|
|
| (lbl, use) :: rest ->
|
|
|
|
use ();
|
2013-03-12 07:56:15 -07:00
|
|
|
let paths = ambiguous_types env lbl rest in
|
2013-09-04 08:12:37 -07:00
|
|
|
if paths <> [] then
|
|
|
|
warn lid.loc
|
|
|
|
(Warnings.Ambiguous_name ([Longident.last lid.txt],
|
2013-06-03 04:12:31 -07:00
|
|
|
paths, false));
|
2013-09-04 08:12:37 -07:00
|
|
|
lbl
|
|
|
|
end
|
2012-11-10 19:46:59 -08:00
|
|
|
| Some(tpath0, tpath, pr) ->
|
2013-09-04 08:12:37 -07:00
|
|
|
let warn_pr () =
|
|
|
|
let kind = if type_kind = "record" then "field" else "constructor" in
|
2012-10-31 05:36:13 -07:00
|
|
|
warn lid.loc
|
|
|
|
(Warnings.Not_principal
|
2013-09-04 08:12:37 -07:00
|
|
|
("this type-based " ^ kind ^ " disambiguation"))
|
|
|
|
in
|
2012-10-29 00:54:06 -07:00
|
|
|
try
|
2012-10-31 05:36:13 -07:00
|
|
|
let lbl, use = disambiguate_by_type env tpath scope in
|
2012-10-29 00:54:06 -07:00
|
|
|
use ();
|
|
|
|
if not pr then begin
|
|
|
|
(* Check if non-principal type is affecting result *)
|
|
|
|
match lbls with
|
2012-10-31 05:36:13 -07:00
|
|
|
[] -> warn_pr ()
|
2012-10-30 02:02:04 -07:00
|
|
|
| (lbl', use') :: rest ->
|
2012-10-29 00:54:06 -07:00
|
|
|
let lbl_tpath = get_type_path env lbl' in
|
2012-10-31 05:36:13 -07:00
|
|
|
if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
|
2013-03-12 07:56:15 -07:00
|
|
|
else
|
|
|
|
let paths = ambiguous_types env lbl rest in
|
|
|
|
if paths <> [] then
|
|
|
|
warn lid.loc
|
|
|
|
(Warnings.Ambiguous_name ([Longident.last lid.txt],
|
|
|
|
paths, false))
|
2012-10-29 00:54:06 -07:00
|
|
|
end;
|
|
|
|
lbl
|
2012-10-31 05:36:13 -07:00
|
|
|
with Not_found -> try
|
2012-11-10 19:46:59 -08:00
|
|
|
let lbl = lookup_from_type env tpath lid in
|
2012-12-07 18:40:56 -08:00
|
|
|
check_lk tpath lbl;
|
2013-04-26 06:09:24 -07:00
|
|
|
let s = Printtyp.string_of_path tpath in
|
2012-10-30 02:02:04 -07:00
|
|
|
warn lid.loc
|
2013-04-26 06:09:24 -07:00
|
|
|
(Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false));
|
2012-10-31 05:36:13 -07:00
|
|
|
if not pr then warn_pr ();
|
2012-10-29 00:54:06 -07:00
|
|
|
lbl
|
2013-09-04 08:12:37 -07:00
|
|
|
with Not_found ->
|
2012-12-26 18:34:49 -08:00
|
|
|
if lbls = [] then unbound_name_error env lid else
|
2012-11-10 19:46:59 -08:00
|
|
|
let tp = (tpath0, expand_path env tpath) in
|
2013-09-04 08:12:37 -07:00
|
|
|
let tpl =
|
|
|
|
List.map
|
|
|
|
(fun (lbl, _) ->
|
2012-11-10 19:46:59 -08:00
|
|
|
let tp0 = get_type_path env lbl in
|
|
|
|
let tp = expand_path env tp0 in
|
|
|
|
(tp0, tp))
|
|
|
|
lbls
|
|
|
|
in
|
2013-01-29 06:21:12 -08:00
|
|
|
raise (Error (lid.loc, env,
|
2012-12-06 18:22:18 -08:00
|
|
|
Name_type_mismatch (type_kind, lid.txt, tp, tpl)))
|
2013-02-18 18:45:09 -08:00
|
|
|
in
|
|
|
|
begin match scope with
|
|
|
|
(lab1,_)::_ when lab1 == lbl -> ()
|
|
|
|
| _ ->
|
|
|
|
Location.prerr_warning lid.loc
|
|
|
|
(Warnings.Disambiguated_name(get_name lbl))
|
|
|
|
end;
|
|
|
|
lbl
|
2012-10-29 00:54:06 -07:00
|
|
|
end
|
|
|
|
|
2013-09-19 00:25:51 -07:00
|
|
|
let wrap_disambiguate kind ty f x =
|
|
|
|
try f x with Error (loc, env, Wrong_name (_,_,tk,tp,lid)) ->
|
|
|
|
raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,lid)))
|
|
|
|
|
2012-10-29 00:54:06 -07:00
|
|
|
module Label = NameChoice (struct
|
|
|
|
type t = label_description
|
2012-10-31 05:36:13 -07:00
|
|
|
let type_kind = "record"
|
2012-10-31 20:32:34 -07:00
|
|
|
let get_name lbl = lbl.lbl_name
|
|
|
|
let get_type lbl = lbl.lbl_res
|
|
|
|
let get_descrs = snd
|
|
|
|
let fold = Env.fold_labels
|
2012-10-29 00:54:06 -07:00
|
|
|
let unbound_name_error = Typetexp.unbound_label_error
|
|
|
|
end)
|
|
|
|
|
|
|
|
let disambiguate_label_by_ids keep env closed ids labels =
|
|
|
|
let check_ids (lbl, _) =
|
|
|
|
let lbls = Hashtbl.create 8 in
|
|
|
|
Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all;
|
|
|
|
List.for_all (Hashtbl.mem lbls) ids
|
|
|
|
and check_closed (lbl, _) =
|
|
|
|
(not closed || List.length ids = Array.length lbl.lbl_all)
|
2012-09-21 04:16:02 -07:00
|
|
|
in
|
2012-10-29 00:54:06 -07:00
|
|
|
let labels' = List.filter check_ids labels in
|
2012-10-29 18:02:08 -07:00
|
|
|
if keep && labels' = [] then (false, labels) else
|
2012-10-29 00:54:06 -07:00
|
|
|
let labels'' = List.filter check_closed labels' in
|
2012-11-10 19:46:59 -08:00
|
|
|
if keep && labels'' = [] then (false, labels') else (true, labels'')
|
2012-10-30 02:02:04 -07:00
|
|
|
|
2012-10-29 00:54:06 -07:00
|
|
|
(* Only issue warnings once per record constructor/pattern *)
|
2012-10-29 18:02:08 -07:00
|
|
|
let disambiguate_lid_a_list loc closed env opath lid_a_list =
|
2012-10-29 00:54:06 -07:00
|
|
|
let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in
|
2013-04-26 06:09:24 -07:00
|
|
|
let w_pr = ref false and w_amb = ref []
|
|
|
|
and w_scope = ref [] and w_scope_ty = ref "" in
|
2012-10-29 00:54:06 -07:00
|
|
|
let warn loc msg =
|
2012-10-29 18:02:08 -07:00
|
|
|
let open Warnings in
|
|
|
|
match msg with
|
|
|
|
| Not_principal _ -> w_pr := true
|
2013-03-12 07:56:15 -07:00
|
|
|
| Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb
|
2013-04-26 06:09:24 -07:00
|
|
|
| Name_out_of_scope(ty, [s], _) ->
|
|
|
|
w_scope := s :: !w_scope; w_scope_ty := ty
|
2012-10-29 18:02:08 -07:00
|
|
|
| _ -> Location.prerr_warning loc msg
|
|
|
|
in
|
|
|
|
let process_label lid =
|
|
|
|
(* Strategy for each field:
|
|
|
|
* collect all the labels in scope for that name
|
|
|
|
* if the type is known and principal, just eventually warn
|
|
|
|
if the real label was not in scope
|
|
|
|
* fail if there is no known type and no label found
|
|
|
|
* otherwise use other fields to reduce the list of candidates
|
|
|
|
* if there is no known type reduce it incrementally, so that
|
|
|
|
there is still at least one candidate (for error message)
|
|
|
|
* if the reduced list is valid, call Label.disambiguate
|
|
|
|
*)
|
2012-10-31 05:36:13 -07:00
|
|
|
let scope = Typetexp.find_all_labels env lid.loc lid.txt in
|
|
|
|
if opath = None && scope = [] then
|
2012-10-29 18:02:08 -07:00
|
|
|
Typetexp.unbound_label_error env lid;
|
|
|
|
let (ok, labels) =
|
|
|
|
match opath with
|
2012-11-10 19:46:59 -08:00
|
|
|
Some (_, _, true) -> (true, scope) (* disambiguate only checks scope *)
|
2012-10-31 05:36:13 -07:00
|
|
|
| _ -> disambiguate_label_by_ids (opath=None) env closed ids scope
|
2012-10-29 00:54:06 -07:00
|
|
|
in
|
2012-10-31 05:36:13 -07:00
|
|
|
if ok then Label.disambiguate lid env opath labels ~warn ~scope
|
2012-10-29 18:02:08 -07:00
|
|
|
else fst (List.hd labels) (* will fail later *)
|
2012-10-29 00:54:06 -07:00
|
|
|
in
|
2012-10-29 18:02:08 -07:00
|
|
|
let lbl_a_list =
|
|
|
|
List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in
|
|
|
|
if !w_pr then
|
|
|
|
Location.prerr_warning loc
|
2013-03-12 07:56:15 -07:00
|
|
|
(Warnings.Not_principal "this type-based record disambiguation")
|
|
|
|
else begin
|
|
|
|
match List.rev !w_amb with
|
|
|
|
(_,types)::others as amb ->
|
|
|
|
let paths =
|
|
|
|
List.map (fun (_,lbl,_) -> Label.get_type_path env lbl) lbl_a_list in
|
|
|
|
let path = List.hd paths in
|
|
|
|
if List.for_all (compare_type_path env path) (List.tl paths) then
|
|
|
|
Location.prerr_warning loc
|
|
|
|
(Warnings.Ambiguous_name (List.map fst amb, types, true))
|
|
|
|
else
|
|
|
|
List.iter
|
|
|
|
(fun (s,l) -> Location.prerr_warning loc
|
|
|
|
(Warnings.Ambiguous_name ([s],l,false)))
|
|
|
|
amb
|
|
|
|
| _ -> ()
|
|
|
|
end;
|
2012-10-30 02:02:04 -07:00
|
|
|
if !w_scope <> [] then
|
|
|
|
Location.prerr_warning loc
|
2013-04-26 06:09:24 -07:00
|
|
|
(Warnings.Name_out_of_scope (!w_scope_ty, List.rev !w_scope, true));
|
2012-10-29 18:02:08 -07:00
|
|
|
lbl_a_list
|
2012-10-29 00:54:06 -07:00
|
|
|
|
2004-06-14 14:29:05 -07:00
|
|
|
let rec find_record_qual = function
|
|
|
|
| [] -> None
|
2012-05-30 07:52:37 -07:00
|
|
|
| ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname
|
2004-06-14 14:29:05 -07:00
|
|
|
| _ :: rest -> find_record_qual rest
|
|
|
|
|
2012-10-29 00:54:06 -07:00
|
|
|
let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list =
|
2011-06-15 02:26:30 -07:00
|
|
|
let lbl_a_list =
|
2012-10-29 00:54:06 -07:00
|
|
|
match lid_a_list, labels with
|
|
|
|
({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s ->
|
|
|
|
(* Special case for rebuilt syntax trees *)
|
|
|
|
List.map
|
|
|
|
(function lid, a -> match lid.txt with
|
|
|
|
Longident.Lident s -> lid, Hashtbl.find labels s, a
|
|
|
|
| _ -> assert false)
|
|
|
|
lid_a_list
|
|
|
|
| _ ->
|
|
|
|
let lid_a_list =
|
|
|
|
match find_record_qual lid_a_list with
|
|
|
|
None -> lid_a_list
|
|
|
|
| Some modname ->
|
|
|
|
List.map
|
|
|
|
(fun (lid, a as lid_a) ->
|
|
|
|
match lid.txt with Longident.Lident s ->
|
|
|
|
{lid with txt=Longident.Ldot (modname, s)}, a
|
|
|
|
| _ -> lid_a)
|
|
|
|
lid_a_list
|
|
|
|
in
|
2012-10-29 18:02:08 -07:00
|
|
|
disambiguate_lid_a_list loc closed env opath lid_a_list
|
2012-10-29 00:54:06 -07:00
|
|
|
in
|
2011-06-15 02:26:30 -07:00
|
|
|
(* Invariant: records are sorted in the typed tree *)
|
|
|
|
let lbl_a_list =
|
|
|
|
List.sort
|
2012-10-29 00:54:06 -07:00
|
|
|
(fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
|
2011-06-15 02:26:30 -07:00
|
|
|
lbl_a_list
|
|
|
|
in
|
|
|
|
List.map type_lbl_a lbl_a_list
|
2012-05-30 07:52:37 -07:00
|
|
|
;;
|
2011-06-15 02:26:30 -07:00
|
|
|
|
2009-09-12 05:41:07 -07:00
|
|
|
(* Checks over the labels mentioned in a record pattern:
|
|
|
|
no duplicate definitions (error); properly closed (warning) *)
|
|
|
|
|
|
|
|
let check_recordpat_labels loc lbl_pat_list closed =
|
|
|
|
match lbl_pat_list with
|
|
|
|
| [] -> () (* should not happen *)
|
2012-10-24 05:03:00 -07:00
|
|
|
| (_, label1, _) :: _ ->
|
2009-09-12 05:41:07 -07:00
|
|
|
let all = label1.lbl_all in
|
|
|
|
let defined = Array.make (Array.length all) false in
|
2012-10-24 05:03:00 -07:00
|
|
|
let check_defined (_, label, _) =
|
2009-09-12 05:41:07 -07:00
|
|
|
if defined.(label.lbl_pos)
|
2013-01-29 06:21:12 -08:00
|
|
|
then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name))
|
2009-09-12 05:41:07 -07:00
|
|
|
else defined.(label.lbl_pos) <- true in
|
|
|
|
List.iter check_defined lbl_pat_list;
|
|
|
|
if closed = Closed
|
|
|
|
&& Warnings.is_active (Warnings.Non_closed_record_pattern "")
|
|
|
|
then begin
|
|
|
|
let undefined = ref [] in
|
|
|
|
for i = 0 to Array.length all - 1 do
|
|
|
|
if not defined.(i) then undefined := all.(i).lbl_name :: !undefined
|
|
|
|
done;
|
|
|
|
if !undefined <> [] then begin
|
|
|
|
let u = String.concat ", " (List.rev !undefined) in
|
|
|
|
Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)
|
|
|
|
end
|
|
|
|
end
|
|
|
|
|
2012-12-06 01:41:21 -08:00
|
|
|
(* Constructors *)
|
|
|
|
|
|
|
|
module Constructor = NameChoice (struct
|
|
|
|
type t = constructor_description
|
|
|
|
let type_kind = "variant"
|
|
|
|
let get_name cstr = cstr.cstr_name
|
|
|
|
let get_type cstr = cstr.cstr_res
|
|
|
|
let get_descrs = fst
|
|
|
|
let fold = Env.fold_constructors
|
|
|
|
let unbound_name_error = Typetexp.unbound_constructor_error
|
|
|
|
end)
|
|
|
|
|
2011-10-25 05:11:06 -07:00
|
|
|
(* unification of a type with a tconstr with
|
|
|
|
freshly created arguments *)
|
|
|
|
let unify_head_only loc env ty constr =
|
2010-12-13 22:33:06 -08:00
|
|
|
let (_, ty_res) = instance_constructor constr in
|
2010-11-09 00:21:44 -08:00
|
|
|
match (repr ty_res).desc with
|
|
|
|
| Tconstr(p,args,m) ->
|
2011-10-25 05:11:06 -07:00
|
|
|
ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);
|
2010-11-09 00:21:44 -08:00
|
|
|
enforce_constraints env ty_res;
|
2011-10-25 05:11:06 -07:00
|
|
|
unify_pat_types loc env ty ty_res
|
2010-11-09 00:21:44 -08:00
|
|
|
| _ -> assert false
|
|
|
|
|
2009-09-12 05:41:07 -07:00
|
|
|
(* Typing of patterns *)
|
|
|
|
|
2010-12-13 22:33:06 -08:00
|
|
|
(* type_pat does not generate local constraints inside or patterns *)
|
2011-10-25 05:11:06 -07:00
|
|
|
type type_pat_mode =
|
|
|
|
| Normal
|
|
|
|
| Inside_or
|
2010-10-18 22:24:36 -07:00
|
|
|
|
2010-12-13 22:33:06 -08:00
|
|
|
(* type_pat propagates the expected type as well as maps for
|
|
|
|
constructors and labels.
|
|
|
|
Unification may update the typing environment. *)
|
|
|
|
let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
|
|
|
|
let type_pat ?(mode=mode) ?(env=env) =
|
|
|
|
type_pat ~constrs ~labels ~no_existentials ~mode ~env in
|
2009-09-04 09:19:35 -07:00
|
|
|
let loc = sp.ppat_loc in
|
1995-05-04 03:15:53 -07:00
|
|
|
match sp.ppat_desc with
|
|
|
|
Ppat_any ->
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_any;
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-09-12 22:28:30 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2011-10-25 05:11:06 -07:00
|
|
|
| Ppat_var name ->
|
2010-10-18 22:24:36 -07:00
|
|
|
let id = enter_variable loc name expected_ty in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_desc = Tpat_var (id, name);
|
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-09-22 00:04:22 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2010-10-21 16:59:33 -07:00
|
|
|
| Ppat_unpack name ->
|
2011-07-29 03:32:43 -07:00
|
|
|
let id = enter_variable loc name expected_ty ~is_module:true in
|
2010-10-21 16:59:33 -07:00
|
|
|
rp {
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_desc = Tpat_var (id, name);
|
|
|
|
pat_loc = sp.ppat_loc;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
|
2011-07-29 03:32:43 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = [];
|
2010-10-25 01:19:48 -07:00
|
|
|
pat_env = !env }
|
2012-05-30 07:52:37 -07:00
|
|
|
| Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc},
|
2009-10-26 00:11:36 -07:00
|
|
|
({ptyp_desc=Ptyp_poly _} as sty)) ->
|
|
|
|
(* explicitly polymorphic type *)
|
2012-05-30 07:52:37 -07:00
|
|
|
let cty, force = Typetexp.transl_simple_type_delayed !env sty in
|
|
|
|
let ty = cty.ctyp_type in
|
|
|
|
unify_pat_types lloc !env ty expected_ty;
|
2009-10-26 00:11:36 -07:00
|
|
|
pattern_force := force :: !pattern_force;
|
|
|
|
begin match ty.desc with
|
|
|
|
| Tpoly (body, tyl) ->
|
|
|
|
begin_def ();
|
2011-12-27 00:52:45 -08:00
|
|
|
let _, ty' = instance_poly ~keep_names:true false tyl body in
|
2009-10-26 00:11:36 -07:00
|
|
|
end_def ();
|
|
|
|
generalize ty';
|
2012-05-30 07:52:37 -07:00
|
|
|
let id = enter_variable lloc name ty' in
|
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_var (id, name);
|
|
|
|
pat_loc = lloc;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_type = ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = [];
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_env = !env
|
|
|
|
}
|
2009-10-26 00:11:36 -07:00
|
|
|
| _ -> assert false
|
2009-11-19 04:27:15 -08:00
|
|
|
end
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_alias(sq, name) ->
|
2010-12-13 22:33:06 -08:00
|
|
|
let q = type_pat sq expected_ty in
|
2000-06-29 02:11:42 -07:00
|
|
|
begin_def ();
|
2010-12-13 22:33:06 -08:00
|
|
|
let ty_var = build_as_type !env q in
|
2000-06-29 02:11:42 -07:00
|
|
|
end_def ();
|
|
|
|
generalize ty_var;
|
2011-12-29 09:49:58 -08:00
|
|
|
let id = enter_variable ~is_as_variable:true loc name ty_var in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_desc = Tpat_alias(q, id, name);
|
|
|
|
pat_loc = loc; pat_extra=[];
|
2000-10-02 07:18:05 -07:00
|
|
|
pat_type = q.pat_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2011-10-25 05:11:06 -07:00
|
|
|
| Ppat_constant cst ->
|
2010-10-15 23:09:25 -07:00
|
|
|
unify_pat_types loc !env (type_constant cst) expected_ty;
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
2013-05-23 08:12:04 -07:00
|
|
|
pat_desc = Tpat_constant cst;
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-11-09 00:21:44 -08:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2013-05-23 08:12:04 -07:00
|
|
|
| Ppat_interval (Const_char c1, Const_char c2) ->
|
2013-04-16 08:34:09 -07:00
|
|
|
let open Ast_helper.Pat in
|
2013-10-01 04:40:21 -07:00
|
|
|
let gloc = {loc with Location.loc_ghost=true} in
|
2013-04-16 08:34:09 -07:00
|
|
|
let rec loop c1 c2 =
|
2013-10-01 04:40:21 -07:00
|
|
|
if c1 = c2 then constant ~loc:gloc (Const_char c1)
|
2013-04-16 08:34:09 -07:00
|
|
|
else
|
2013-10-01 04:40:21 -07:00
|
|
|
or_ ~loc:gloc
|
|
|
|
(constant ~loc:gloc (Const_char c1))
|
2013-04-16 08:34:09 -07:00
|
|
|
(loop (Char.chr(Char.code c1 + 1)) c2)
|
|
|
|
in
|
|
|
|
let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
|
2013-10-01 04:40:21 -07:00
|
|
|
let p = {p with ppat_loc=loc} in
|
2014-01-22 17:58:37 -08:00
|
|
|
type_pat p expected_ty
|
|
|
|
(* TODO: record 'extra' to remember about interval *)
|
2013-04-16 08:34:09 -07:00
|
|
|
| Ppat_interval _ ->
|
|
|
|
raise (Error (loc, !env, Invalid_interval))
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_tuple spl ->
|
2011-10-25 05:11:06 -07:00
|
|
|
let spl_ann = List.map (fun p -> (p,newvar ())) spl in
|
2010-09-20 22:30:25 -07:00
|
|
|
let ty = newty (Ttuple(List.map snd spl_ann)) in
|
2010-10-15 23:09:25 -07:00
|
|
|
unify_pat_types loc !env ty expected_ty;
|
2010-12-13 22:33:06 -08:00
|
|
|
let pl = List.map (fun (p,t) -> type_pat p t) spl_ann in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_tuple pl;
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-09-12 22:28:30 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2013-04-17 02:46:52 -07:00
|
|
|
| Ppat_construct(lid, sarg) ->
|
2012-10-29 00:54:06 -07:00
|
|
|
let opath =
|
2013-04-16 08:34:09 -07:00
|
|
|
try
|
2012-11-10 19:46:59 -08:00
|
|
|
let (p0, p, _) = extract_concrete_variant !env expected_ty in
|
|
|
|
Some (p0, p, true)
|
2013-09-04 08:12:37 -07:00
|
|
|
with Not_found -> None
|
2012-10-29 00:54:06 -07:00
|
|
|
in
|
|
|
|
let constrs =
|
2012-05-30 07:52:37 -07:00
|
|
|
match lid.txt, constrs with
|
2010-12-13 22:33:06 -08:00
|
|
|
Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
|
2012-10-29 00:54:06 -07:00
|
|
|
[Hashtbl.find constrs s, (fun () -> ())]
|
|
|
|
| _ -> Typetexp.find_all_constructors !env lid.loc lid.txt
|
2010-09-20 22:30:25 -07:00
|
|
|
in
|
2012-12-07 18:40:56 -08:00
|
|
|
let check_lk tpath constr =
|
2013-09-04 08:12:37 -07:00
|
|
|
if constr.cstr_generalized then
|
2013-01-29 06:21:12 -08:00
|
|
|
raise (Error (lid.loc, !env,
|
2012-12-07 18:40:56 -08:00
|
|
|
Unqualified_gadt_pattern (tpath, constr.cstr_name)))
|
|
|
|
in
|
|
|
|
let constr =
|
2013-09-19 00:25:51 -07:00
|
|
|
wrap_disambiguate "This variant pattern is expected to have" expected_ty
|
|
|
|
(Constructor.disambiguate lid !env opath ~check_lk) constrs
|
|
|
|
in
|
2012-05-31 01:07:31 -07:00
|
|
|
Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
|
2013-09-27 08:04:03 -07:00
|
|
|
Typetexp.check_deprecated loc constr.cstr_attributes constr.cstr_name;
|
2010-12-13 22:33:06 -08:00
|
|
|
if no_existentials && constr.cstr_existentials <> [] then
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error (loc, !env, Unexpected_existential));
|
2010-12-03 06:06:31 -08:00
|
|
|
(* if constructor is gadt, we must verify that the expected type has the
|
|
|
|
correct head *)
|
2010-12-13 22:33:06 -08:00
|
|
|
if constr.cstr_generalized then
|
|
|
|
unify_head_only loc !env expected_ty constr;
|
1995-05-04 03:15:53 -07:00
|
|
|
let sargs =
|
|
|
|
match sarg with
|
|
|
|
None -> []
|
2014-04-15 02:53:51 -07:00
|
|
|
| Some {ppat_desc = Ppat_tuple spl} when
|
|
|
|
constr.cstr_arity > 1 || explicit_arity sp.ppat_attributes
|
|
|
|
-> spl
|
2008-01-22 09:08:48 -08:00
|
|
|
| Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
|
2009-11-19 04:27:15 -08:00
|
|
|
if constr.cstr_arity = 0 then
|
|
|
|
Location.prerr_warning sp.ppat_loc
|
|
|
|
Warnings.Wildcard_arg_to_constant_constr;
|
1996-01-04 04:50:52 -08:00
|
|
|
replicate_list sp constr.cstr_arity
|
1995-05-04 03:15:53 -07:00
|
|
|
| Some sp -> [sp] in
|
|
|
|
if List.length sargs <> constr.cstr_arity then
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
|
1995-05-04 03:15:53 -07:00
|
|
|
constr.cstr_arity, List.length sargs)));
|
2011-10-25 05:11:06 -07:00
|
|
|
let (ty_args, ty_res) =
|
|
|
|
instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
|
2010-11-09 01:29:08 -08:00
|
|
|
in
|
2011-06-14 02:41:21 -07:00
|
|
|
if constr.cstr_generalized && mode = Normal then
|
|
|
|
unify_pat_types_gadt loc env ty_res expected_ty
|
|
|
|
else
|
|
|
|
unify_pat_types loc !env ty_res expected_ty;
|
2010-12-13 22:33:06 -08:00
|
|
|
let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
2013-04-17 02:46:52 -07:00
|
|
|
pat_desc=Tpat_construct(lid, constr, args);
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_variant(l, sarg) ->
|
2013-11-12 16:16:03 -08:00
|
|
|
let arg_type = match sarg with None -> [] | Some _ -> [newvar()] in
|
2001-03-02 16:14:35 -08:00
|
|
|
let row = { row_fields =
|
2013-11-12 16:16:03 -08:00
|
|
|
[l, Reither(sarg = None, arg_type, true, ref None)];
|
2008-01-11 08:13:18 -08:00
|
|
|
row_bound = ();
|
1999-11-30 08:07:38 -08:00
|
|
|
row_closed = false;
|
|
|
|
row_more = newvar ();
|
2002-04-18 00:27:47 -07:00
|
|
|
row_fixed = false;
|
1999-11-30 08:07:38 -08:00
|
|
|
row_name = None } in
|
2010-10-18 22:24:36 -07:00
|
|
|
unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
|
2013-11-12 16:16:03 -08:00
|
|
|
let arg =
|
|
|
|
(* PR#6235: propagate type information *)
|
|
|
|
match sarg, arg_type with
|
|
|
|
Some p, [ty] -> Some (type_pat p ty)
|
|
|
|
| _ -> None
|
|
|
|
in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
2008-01-11 08:13:18 -08:00
|
|
|
pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-10-18 22:24:36 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2009-09-12 05:41:07 -07:00
|
|
|
| Ppat_record(lid_sp_list, closed) ->
|
2012-11-08 01:39:23 -08:00
|
|
|
let opath, record_ty =
|
|
|
|
try
|
2012-11-10 19:46:59 -08:00
|
|
|
let (p0, p,_) = extract_concrete_record !env expected_ty in
|
|
|
|
Some (p0, p, true), expected_ty
|
2013-09-04 08:12:37 -07:00
|
|
|
with Not_found -> None, newvar ()
|
2012-11-08 01:39:23 -08:00
|
|
|
in
|
2012-10-24 05:03:00 -07:00
|
|
|
let type_label_pat (label_lid, label, sarg) =
|
2007-02-26 20:38:11 -08:00
|
|
|
begin_def ();
|
2007-02-26 19:46:19 -08:00
|
|
|
let (vars, ty_arg, ty_res) = instance_label false label in
|
2007-02-26 20:38:11 -08:00
|
|
|
if vars = [] then end_def ();
|
1995-05-04 03:15:53 -07:00
|
|
|
begin try
|
2012-11-08 01:39:23 -08:00
|
|
|
unify_pat_types loc !env ty_res record_ty
|
1996-05-20 09:43:29 -07:00
|
|
|
with Unify trace ->
|
2013-01-29 06:21:12 -08:00
|
|
|
raise(Error(label_lid.loc, !env,
|
2013-09-04 08:12:37 -07:00
|
|
|
Label_mismatch(label_lid.txt, trace)))
|
1995-05-04 03:15:53 -07:00
|
|
|
end;
|
2010-12-13 22:33:06 -08:00
|
|
|
let arg = type_pat sarg ty_arg in
|
2007-02-26 20:38:11 -08:00
|
|
|
if vars <> [] then begin
|
|
|
|
end_def ();
|
|
|
|
generalize ty_arg;
|
|
|
|
List.iter generalize vars;
|
2011-10-25 05:11:06 -07:00
|
|
|
let instantiated tv =
|
2010-09-18 21:55:40 -07:00
|
|
|
let tv = expand_head !env tv in
|
2011-09-22 02:05:42 -07:00
|
|
|
not (is_Tvar tv) || tv.level <> generic_level in
|
2007-02-26 20:38:11 -08:00
|
|
|
if List.exists instantiated vars then
|
2013-01-29 06:21:12 -08:00
|
|
|
raise (Error(label_lid.loc, !env, Polymorphic_label label_lid.txt))
|
2007-02-26 20:38:11 -08:00
|
|
|
end;
|
2012-10-24 05:03:00 -07:00
|
|
|
(label_lid, label, arg)
|
1995-05-04 03:15:53 -07:00
|
|
|
in
|
2011-06-15 02:26:30 -07:00
|
|
|
let lbl_pat_list =
|
2013-09-19 00:25:51 -07:00
|
|
|
wrap_disambiguate "This record pattern is expected to have" expected_ty
|
|
|
|
(type_label_a_list ?labels loc false !env type_label_pat opath)
|
|
|
|
lid_sp_list
|
|
|
|
in
|
2009-09-12 05:41:07 -07:00
|
|
|
check_recordpat_labels loc lbl_pat_list closed;
|
2012-11-08 01:39:23 -08:00
|
|
|
unify_pat_types loc !env record_ty expected_ty;
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_desc = Tpat_record (lbl_pat_list, closed);
|
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-10-15 23:09:25 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2011-10-25 05:11:06 -07:00
|
|
|
| Ppat_array spl ->
|
1998-04-06 02:23:01 -07:00
|
|
|
let ty_elt = newvar() in
|
2011-10-25 05:11:06 -07:00
|
|
|
unify_pat_types
|
2011-11-24 01:02:48 -08:00
|
|
|
loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
|
2011-10-25 05:11:06 -07:00
|
|
|
let spl_ann = List.map (fun p -> (p,newvar())) spl in
|
2010-12-13 22:33:06 -08:00
|
|
|
let pl = List.map (fun (p,t) -> type_pat p ty_elt) spl_ann in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_array pl;
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-09-12 22:28:30 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_or(sp1, sp2) ->
|
1995-05-04 03:15:53 -07:00
|
|
|
let initial_pattern_variables = !pattern_variables in
|
2011-10-25 05:11:06 -07:00
|
|
|
let p1 = type_pat ~mode:Inside_or sp1 expected_ty in
|
2000-10-02 07:18:05 -07:00
|
|
|
let p1_variables = !pattern_variables in
|
2011-10-25 05:11:06 -07:00
|
|
|
pattern_variables := initial_pattern_variables;
|
|
|
|
let p2 = type_pat ~mode:Inside_or sp2 expected_ty in
|
2000-10-02 07:18:05 -07:00
|
|
|
let p2_variables = !pattern_variables in
|
|
|
|
let alpha_env =
|
2010-09-18 21:55:40 -07:00
|
|
|
enter_orpat_variables loc !env p1_variables p2_variables in
|
2011-10-25 05:11:06 -07:00
|
|
|
pattern_variables := p1_variables;
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_lazy sp1 ->
|
2011-10-25 05:11:06 -07:00
|
|
|
let nv = newvar () in
|
2012-05-31 01:07:31 -07:00
|
|
|
unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv))
|
|
|
|
expected_ty;
|
2010-12-13 22:33:06 -08:00
|
|
|
let p1 = type_pat sp1 nv in
|
2008-07-09 06:03:38 -07:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_lazy p1;
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_loc = loc; pat_extra=[];
|
2010-09-12 22:28:30 -07:00
|
|
|
pat_type = expected_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = sp.ppat_attributes;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_constraint(sp, sty) ->
|
2012-02-14 02:00:18 -08:00
|
|
|
(* Separate when not already separated by !principal *)
|
|
|
|
let separate = true in
|
|
|
|
if separate then begin_def();
|
2012-05-30 07:52:37 -07:00
|
|
|
let cty, force = Typetexp.transl_simple_type_delayed !env sty in
|
|
|
|
let ty = cty.ctyp_type in
|
2012-02-14 02:00:18 -08:00
|
|
|
let ty, expected_ty' =
|
|
|
|
if separate then begin
|
|
|
|
end_def();
|
|
|
|
generalize_structure ty;
|
|
|
|
instance !env ty, instance !env ty
|
|
|
|
end else ty, ty
|
|
|
|
in
|
2010-10-15 23:09:25 -07:00
|
|
|
unify_pat_types loc !env ty expected_ty;
|
2012-02-14 02:00:18 -08:00
|
|
|
let p = type_pat sp expected_ty' in
|
|
|
|
(*Format.printf "%a@.%a@."
|
|
|
|
Printtyp.raw_type_expr ty
|
|
|
|
Printtyp.raw_type_expr p.pat_type;*)
|
2002-06-03 00:33:48 -07:00
|
|
|
pattern_force := force :: !pattern_force;
|
2013-03-25 07:16:07 -07:00
|
|
|
let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
|
2012-02-14 02:00:18 -08:00
|
|
|
if separate then
|
|
|
|
match p.pat_desc with
|
2012-05-30 07:52:37 -07:00
|
|
|
Tpat_var (id,s) ->
|
2012-02-14 02:00:18 -08:00
|
|
|
{p with pat_type = ty;
|
2014-01-22 17:58:37 -08:00
|
|
|
pat_desc = Tpat_alias
|
|
|
|
({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_extra = [extra];
|
2012-05-30 07:52:37 -07:00
|
|
|
}
|
2012-05-31 01:07:31 -07:00
|
|
|
| _ -> {p with pat_type = ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_extra = extra :: p.pat_extra}
|
2012-02-14 02:00:18 -08:00
|
|
|
else p
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_type lid ->
|
2012-05-30 07:52:37 -07:00
|
|
|
let (path, p,ty) = build_or_pat !env loc lid.txt in
|
2010-09-27 22:48:37 -07:00
|
|
|
unify_pat_types loc !env ty expected_ty;
|
2014-01-22 17:58:37 -08:00
|
|
|
{ p with pat_extra =
|
|
|
|
(Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
|
2014-05-05 04:49:37 -07:00
|
|
|
| Ppat_exception _ ->
|
|
|
|
raise (Error (loc, !env, Exception_pattern_below_toplevel))
|
2014-05-07 01:26:17 -07:00
|
|
|
| Ppat_extension ext ->
|
|
|
|
raise (Error_forward (Typetexp.error_of_extension ext))
|
2010-12-12 18:59:58 -08:00
|
|
|
|
2010-12-13 22:33:06 -08:00
|
|
|
let type_pat ?(allow_existentials=false) ?constrs ?labels
|
2011-10-25 05:11:06 -07:00
|
|
|
?(lev=get_current_level()) env sp expected_ty =
|
2010-12-13 22:33:06 -08:00
|
|
|
newtype_level := Some lev;
|
2010-10-04 01:38:22 -07:00
|
|
|
try
|
2010-12-12 18:59:58 -08:00
|
|
|
let r =
|
2010-12-13 22:33:06 -08:00
|
|
|
type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
|
|
|
|
~mode:Normal ~env sp expected_ty in
|
2010-11-07 23:34:09 -08:00
|
|
|
iter_pattern (fun p -> p.pat_env <- !env) r;
|
2010-12-13 16:53:47 -08:00
|
|
|
newtype_level := None;
|
2010-10-04 01:38:22 -07:00
|
|
|
r
|
2011-10-25 05:11:06 -07:00
|
|
|
with e ->
|
2010-12-13 22:33:06 -08:00
|
|
|
newtype_level := None;
|
2011-10-25 05:11:06 -07:00
|
|
|
raise e
|
2010-11-09 00:21:44 -08:00
|
|
|
|
2010-11-15 22:01:59 -08:00
|
|
|
|
2010-11-09 00:21:44 -08:00
|
|
|
(* this function is passed to Partial.parmatch
|
2011-10-25 05:11:06 -07:00
|
|
|
to type check gadt nonexhaustiveness *)
|
|
|
|
let partial_pred ~lev env expected_ty constrs labels p =
|
|
|
|
let snap = snapshot () in
|
2010-12-13 18:00:20 -08:00
|
|
|
try
|
|
|
|
reset_pattern None true;
|
2010-12-13 16:53:47 -08:00
|
|
|
let typed_p =
|
2010-12-13 17:53:15 -08:00
|
|
|
type_pat ~allow_existentials:true ~lev
|
2010-12-13 16:53:47 -08:00
|
|
|
~constrs ~labels (ref env) p expected_ty
|
|
|
|
in
|
|
|
|
backtrack snap;
|
|
|
|
(* types are invalidated but we don't need them here *)
|
|
|
|
Some typed_p
|
|
|
|
with _ ->
|
|
|
|
backtrack snap;
|
|
|
|
None
|
2010-11-09 00:21:44 -08:00
|
|
|
|
2011-10-25 05:11:06 -07:00
|
|
|
let rec iter3 f lst1 lst2 lst3 =
|
2010-11-09 00:21:44 -08:00
|
|
|
match lst1,lst2,lst3 with
|
|
|
|
| x1::xs1,x2::xs2,x3::xs3 ->
|
|
|
|
f x1 x2 x3;
|
2011-10-25 05:11:06 -07:00
|
|
|
iter3 f xs1 xs2 xs3
|
2010-11-09 00:21:44 -08:00
|
|
|
| [],[],[] ->
|
2010-10-15 23:09:25 -07:00
|
|
|
()
|
|
|
|
| _ ->
|
|
|
|
assert false
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2011-12-29 09:49:58 -08:00
|
|
|
let add_pattern_variables ?check ?check_as env =
|
2002-06-03 00:33:48 -07:00
|
|
|
let pv = get_ref pattern_variables in
|
2010-10-21 16:59:33 -07:00
|
|
|
(List.fold_right
|
2012-11-08 01:40:21 -08:00
|
|
|
(fun (id, ty, name, loc, as_var) env ->
|
2011-12-29 09:49:58 -08:00
|
|
|
let check = if as_var then check_as else check in
|
2012-11-08 01:40:21 -08:00
|
|
|
Env.add_value ?check id
|
2013-09-26 08:24:11 -07:00
|
|
|
{val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
|
|
|
|
val_attributes = [];
|
|
|
|
} env
|
2012-11-08 01:40:21 -08:00
|
|
|
)
|
|
|
|
pv env,
|
2010-10-21 16:59:33 -07:00
|
|
|
get_ref module_variables)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2011-10-25 05:11:06 -07:00
|
|
|
let type_pattern ~lev env spat scope expected_ty =
|
2010-10-21 16:59:33 -07:00
|
|
|
reset_pattern scope true;
|
2011-10-25 05:11:06 -07:00
|
|
|
let new_env = ref env in
|
2010-12-03 08:13:01 -08:00
|
|
|
let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
|
2012-02-14 02:00:18 -08:00
|
|
|
let new_env, unpacks =
|
|
|
|
add_pattern_variables !new_env
|
|
|
|
~check:(fun s -> Warnings.Unused_var_strict s)
|
|
|
|
~check_as:(fun s -> Warnings.Unused_var s) in
|
2010-10-21 16:59:33 -07:00
|
|
|
(pat, new_env, get_ref pattern_force, unpacks)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2010-10-25 01:19:48 -07:00
|
|
|
let type_pattern_list env spatl scope expected_tys allow =
|
2010-10-21 16:59:33 -07:00
|
|
|
reset_pattern scope allow;
|
2011-10-25 05:11:06 -07:00
|
|
|
let new_env = ref env in
|
2010-12-13 22:33:06 -08:00
|
|
|
let patl = List.map2 (type_pat new_env) spatl expected_tys in
|
2010-10-25 01:19:48 -07:00
|
|
|
let new_env, unpacks = add_pattern_variables !new_env in
|
2010-10-21 16:59:33 -07:00
|
|
|
(patl, new_env, get_ref pattern_force, unpacks)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1999-11-30 08:07:38 -08:00
|
|
|
let type_class_arg_pattern cl_num val_env met_env l spat =
|
2010-10-21 16:59:33 -07:00
|
|
|
reset_pattern None false;
|
2011-10-25 05:11:06 -07:00
|
|
|
let nv = newvar () in
|
2010-09-18 21:55:40 -07:00
|
|
|
let pat = type_pat (ref val_env) spat nv in
|
2003-08-18 01:26:18 -07:00
|
|
|
if has_variants pat then begin
|
|
|
|
Parmatch.pressure_variants val_env [pat];
|
|
|
|
iter_pattern finalize_variant pat
|
|
|
|
end;
|
2002-06-03 00:33:48 -07:00
|
|
|
List.iter (fun f -> f()) (get_ref pattern_force);
|
1999-11-30 08:07:38 -08:00
|
|
|
if is_optional l then unify_pat val_env pat (type_option (newvar ()));
|
1998-06-24 12:22:26 -07:00
|
|
|
let (pv, met_env) =
|
|
|
|
List.fold_right
|
2012-05-30 07:52:37 -07:00
|
|
|
(fun (id, ty, name, loc, as_var) (pv, env) ->
|
2012-02-14 02:00:18 -08:00
|
|
|
let check s =
|
|
|
|
if as_var then Warnings.Unused_var s
|
|
|
|
else Warnings.Unused_var_strict s in
|
1998-06-24 12:22:26 -07:00
|
|
|
let id' = Ident.create (Ident.name id) in
|
2012-05-30 07:52:37 -07:00
|
|
|
((id', name, id, ty)::pv,
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.add_value id' {val_type = ty;
|
2010-05-21 08:45:52 -07:00
|
|
|
val_kind = Val_ivar (Immutable, cl_num);
|
2013-09-26 08:24:11 -07:00
|
|
|
val_attributes = [];
|
2012-05-30 07:52:37 -07:00
|
|
|
Types.val_loc = loc;
|
2012-01-06 06:16:58 -08:00
|
|
|
} ~check
|
1998-06-24 12:22:26 -07:00
|
|
|
env))
|
|
|
|
!pattern_variables ([], met_env)
|
|
|
|
in
|
2010-10-21 16:59:33 -07:00
|
|
|
let val_env, _ = add_pattern_variables val_env in
|
1998-06-24 12:22:26 -07:00
|
|
|
(pat, pv, val_env, met_env)
|
|
|
|
|
2003-11-25 01:20:45 -08:00
|
|
|
let type_self_pattern cl_num privty val_env met_env par_env spat =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Ast_helper in
|
2005-08-13 13:59:37 -07:00
|
|
|
let spat =
|
2013-03-08 06:59:45 -08:00
|
|
|
Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")),
|
|
|
|
mknoloc ("selfpat-" ^ cl_num)))
|
1998-11-29 09:34:05 -08:00
|
|
|
in
|
2010-10-21 16:59:33 -07:00
|
|
|
reset_pattern None false;
|
2011-10-25 05:11:06 -07:00
|
|
|
let nv = newvar() in
|
2010-10-18 22:24:36 -07:00
|
|
|
let pat = type_pat (ref val_env) spat nv in
|
2002-06-03 00:33:48 -07:00
|
|
|
List.iter (fun f -> f()) (get_ref pattern_force);
|
1998-06-24 12:22:26 -07:00
|
|
|
let meths = ref Meths.empty in
|
|
|
|
let vars = ref Vars.empty in
|
|
|
|
let pv = !pattern_variables in
|
|
|
|
pattern_variables := [];
|
|
|
|
let (val_env, met_env, par_env) =
|
|
|
|
List.fold_right
|
2012-05-30 07:52:37 -07:00
|
|
|
(fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) ->
|
2010-05-21 08:45:52 -07:00
|
|
|
(Env.add_value id {val_type = ty;
|
|
|
|
val_kind = Val_unbound;
|
2013-09-26 08:24:11 -07:00
|
|
|
val_attributes = [];
|
2012-05-30 07:52:37 -07:00
|
|
|
Types.val_loc = loc;
|
2010-05-21 08:45:52 -07:00
|
|
|
} val_env,
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.add_value id {val_type = ty;
|
2010-05-21 08:45:52 -07:00
|
|
|
val_kind = Val_self (meths, vars, cl_num, privty);
|
2013-09-26 08:24:11 -07:00
|
|
|
val_attributes = [];
|
2012-05-30 07:52:37 -07:00
|
|
|
Types.val_loc = loc;
|
2010-05-21 08:45:52 -07:00
|
|
|
}
|
2012-02-14 02:00:18 -08:00
|
|
|
~check:(fun s -> if as_var then Warnings.Unused_var s
|
|
|
|
else Warnings.Unused_var_strict s)
|
1998-06-24 12:22:26 -07:00
|
|
|
met_env,
|
2010-05-21 08:45:52 -07:00
|
|
|
Env.add_value id {val_type = ty; val_kind = Val_unbound;
|
2013-09-26 08:24:11 -07:00
|
|
|
val_attributes = [];
|
2012-05-30 07:52:37 -07:00
|
|
|
Types.val_loc = loc;
|
2010-05-21 08:45:52 -07:00
|
|
|
} par_env))
|
1998-06-24 12:22:26 -07:00
|
|
|
pv (val_env, met_env, par_env)
|
|
|
|
in
|
|
|
|
(pat, meths, vars, val_env, met_env, par_env)
|
|
|
|
|
2002-05-16 03:18:51 -07:00
|
|
|
let delayed_checks = ref []
|
|
|
|
let reset_delayed_checks () = delayed_checks := []
|
|
|
|
let add_delayed_check f = delayed_checks := f :: !delayed_checks
|
|
|
|
let force_delayed_checks () =
|
2008-01-11 08:13:18 -08:00
|
|
|
(* checks may change type levels *)
|
|
|
|
let snap = Btype.snapshot () in
|
2002-05-16 03:18:51 -07:00
|
|
|
List.iter (fun f -> f ()) (List.rev !delayed_checks);
|
2008-01-11 08:13:18 -08:00
|
|
|
reset_delayed_checks ();
|
|
|
|
Btype.backtrack snap
|
2002-05-16 03:18:51 -07:00
|
|
|
|
2012-07-24 01:57:52 -07:00
|
|
|
let rec final_subexpression sexp =
|
|
|
|
match sexp.pexp_desc with
|
|
|
|
Pexp_let (_, _, e)
|
|
|
|
| Pexp_sequence (_, e)
|
|
|
|
| Pexp_try (e, _)
|
|
|
|
| Pexp_ifthenelse (_, e, _)
|
2013-04-15 09:23:22 -07:00
|
|
|
| Pexp_match (_, {pc_rhs=e} :: _)
|
2012-07-24 01:57:52 -07:00
|
|
|
-> final_subexpression e
|
|
|
|
| _ -> sexp
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Generalization criterion for expressions *)
|
|
|
|
|
|
|
|
let rec is_nonexpansive exp =
|
|
|
|
match exp.exp_desc with
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_ident(_,_,_) -> true
|
1995-05-04 03:15:53 -07:00
|
|
|
| Texp_constant _ -> true
|
|
|
|
| Texp_let(rec_flag, pat_exp_list, body) ->
|
2013-06-03 08:14:19 -07:00
|
|
|
List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list &&
|
1995-05-04 03:15:53 -07:00
|
|
|
is_nonexpansive body
|
2002-01-20 09:39:10 -08:00
|
|
|
| Texp_function _ -> true
|
2012-05-30 07:52:37 -07:00
|
|
|
| Texp_apply(e, (_,None,_)::el) ->
|
|
|
|
is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el)
|
2014-05-05 04:49:37 -07:00
|
|
|
| Texp_match(e, cases, [], _) ->
|
2013-06-28 03:43:25 -07:00
|
|
|
is_nonexpansive e &&
|
2013-07-16 06:34:30 -07:00
|
|
|
List.for_all
|
|
|
|
(fun {c_lhs = _; c_guard; c_rhs} ->
|
|
|
|
is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
|
|
|
|
) cases
|
1995-05-04 03:15:53 -07:00
|
|
|
| Texp_tuple el ->
|
|
|
|
List.for_all is_nonexpansive el
|
2013-04-17 02:46:52 -07:00
|
|
|
| Texp_construct( _, _, el) ->
|
1995-05-04 03:15:53 -07:00
|
|
|
List.for_all is_nonexpansive el
|
2000-06-01 06:14:36 -07:00
|
|
|
| Texp_variant(_, arg) -> is_nonexpansive_opt arg
|
1998-04-27 08:17:11 -07:00
|
|
|
| Texp_record(lbl_exp_list, opt_init_exp) ->
|
1996-05-22 09:22:33 -07:00
|
|
|
List.for_all
|
2012-10-24 05:03:00 -07:00
|
|
|
(fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
|
2005-08-13 13:59:37 -07:00
|
|
|
lbl_exp_list
|
2000-06-01 06:14:36 -07:00
|
|
|
&& is_nonexpansive_opt opt_init_exp
|
2012-10-24 05:03:00 -07:00
|
|
|
| Texp_field(exp, lbl, _) -> is_nonexpansive exp
|
1995-06-05 06:43:38 -07:00
|
|
|
| Texp_array [] -> true
|
2000-06-01 06:14:36 -07:00
|
|
|
| Texp_ifthenelse(cond, ifso, ifnot) ->
|
|
|
|
is_nonexpansive ifso && is_nonexpansive_opt ifnot
|
2008-01-11 08:13:18 -08:00
|
|
|
| Texp_sequence (e1, e2) -> is_nonexpansive e2 (* PR#4354 *)
|
2012-05-30 07:52:37 -07:00
|
|
|
| Texp_new (_, _, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
|
1998-08-31 12:41:24 -07:00
|
|
|
true
|
2003-11-25 01:20:45 -08:00
|
|
|
(* Note: nonexpansive only means no _observable_ side effects *)
|
|
|
|
| Texp_lazy e -> is_nonexpansive e
|
2013-09-27 08:04:03 -07:00
|
|
|
| Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) ->
|
2003-11-25 01:20:45 -08:00
|
|
|
let count = ref 0 in
|
|
|
|
List.for_all
|
2012-05-30 07:52:37 -07:00
|
|
|
(fun field -> match field.cf_desc with
|
2013-04-10 04:17:41 -07:00
|
|
|
Tcf_method _ -> true
|
|
|
|
| Tcf_val (_, _, _, Tcfk_concrete (_, e), _) ->
|
2012-05-30 07:52:37 -07:00
|
|
|
incr count; is_nonexpansive e
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tcf_val (_, _, _, Tcfk_virtual _, _) ->
|
2012-05-30 07:52:37 -07:00
|
|
|
incr count; true
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tcf_initializer e -> is_nonexpansive e
|
|
|
|
| Tcf_constraint _ -> true
|
2014-05-04 13:42:34 -07:00
|
|
|
| Tcf_inherit _ -> false
|
|
|
|
| Tcf_attribute _ -> true)
|
2003-11-25 01:20:45 -08:00
|
|
|
fields &&
|
2006-04-04 19:28:13 -07:00
|
|
|
Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
|
2003-11-25 01:20:45 -08:00
|
|
|
vars true &&
|
|
|
|
!count = 0
|
2012-06-01 01:05:48 -07:00
|
|
|
| Texp_letmodule (_, _, mexp, e) ->
|
|
|
|
is_nonexpansive_mod mexp && is_nonexpansive e
|
2010-08-02 07:37:22 -07:00
|
|
|
| Texp_pack mexp ->
|
|
|
|
is_nonexpansive_mod mexp
|
1995-05-04 03:15:53 -07:00
|
|
|
| _ -> false
|
|
|
|
|
2010-08-02 07:37:22 -07:00
|
|
|
and is_nonexpansive_mod mexp =
|
|
|
|
match mexp.mod_desc with
|
|
|
|
| Tmod_ident _ -> true
|
|
|
|
| Tmod_functor _ -> true
|
|
|
|
| Tmod_unpack (e, _) -> is_nonexpansive e
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m
|
|
|
|
| Tmod_structure str ->
|
2010-08-02 07:37:22 -07:00
|
|
|
List.for_all
|
2012-05-30 07:52:37 -07:00
|
|
|
(fun item -> match item.str_desc with
|
2014-05-04 16:08:45 -07:00
|
|
|
| Tstr_eval _ | Tstr_primitive _ | Tstr_type _
|
|
|
|
| Tstr_modtype _ | Tstr_open _ | Tstr_class_type _ -> true
|
2013-06-03 08:14:19 -07:00
|
|
|
| Tstr_value (_, pat_exp_list) ->
|
|
|
|
List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list
|
2013-10-02 01:34:01 -07:00
|
|
|
| Tstr_module {mb_expr=m;_}
|
2014-04-15 04:26:00 -07:00
|
|
|
| Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m
|
2010-08-02 07:37:22 -07:00
|
|
|
| Tstr_recmodule id_mod_list ->
|
2013-03-26 01:09:26 -07:00
|
|
|
List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m)
|
2012-05-31 01:07:31 -07:00
|
|
|
id_mod_list
|
2014-05-04 16:08:45 -07:00
|
|
|
| Tstr_exception {ext_kind = Text_decl _} ->
|
|
|
|
false (* true would be unsound *)
|
|
|
|
| Tstr_exception {ext_kind = Text_rebind _} -> true
|
|
|
|
| Tstr_typext te ->
|
|
|
|
List.for_all
|
|
|
|
(function {ext_kind = Text_decl _} -> false
|
|
|
|
| {ext_kind = Text_rebind _} -> true)
|
|
|
|
te.tyext_constructors
|
2010-08-02 07:37:22 -07:00
|
|
|
| Tstr_class _ -> false (* could be more precise *)
|
2013-03-25 07:16:07 -07:00
|
|
|
| Tstr_attribute _ -> true
|
2010-08-02 07:37:22 -07:00
|
|
|
)
|
2012-05-30 07:52:37 -07:00
|
|
|
str.str_items
|
2010-08-02 07:37:22 -07:00
|
|
|
| Tmod_apply _ -> false
|
|
|
|
|
2000-06-01 06:14:36 -07:00
|
|
|
and is_nonexpansive_opt = function
|
|
|
|
None -> true
|
|
|
|
| Some e -> is_nonexpansive e
|
|
|
|
|
2011-10-25 06:13:54 -07:00
|
|
|
(* Typing format strings for printing or reading.
|
|
|
|
|
2012-01-11 07:22:51 -08:00
|
|
|
These format strings are used by functions in modules Printf, Format, and
|
2011-10-25 06:13:54 -07:00
|
|
|
Scanf.
|
|
|
|
|
2001-10-28 06:22:05 -08:00
|
|
|
(Handling of * modifiers contributed by Thorsten Ohl.) *)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2006-04-05 04:46:47 -07:00
|
|
|
external string_to_format :
|
2006-10-24 13:42:41 -07:00
|
|
|
string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
|
2006-04-05 04:46:47 -07:00
|
|
|
external format_to_string :
|
2006-10-24 13:42:41 -07:00
|
|
|
('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity"
|
2006-04-05 04:46:47 -07:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
let type_format loc fmt =
|
2004-09-22 02:17:21 -07:00
|
|
|
|
2011-11-24 01:02:48 -08:00
|
|
|
let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in
|
2004-06-14 13:38:15 -07:00
|
|
|
|
2005-03-04 06:51:31 -08:00
|
|
|
let bad_conversion fmt i c =
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error (loc, Env.empty, Bad_conversion (fmt, i, c))) in
|
2005-03-04 06:51:31 -08:00
|
|
|
let incomplete_format fmt =
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error (loc, Env.empty, Incomplete_format fmt)) in
|
2005-03-04 06:51:31 -08:00
|
|
|
|
2004-09-22 02:17:21 -07:00
|
|
|
let rec type_in_format fmt =
|
2005-07-22 05:11:26 -07:00
|
|
|
|
2004-09-22 02:17:21 -07:00
|
|
|
let len = String.length fmt in
|
|
|
|
|
|
|
|
let ty_input = newvar ()
|
|
|
|
and ty_result = newvar ()
|
2006-10-24 13:42:41 -07:00
|
|
|
and ty_aresult = newvar ()
|
|
|
|
and ty_uresult = newvar () in
|
2002-12-09 01:27:54 -08:00
|
|
|
|
2004-09-22 02:17:21 -07:00
|
|
|
let meta = ref 0 in
|
2002-12-09 01:27:54 -08:00
|
|
|
|
2004-09-22 02:17:21 -07:00
|
|
|
let rec scan_format i =
|
|
|
|
if i >= len then
|
2005-03-04 06:51:31 -08:00
|
|
|
if !meta = 0
|
2006-10-24 15:07:47 -07:00
|
|
|
then ty_uresult, ty_result
|
2005-03-04 06:51:31 -08:00
|
|
|
else incomplete_format fmt else
|
2004-09-22 02:17:21 -07:00
|
|
|
match fmt.[i] with
|
|
|
|
| '%' -> scan_opts i (i + 1)
|
|
|
|
| _ -> scan_format (i + 1)
|
|
|
|
and scan_opts i j =
|
2005-03-04 06:51:31 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2002-12-09 01:27:54 -08:00
|
|
|
match fmt.[j] with
|
2004-09-22 02:17:21 -07:00
|
|
|
| '_' -> scan_rest true i (j + 1)
|
|
|
|
| _ -> scan_rest false i j
|
|
|
|
and scan_rest skip i j =
|
|
|
|
let rec scan_flags i j =
|
2005-03-04 06:51:31 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2004-09-22 02:17:21 -07:00
|
|
|
match fmt.[j] with
|
|
|
|
| '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
|
|
|
|
| _ -> scan_width i j
|
|
|
|
and scan_width i j = scan_width_or_prec_value scan_precision i j
|
|
|
|
and scan_decimal_string scan i j =
|
2005-03-04 06:51:31 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2004-09-22 02:17:21 -07:00
|
|
|
match fmt.[j] with
|
|
|
|
| '0' .. '9' -> scan_decimal_string scan i (j + 1)
|
|
|
|
| _ -> scan i j
|
|
|
|
and scan_width_or_prec_value scan i j =
|
2005-03-04 06:51:31 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2004-09-22 02:17:21 -07:00
|
|
|
match fmt.[j] with
|
|
|
|
| '*' ->
|
2006-10-24 15:07:47 -07:00
|
|
|
let ty_uresult, ty_result = scan i (j + 1) in
|
|
|
|
ty_uresult, ty_arrow Predef.type_int ty_result
|
2004-09-22 02:17:21 -07:00
|
|
|
| '-' | '+' -> scan_decimal_string scan i (j + 1)
|
|
|
|
| _ -> scan_decimal_string scan i j
|
|
|
|
and scan_precision i j =
|
2005-03-04 06:51:31 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2004-09-22 02:17:21 -07:00
|
|
|
match fmt.[j] with
|
|
|
|
| '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
|
|
|
|
| _ -> scan_conversion i j
|
2012-01-11 07:22:51 -08:00
|
|
|
and scan_indication j =
|
|
|
|
if j >= len then j - 1 else
|
|
|
|
match fmt.[j] with
|
|
|
|
| '@' ->
|
|
|
|
let k = j + 1 in
|
|
|
|
if k >= len then j - 1 else
|
|
|
|
begin match fmt.[k] with
|
|
|
|
| '%' ->
|
|
|
|
let k = k + 1 in
|
|
|
|
if k >= len then j - 1 else
|
|
|
|
begin match fmt.[k] with
|
|
|
|
| '%' | '@' -> k
|
|
|
|
| _c -> j - 1
|
|
|
|
end
|
|
|
|
| _c -> k
|
|
|
|
end
|
|
|
|
| _c -> j - 1
|
|
|
|
and scan_range j =
|
|
|
|
let rec scan_closing j =
|
|
|
|
if j >= len then incomplete_format fmt else
|
|
|
|
match fmt.[j] with
|
|
|
|
| ']' -> j
|
|
|
|
| '%' ->
|
|
|
|
let j = j + 1 in
|
|
|
|
if j >= len then incomplete_format fmt else
|
|
|
|
begin match fmt.[j] with
|
|
|
|
| '%' | '@' -> scan_closing (j + 1)
|
|
|
|
| c -> bad_conversion fmt j c
|
|
|
|
end
|
|
|
|
| c -> scan_closing (j + 1) in
|
|
|
|
let scan_first_pos j =
|
|
|
|
if j >= len then incomplete_format fmt else
|
|
|
|
match fmt.[j] with
|
|
|
|
| ']' -> scan_closing (j + 1)
|
|
|
|
| c -> scan_closing j in
|
2012-05-29 06:41:14 -07:00
|
|
|
let scan_first_neg j =
|
2012-01-11 07:22:51 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
|
|
|
match fmt.[j] with
|
|
|
|
| '^' -> scan_first_pos (j + 1)
|
|
|
|
| c -> scan_first_pos j in
|
|
|
|
|
|
|
|
scan_first_neg j
|
2004-09-22 02:17:21 -07:00
|
|
|
|
|
|
|
and conversion j ty_arg =
|
2006-10-24 15:07:47 -07:00
|
|
|
let ty_uresult, ty_result = scan_format (j + 1) in
|
|
|
|
ty_uresult,
|
2004-09-22 02:17:21 -07:00
|
|
|
if skip then ty_result else ty_arrow ty_arg ty_result
|
|
|
|
|
2009-11-30 14:02:08 -08:00
|
|
|
and conversion_a j ty_e ty_arg =
|
|
|
|
let ty_uresult, ty_result = conversion j ty_arg in
|
|
|
|
let ty_a = ty_arrow ty_input (ty_arrow ty_e ty_aresult) in
|
|
|
|
ty_uresult, ty_arrow ty_a ty_result
|
|
|
|
|
|
|
|
and conversion_r j ty_e ty_arg =
|
|
|
|
let ty_uresult, ty_result = conversion j ty_arg in
|
|
|
|
let ty_r = ty_arrow ty_input ty_e in
|
|
|
|
ty_arrow ty_r ty_uresult, ty_result
|
|
|
|
|
2004-09-22 02:17:21 -07:00
|
|
|
and scan_conversion i j =
|
2005-03-04 06:51:31 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2004-09-22 02:17:21 -07:00
|
|
|
match fmt.[j] with
|
2012-01-11 07:22:51 -08:00
|
|
|
| '%' | '@' | '!' | ',' -> scan_format (j + 1)
|
|
|
|
| 's' | 'S' ->
|
|
|
|
let j = scan_indication (j + 1) in
|
|
|
|
conversion j Predef.type_string
|
2005-07-22 05:11:26 -07:00
|
|
|
| '[' ->
|
2012-01-11 07:22:51 -08:00
|
|
|
let j = scan_range (j + 1) in
|
|
|
|
let j = scan_indication (j + 1) in
|
2005-07-22 05:11:26 -07:00
|
|
|
conversion j Predef.type_string
|
2004-09-22 02:17:21 -07:00
|
|
|
| 'c' | 'C' -> conversion j Predef.type_char
|
2012-01-11 07:22:51 -08:00
|
|
|
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' ->
|
2004-09-22 02:17:21 -07:00
|
|
|
conversion j Predef.type_int
|
|
|
|
| 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
|
|
|
|
| 'B' | 'b' -> conversion j Predef.type_bool
|
2009-11-30 14:02:08 -08:00
|
|
|
| 'a' | 'r' as conv ->
|
|
|
|
let conversion =
|
|
|
|
if conv = 'a' then conversion_a else conversion_r in
|
|
|
|
let ty_e = newvar () in
|
|
|
|
let j = j + 1 in
|
|
|
|
if j >= len then conversion (j - 1) ty_e ty_e else begin
|
|
|
|
match fmt.[j] with
|
|
|
|
(* | 'a' | 'A' -> conversion j ty_e (Predef.type_array ty_e)
|
|
|
|
| 'l' | 'L' -> conversion j ty_e (Predef.type_list ty_e)
|
|
|
|
| 'o' | 'O' -> conversion j ty_e (Predef.type_option ty_e)*)
|
|
|
|
| _ -> conversion (j - 1) ty_e ty_e end
|
|
|
|
(* | 'r' ->
|
|
|
|
let ty_e = newvar () in
|
|
|
|
let j = j + 1 in
|
|
|
|
if j >= len then conversion_r (j - 1) ty_e ty_e else begin
|
|
|
|
match fmt.[j] with
|
|
|
|
| 'a' | 'A' -> conversion_r j ty_e (Pref.type_array ty_e)
|
|
|
|
| 'l' | 'L' -> conversion_r j ty_e (Pref.type_list ty_e)
|
|
|
|
| 'o' | 'O' -> conversion_r j ty_e (Pref.type_option ty_e)
|
|
|
|
| _ -> conversion_r (j - 1) ty_e ty_e end *)
|
2004-09-22 02:17:21 -07:00
|
|
|
| 't' -> conversion j (ty_arrow ty_input ty_aresult)
|
|
|
|
| 'l' | 'n' | 'L' as c ->
|
2002-12-09 01:27:54 -08:00
|
|
|
let j = j + 1 in
|
2004-09-22 02:17:21 -07:00
|
|
|
if j >= len then conversion (j - 1) Predef.type_int else begin
|
|
|
|
match fmt.[j] with
|
2012-01-11 07:22:51 -08:00
|
|
|
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
|
2004-09-22 02:17:21 -07:00
|
|
|
let ty_arg =
|
|
|
|
match c with
|
|
|
|
| 'l' -> Predef.type_int32
|
|
|
|
| 'n' -> Predef.type_nativeint
|
|
|
|
| _ -> Predef.type_int64 in
|
2004-06-14 13:38:15 -07:00
|
|
|
conversion j ty_arg
|
2004-09-22 02:17:21 -07:00
|
|
|
| c -> conversion (j - 1) Predef.type_int
|
2002-12-09 01:27:54 -08:00
|
|
|
end
|
2004-09-22 02:17:21 -07:00
|
|
|
| '{' | '(' as c ->
|
|
|
|
let j = j + 1 in
|
2005-03-04 06:51:31 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2004-12-06 22:13:06 -08:00
|
|
|
let sj =
|
2006-11-17 00:34:05 -08:00
|
|
|
Printf.CamlinternalPr.Tformat.sub_format
|
2006-10-24 14:16:10 -07:00
|
|
|
(fun fmt -> incomplete_format (format_to_string fmt))
|
|
|
|
(fun fmt -> bad_conversion (format_to_string fmt))
|
|
|
|
c (string_to_format fmt) j in
|
2006-10-04 03:03:16 -07:00
|
|
|
let sfmt = String.sub fmt j (sj - 2 - j) in
|
2004-09-22 02:17:21 -07:00
|
|
|
let ty_sfmt = type_in_format sfmt in
|
|
|
|
begin match c with
|
2006-10-04 03:03:16 -07:00
|
|
|
| '{' -> conversion (sj - 1) ty_sfmt
|
2004-09-22 02:17:21 -07:00
|
|
|
| _ -> incr meta; conversion (j - 1) ty_sfmt end
|
|
|
|
| ')' when !meta > 0 -> decr meta; scan_format (j + 1)
|
2004-12-06 22:13:06 -08:00
|
|
|
| c -> bad_conversion fmt i c in
|
2004-09-22 02:17:21 -07:00
|
|
|
scan_flags i j in
|
|
|
|
|
2006-10-24 15:07:47 -07:00
|
|
|
let ty_ureader, ty_args = scan_format 0 in
|
2004-09-22 02:17:21 -07:00
|
|
|
newty
|
2006-10-24 13:42:41 -07:00
|
|
|
(Tconstr
|
2012-01-11 07:22:51 -08:00
|
|
|
(Predef.path_format6,
|
|
|
|
[ ty_args; ty_input; ty_aresult;
|
|
|
|
ty_ureader; ty_uresult; ty_result; ],
|
|
|
|
ref Mnil)) in
|
2004-09-22 02:17:21 -07:00
|
|
|
|
|
|
|
type_in_format fmt
|
1995-05-04 03:15:53 -07:00
|
|
|
|
1999-11-30 08:07:38 -08:00
|
|
|
(* Approximate the type of an expression, for better recursion *)
|
|
|
|
|
2005-03-24 04:19:54 -08:00
|
|
|
let rec approx_type env sty =
|
1999-11-30 08:07:38 -08:00
|
|
|
match sty.ptyp_desc with
|
|
|
|
Ptyp_arrow (p, _, sty) ->
|
|
|
|
let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
|
2005-03-24 04:19:54 -08:00
|
|
|
newty (Tarrow (p, ty1, approx_type env sty, Cok))
|
|
|
|
| Ptyp_tuple args ->
|
|
|
|
newty (Ttuple (List.map (approx_type env) args))
|
|
|
|
| Ptyp_constr (lid, ctl) ->
|
|
|
|
begin try
|
2012-05-30 07:52:37 -07:00
|
|
|
let (path, decl) = Env.lookup_type lid.txt env in
|
2006-04-16 16:28:22 -07:00
|
|
|
if List.length ctl <> decl.type_arity then raise Not_found;
|
2005-03-24 04:19:54 -08:00
|
|
|
let tyl = List.map (approx_type env) ctl in
|
|
|
|
newconstr path tyl
|
|
|
|
with Not_found -> newvar ()
|
|
|
|
end
|
2009-10-26 00:11:36 -07:00
|
|
|
| Ptyp_poly (_, sty) ->
|
|
|
|
approx_type env sty
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ -> newvar ()
|
|
|
|
|
|
|
|
let rec type_approx env sexp =
|
|
|
|
match sexp.pexp_desc with
|
|
|
|
Pexp_let (_, _, e) -> type_approx env e
|
2013-04-17 04:43:29 -07:00
|
|
|
| Pexp_fun (p, _, _, e) when is_optional p ->
|
2001-04-19 01:34:21 -07:00
|
|
|
newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
|
2013-04-17 04:43:29 -07:00
|
|
|
| Pexp_fun (p,_,_, e) ->
|
2001-04-19 01:34:21 -07:00
|
|
|
newty (Tarrow(p, newvar (), type_approx env e, Cok))
|
2013-04-17 04:43:29 -07:00
|
|
|
| Pexp_function ({pc_rhs=e}::_) ->
|
|
|
|
newty (Tarrow("", newvar (), type_approx env e, Cok))
|
2013-04-15 09:23:22 -07:00
|
|
|
| Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e
|
1999-11-30 08:07:38 -08:00
|
|
|
| Pexp_try (e, _) -> type_approx env e
|
|
|
|
| Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
|
|
|
|
| Pexp_ifthenelse (_,e,_) -> type_approx env e
|
|
|
|
| Pexp_sequence (_,e) -> type_approx env e
|
2013-04-17 05:23:44 -07:00
|
|
|
| Pexp_constraint (e, sty) ->
|
|
|
|
let ty = type_approx env e in
|
|
|
|
let ty1 = approx_type env sty in
|
|
|
|
begin try unify env ty ty1 with Unify trace ->
|
|
|
|
raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
|
|
|
|
end;
|
|
|
|
ty1
|
|
|
|
| Pexp_coerce (e, sty1, sty2) ->
|
2005-03-24 04:19:54 -08:00
|
|
|
let approx_ty_opt = function
|
|
|
|
| None -> newvar ()
|
|
|
|
| Some sty -> approx_type env sty
|
|
|
|
in
|
1999-11-30 08:07:38 -08:00
|
|
|
let ty = type_approx env e
|
2005-03-24 04:19:54 -08:00
|
|
|
and ty1 = approx_ty_opt sty1
|
2013-04-17 05:23:44 -07:00
|
|
|
and ty2 = approx_type env sty2 in
|
2005-04-03 21:34:53 -07:00
|
|
|
begin try unify env ty ty1 with Unify trace ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(sexp.pexp_loc, env, Expr_type_clash trace))
|
2005-04-03 21:34:53 -07:00
|
|
|
end;
|
2013-04-17 05:23:44 -07:00
|
|
|
ty2
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ -> newvar ()
|
|
|
|
|
2001-12-05 16:19:35 -08:00
|
|
|
(* List labels in a function type, and whether return type is a variable *)
|
|
|
|
let rec list_labels_aux env visited ls ty_fun =
|
|
|
|
let ty = expand_head env ty_fun in
|
2002-06-09 19:39:35 -07:00
|
|
|
if List.memq ty visited then
|
2001-12-05 16:19:35 -08:00
|
|
|
List.rev ls, false
|
|
|
|
else match ty.desc with
|
|
|
|
Tarrow (l, _, ty_res, _) ->
|
|
|
|
list_labels_aux env (ty::visited) (l::ls) ty_res
|
|
|
|
| _ ->
|
2011-09-22 02:05:42 -07:00
|
|
|
List.rev ls, is_Tvar ty
|
2001-12-05 16:19:35 -08:00
|
|
|
|
2013-10-28 05:08:04 -07:00
|
|
|
let list_labels env ty =
|
|
|
|
wrap_trace_gadt_instances env (list_labels_aux env [] []) ty
|
2001-12-05 16:19:35 -08:00
|
|
|
|
2002-04-18 00:27:47 -07:00
|
|
|
(* Check that all univars are safe in a type *)
|
2009-10-26 00:11:36 -07:00
|
|
|
let check_univars env expans kind exp ty_expected vars =
|
|
|
|
if expans && not (is_nonexpansive exp) then
|
|
|
|
generalize_expansive env exp.exp_type;
|
2003-08-24 17:41:24 -07:00
|
|
|
(* need to expand twice? cf. Ctype.unify2 *)
|
|
|
|
let vars = List.map (expand_head env) vars in
|
|
|
|
let vars = List.map (expand_head env) vars in
|
2002-04-18 00:27:47 -07:00
|
|
|
let vars' =
|
|
|
|
List.filter
|
|
|
|
(fun t ->
|
|
|
|
let t = repr t in
|
|
|
|
generalize t;
|
2011-09-22 02:05:42 -07:00
|
|
|
match t.desc with
|
|
|
|
Tvar name when t.level = generic_level ->
|
|
|
|
log_type t; t.desc <- Tunivar name; true
|
|
|
|
| _ -> false)
|
2002-04-18 00:27:47 -07:00
|
|
|
vars in
|
|
|
|
if List.length vars = List.length vars' then () else
|
|
|
|
let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
|
|
|
|
and ty_expected = repr ty_expected in
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error (exp.exp_loc, env,
|
2002-04-18 00:27:47 -07:00
|
|
|
Less_general(kind, [ty, ty; ty_expected, ty_expected])))
|
|
|
|
|
2002-05-16 03:18:51 -07:00
|
|
|
(* Check that a type is not a function *)
|
2006-01-05 18:25:38 -08:00
|
|
|
let check_application_result env statement exp =
|
2009-09-04 09:19:35 -07:00
|
|
|
let loc = exp.exp_loc in
|
2006-01-05 18:25:38 -08:00
|
|
|
match (expand_head env exp.exp_type).desc with
|
|
|
|
| Tarrow _ ->
|
2002-05-16 03:18:51 -07:00
|
|
|
Location.prerr_warning exp.exp_loc Warnings.Partial_application
|
2011-09-22 02:05:42 -07:00
|
|
|
| Tvar _ -> ()
|
2006-01-05 18:25:38 -08:00
|
|
|
| Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
|
|
|
|
| _ ->
|
|
|
|
if statement then
|
2009-09-04 09:19:35 -07:00
|
|
|
Location.prerr_warning loc Warnings.Statement_type
|
2002-05-16 03:18:51 -07:00
|
|
|
|
2008-07-17 19:48:38 -07:00
|
|
|
(* Check that a type is generalizable at some level *)
|
|
|
|
let generalizable level ty =
|
|
|
|
let rec check ty =
|
|
|
|
let ty = repr ty in
|
|
|
|
if ty.level < lowest_level then () else
|
|
|
|
if ty.level <= level then raise Exit else
|
|
|
|
(mark_type_node ty; iter_type_expr check ty)
|
|
|
|
in
|
|
|
|
try check ty; unmark_type ty; true
|
|
|
|
with Exit -> unmark_type ty; false
|
|
|
|
|
2001-12-05 16:19:35 -08:00
|
|
|
(* Hack to allow coercion of self. Will clean-up later. *)
|
2001-11-05 01:12:59 -08:00
|
|
|
let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
|
|
|
|
|
2009-10-26 03:53:16 -07:00
|
|
|
(* Helpers for packaged modules. *)
|
|
|
|
let create_package_type loc env (p, l) =
|
|
|
|
let s = !Typetexp.transl_modtype_longident loc env p in
|
2012-05-30 07:52:37 -07:00
|
|
|
let fields = List.map (fun (name, ct) ->
|
2012-07-30 11:04:46 -07:00
|
|
|
name, Typetexp.transl_simple_type env false ct) l in
|
2012-05-30 07:52:37 -07:00
|
|
|
let ty = newty (Tpackage (s,
|
|
|
|
List.map fst l,
|
|
|
|
List.map (fun (_, cty) -> cty.ctyp_type) fields))
|
|
|
|
in
|
|
|
|
(s, fields, ty)
|
|
|
|
|
|
|
|
let wrap_unpacks sexp unpacks =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Ast_helper in
|
2012-05-30 07:52:37 -07:00
|
|
|
List.fold_left
|
|
|
|
(fun sexp (name, loc) ->
|
2013-03-08 06:59:45 -08:00
|
|
|
Exp.letmodule ~loc:sexp.pexp_loc
|
|
|
|
name
|
|
|
|
(Mod.unpack ~loc
|
|
|
|
(Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt) name.loc)))
|
|
|
|
sexp
|
|
|
|
)
|
2011-11-24 01:02:48 -08:00
|
|
|
sexp unpacks
|
|
|
|
|
|
|
|
(* Helpers for type_cases *)
|
2013-01-10 23:26:23 -08:00
|
|
|
|
|
|
|
let contains_variant_either ty =
|
2013-09-04 08:12:37 -07:00
|
|
|
let rec loop ty =
|
2013-01-10 23:26:23 -08:00
|
|
|
let ty = repr ty in
|
|
|
|
if ty.level >= lowest_level then begin
|
|
|
|
mark_type_node ty;
|
|
|
|
match ty.desc with
|
|
|
|
Tvariant row ->
|
|
|
|
let row = row_repr row in
|
|
|
|
if not row.row_fixed then
|
|
|
|
List.iter
|
|
|
|
(fun (_,f) ->
|
|
|
|
match row_field_repr f with Reither _ -> raise Exit | _ -> ())
|
|
|
|
row.row_fields;
|
|
|
|
iter_row loop row
|
|
|
|
| _ ->
|
|
|
|
iter_type_expr loop ty
|
|
|
|
end
|
|
|
|
in
|
|
|
|
try loop ty; unmark_type ty; false
|
|
|
|
with Exit -> unmark_type ty; true
|
|
|
|
|
2012-05-30 07:52:37 -07:00
|
|
|
let iter_ppat f p =
|
2010-11-11 02:02:56 -08:00
|
|
|
match p.ppat_desc with
|
2013-04-16 08:34:09 -07:00
|
|
|
| Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _
|
2013-03-04 05:52:23 -08:00
|
|
|
| Ppat_extension _
|
2012-05-30 07:52:37 -07:00
|
|
|
| Ppat_type _ | Ppat_unpack _ -> ()
|
2010-11-11 02:02:56 -08:00
|
|
|
| Ppat_array pats -> List.iter f pats
|
|
|
|
| Ppat_or (p1,p2) -> f p1; f p2
|
2013-04-17 02:46:52 -07:00
|
|
|
| Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg
|
2010-11-11 02:02:56 -08:00
|
|
|
| Ppat_tuple lst -> List.iter f lst
|
2014-05-05 04:49:37 -07:00
|
|
|
| Ppat_exception p | Ppat_alias (p,_)
|
|
|
|
| Ppat_constraint (p,_) | Ppat_lazy p -> f p
|
2011-10-25 05:11:06 -07:00
|
|
|
| Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args
|
2010-11-11 02:02:56 -08:00
|
|
|
|
2011-10-25 05:11:06 -07:00
|
|
|
let contains_polymorphic_variant p =
|
|
|
|
let rec loop p =
|
|
|
|
match p.ppat_desc with
|
2010-11-11 02:02:56 -08:00
|
|
|
Ppat_variant _ | Ppat_type _ -> raise Exit
|
|
|
|
| _ -> iter_ppat loop p
|
|
|
|
in
|
|
|
|
try loop p; false with Exit -> true
|
2009-10-26 03:53:16 -07:00
|
|
|
|
2011-11-24 01:02:48 -08:00
|
|
|
let contains_gadt env p =
|
|
|
|
let rec loop p =
|
|
|
|
match p.ppat_desc with
|
2013-04-17 02:46:52 -07:00
|
|
|
Ppat_construct (lid, _) ->
|
2011-11-24 01:02:48 -08:00
|
|
|
begin try
|
2012-12-07 18:40:56 -08:00
|
|
|
let cstrs = Env.lookup_all_constructors lid.txt env in
|
|
|
|
List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise Exit)
|
|
|
|
cstrs
|
2011-11-24 01:02:48 -08:00
|
|
|
with Not_found -> ()
|
|
|
|
end; iter_ppat loop p
|
|
|
|
| _ -> iter_ppat loop p
|
|
|
|
in
|
|
|
|
try loop p; false with Exit -> true
|
|
|
|
|
2013-01-10 23:26:23 -08:00
|
|
|
let check_absent_variant env =
|
|
|
|
iter_pattern
|
|
|
|
(function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
|
|
|
|
let row = row_repr !row in
|
|
|
|
if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
|
|
|
|
row.row_fields
|
2013-01-14 21:22:28 -08:00
|
|
|
|| not row.row_fixed && not (static_row row) (* same as Ctype.poly *)
|
2013-01-10 23:26:23 -08:00
|
|
|
then () else
|
|
|
|
let ty_arg =
|
|
|
|
match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
|
|
|
|
let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
|
|
|
|
row_more = newvar (); row_bound = ();
|
|
|
|
row_closed = false; row_fixed = false; row_name = None} in
|
|
|
|
(* Should fail *)
|
|
|
|
unify_pat env {pat with pat_type = newty (Tvariant row')}
|
|
|
|
(correct_levels pat.pat_type)
|
|
|
|
| _ -> ())
|
|
|
|
|
2011-11-24 01:02:48 -08:00
|
|
|
(* Duplicate types of values in the environment *)
|
|
|
|
(* XXX Should we do something about global type variables too? *)
|
2012-01-18 09:41:12 -08:00
|
|
|
|
2011-11-24 01:02:48 -08:00
|
|
|
let duplicate_ident_types loc caselist env =
|
|
|
|
let caselist =
|
2013-04-15 09:23:22 -07:00
|
|
|
List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
|
|
|
|
let idents = all_idents_cases caselist in
|
2010-10-21 16:59:33 -07:00
|
|
|
List.fold_left
|
2011-11-24 01:02:48 -08:00
|
|
|
(fun env s ->
|
|
|
|
try
|
2012-01-20 19:40:37 -08:00
|
|
|
(* XXX This will mark the value as being used;
|
|
|
|
I don't think this is what we want *)
|
|
|
|
let (path, desc) = Env.lookup_value (Longident.Lident s) env in
|
2011-11-24 01:02:48 -08:00
|
|
|
match path with
|
|
|
|
Path.Pident id ->
|
|
|
|
let desc = {desc with val_type = correct_levels desc.val_type} in
|
|
|
|
Env.add_value id desc env
|
|
|
|
| _ -> env
|
2012-01-20 19:40:37 -08:00
|
|
|
with Not_found -> env)
|
2011-11-24 01:02:48 -08:00
|
|
|
env idents
|
2010-10-21 16:59:33 -07:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Typing of expressions *)
|
|
|
|
|
|
|
|
let unify_exp env exp expected_ty =
|
2005-03-22 19:08:37 -08:00
|
|
|
(* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
|
|
|
|
Printtyp.raw_type_expr expected_ty; *)
|
2010-10-31 22:33:29 -07:00
|
|
|
unify_exp_types exp.exp_loc env exp.exp_type expected_ty
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
let rec type_exp env sexp =
|
2010-11-11 19:09:11 -08:00
|
|
|
(* We now delegate everything to type_expect *)
|
|
|
|
type_expect env sexp (newvar ())
|
|
|
|
|
|
|
|
(* Typing of an expression with an expected type.
|
|
|
|
This provide better error messages, and allows controlled
|
|
|
|
propagation of return type information.
|
|
|
|
In the principal case, [type_expected'] may be at generic_level.
|
|
|
|
*)
|
|
|
|
|
|
|
|
and type_expect ?in_function env sexp ty_expected =
|
2012-11-08 02:51:00 -08:00
|
|
|
let previous_saved_types = Cmt_format.get_saved_types () in
|
2014-05-06 09:07:44 -07:00
|
|
|
Typetexp.warning_enter_scope ();
|
|
|
|
Typetexp.warning_attribute sexp.pexp_attributes;
|
2012-11-08 02:51:00 -08:00
|
|
|
let exp = type_expect_ ?in_function env sexp ty_expected in
|
2014-05-06 09:07:44 -07:00
|
|
|
Typetexp.warning_leave_scope ();
|
2014-04-02 20:59:17 -07:00
|
|
|
Cmt_format.set_saved_types
|
|
|
|
(Cmt_format.Partial_expression exp :: previous_saved_types);
|
2012-11-08 02:51:00 -08:00
|
|
|
exp
|
|
|
|
|
|
|
|
and type_expect_ ?in_function env sexp ty_expected =
|
2009-09-04 09:19:35 -07:00
|
|
|
let loc = sexp.pexp_loc in
|
2010-11-11 19:09:11 -08:00
|
|
|
(* Record the expression type before unifying it with the expected type *)
|
|
|
|
let rue exp =
|
2012-11-08 02:41:11 -08:00
|
|
|
unify_exp env (re exp) (instance env ty_expected);
|
2010-11-11 19:09:11 -08:00
|
|
|
exp
|
|
|
|
in
|
1995-05-04 03:15:53 -07:00
|
|
|
match sexp.pexp_desc with
|
2009-09-04 09:19:35 -07:00
|
|
|
| Pexp_ident lid ->
|
2010-05-18 09:46:46 -07:00
|
|
|
begin
|
2012-11-08 01:40:21 -08:00
|
|
|
let (path, desc) = Typetexp.find_value env loc lid.txt in
|
2007-05-16 01:21:41 -07:00
|
|
|
if !Clflags.annotations then begin
|
2012-11-08 01:40:21 -08:00
|
|
|
let dloc = desc.Types.val_loc in
|
|
|
|
let annot =
|
|
|
|
if dloc.Location.loc_ghost then Annot.Iref_external
|
|
|
|
else Annot.Iref_internal dloc
|
|
|
|
in
|
|
|
|
let name = Path.name ~paren:Oprint.parenthesized_ident path in
|
|
|
|
Stypes.record (Stypes.An_ident (loc, name, annot))
|
2007-05-16 01:21:41 -07:00
|
|
|
end;
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2003-04-01 17:32:09 -08:00
|
|
|
exp_desc =
|
1998-06-24 12:22:26 -07:00
|
|
|
begin match desc.val_kind with
|
1998-11-29 09:34:05 -08:00
|
|
|
Val_ivar (_, cl_num) ->
|
1998-06-24 12:22:26 -07:00
|
|
|
let (self_path, _) =
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
|
1998-06-24 12:22:26 -07:00
|
|
|
in
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_instvar(self_path, path,
|
|
|
|
match lid.txt with
|
|
|
|
Longident.Lident txt -> { txt; loc = lid.loc }
|
|
|
|
| _ -> assert false)
|
2003-11-25 01:20:45 -08:00
|
|
|
| Val_self (_, _, cl_num, _) ->
|
1998-06-24 12:22:26 -07:00
|
|
|
let (path, _) =
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
|
1996-04-22 04:15:41 -07:00
|
|
|
in
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_ident(path, lid, desc)
|
1998-06-24 12:22:26 -07:00
|
|
|
| Val_unbound ->
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, env, Masked_instance_variable lid.txt))
|
2014-01-14 03:29:02 -08:00
|
|
|
(*| Val_prim _ ->
|
|
|
|
let p = Env.normalize_path (Some loc) env path in
|
|
|
|
Env.add_required_global (Path.head p);
|
|
|
|
Texp_ident(path, lid, desc)*)
|
1997-05-19 08:42:21 -07:00
|
|
|
| _ ->
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_ident(path, lid, desc)
|
|
|
|
end;
|
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance env desc.val_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
end
|
2013-05-23 08:12:04 -07:00
|
|
|
| Pexp_constant(Const_string (s, _) as cst) ->
|
2014-04-02 19:52:51 -07:00
|
|
|
let ty_exp = expand_head env ty_expected in
|
|
|
|
let ty =
|
|
|
|
(* Terrible hack for format strings *)
|
|
|
|
match ty_exp.desc with
|
|
|
|
Tconstr(path, _, _) when Path.same path Predef.path_format6 ->
|
|
|
|
if !Clflags.principal && ty_exp.level <> generic_level then
|
|
|
|
Location.prerr_warning loc
|
|
|
|
(Warnings.Not_principal "this coercion to format6");
|
|
|
|
type_format loc s
|
|
|
|
| _ -> instance_def Predef.type_string
|
|
|
|
in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2013-05-23 08:12:04 -07:00
|
|
|
exp_desc = Texp_constant cst;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2014-04-02 19:52:51 -07:00
|
|
|
exp_type = ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_constant cst ->
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2013-05-23 08:12:04 -07:00
|
|
|
exp_desc = Texp_constant cst;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = type_constant cst;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
2014-01-22 17:58:37 -08:00
|
|
|
| Pexp_let(Nonrecursive,
|
|
|
|
[{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
|
|
|
|
when contains_gadt env spat ->
|
2013-06-03 08:14:19 -07:00
|
|
|
(* TODO: allow non-empty attributes? *)
|
2011-11-24 01:02:48 -08:00
|
|
|
type_expect ?in_function env
|
2014-01-22 17:58:37 -08:00
|
|
|
{sexp with
|
|
|
|
pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
|
2011-11-24 01:02:48 -08:00
|
|
|
ty_expected
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
|
2007-05-16 01:21:41 -07:00
|
|
|
let scp =
|
2013-04-04 05:38:20 -07:00
|
|
|
match sexp.pexp_attributes, rec_flag with
|
2013-04-19 00:40:57 -07:00
|
|
|
| [{txt="#default"},_], _ -> None
|
2013-04-04 05:38:20 -07:00
|
|
|
| _, Recursive -> Some (Annot.Idef loc)
|
|
|
|
| _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
|
2007-05-16 01:21:41 -07:00
|
|
|
in
|
2010-10-21 16:59:33 -07:00
|
|
|
let (pat_exp_list, new_env, unpacks) =
|
|
|
|
type_let env rec_flag spat_sexp_list scp true in
|
2010-11-11 19:09:11 -08:00
|
|
|
let body =
|
|
|
|
type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = body.exp_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
2013-04-17 04:43:29 -07:00
|
|
|
| Pexp_fun (l, Some default, spat, sexp) ->
|
2013-04-17 03:01:24 -07:00
|
|
|
assert(is_optional l); (* default allowed only with optional argument *)
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Ast_helper in
|
2013-04-11 05:50:38 -07:00
|
|
|
let default_loc = default.pexp_loc in
|
2010-11-11 19:09:11 -08:00
|
|
|
let scases = [
|
2013-04-15 09:23:22 -07:00
|
|
|
Exp.case
|
|
|
|
(Pat.construct ~loc:default_loc
|
|
|
|
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
|
2013-04-17 02:46:52 -07:00
|
|
|
(Some (Pat.var ~loc:default_loc (mknoloc "*sth*"))))
|
2013-04-15 09:23:22 -07:00
|
|
|
(Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
|
|
|
|
|
|
|
|
Exp.case
|
|
|
|
(Pat.construct ~loc:default_loc
|
|
|
|
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
|
2013-04-17 02:46:52 -07:00
|
|
|
None)
|
2013-04-15 09:23:22 -07:00
|
|
|
default;
|
2013-03-08 06:59:45 -08:00
|
|
|
]
|
|
|
|
in
|
|
|
|
let smatch =
|
|
|
|
Exp.match_ ~loc (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*")))
|
|
|
|
scases
|
|
|
|
in
|
|
|
|
let sfun =
|
2013-04-17 04:43:29 -07:00
|
|
|
Exp.fun_ ~loc
|
2013-03-08 06:59:45 -08:00
|
|
|
l None
|
2013-04-17 04:43:29 -07:00
|
|
|
(Pat.var ~loc (mknoloc "*opt*"))
|
2014-01-22 17:58:37 -08:00
|
|
|
(Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []]
|
|
|
|
[Vb.mk spat smatch] sexp)
|
2013-03-08 06:59:45 -08:00
|
|
|
in
|
2010-11-11 19:09:11 -08:00
|
|
|
type_expect ?in_function env sfun ty_expected
|
2013-04-17 04:43:29 -07:00
|
|
|
(* TODO: keep attributes, call type_function directly *)
|
|
|
|
| Pexp_fun (l, None, spat, sexp) ->
|
|
|
|
type_function ?in_function loc sexp.pexp_attributes env ty_expected
|
|
|
|
l [{pc_lhs=spat; pc_guard=None; pc_rhs=sexp}]
|
|
|
|
| Pexp_function caselist ->
|
|
|
|
type_function ?in_function
|
|
|
|
loc sexp.pexp_attributes env ty_expected "" caselist
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_apply(sfunct, sargs) ->
|
2004-11-28 18:27:25 -08:00
|
|
|
begin_def (); (* one more level for non-returning functions *)
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
1995-05-04 03:15:53 -07:00
|
|
|
let funct = type_exp env sfunct in
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin
|
2012-05-30 07:52:37 -07:00
|
|
|
end_def ();
|
|
|
|
generalize_structure funct.exp_type
|
|
|
|
end;
|
2006-08-11 15:40:19 -07:00
|
|
|
let rec lower_args seen ty_fun =
|
|
|
|
let ty = expand_head env ty_fun in
|
|
|
|
if List.memq ty seen then () else
|
|
|
|
match ty.desc with
|
|
|
|
Tarrow (l, ty_arg, ty_fun, com) ->
|
2010-12-12 18:59:58 -08:00
|
|
|
(try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
|
2006-08-11 15:40:19 -07:00
|
|
|
lower_args (ty::seen) ty_fun
|
2004-11-28 18:27:25 -08:00
|
|
|
| _ -> ()
|
|
|
|
in
|
2011-11-24 01:02:48 -08:00
|
|
|
let ty = instance env funct.exp_type in
|
2004-11-28 18:27:25 -08:00
|
|
|
end_def ();
|
2013-10-28 05:08:04 -07:00
|
|
|
wrap_trace_gadt_instances env (lower_args []) ty;
|
2004-11-28 18:27:25 -08:00
|
|
|
begin_def ();
|
1999-11-30 08:07:38 -08:00
|
|
|
let (args, ty_res) = type_application env funct sargs in
|
2004-11-28 18:27:25 -08:00
|
|
|
end_def ();
|
|
|
|
unify_var env (newvar()) funct.exp_type;
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2003-04-01 17:32:09 -08:00
|
|
|
exp_desc = Texp_apply(funct, args);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = ty_res;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_match(sarg, caselist) ->
|
2011-11-24 01:02:48 -08:00
|
|
|
begin_def ();
|
1995-05-04 03:15:53 -07:00
|
|
|
let arg = type_exp env sarg in
|
2011-11-24 01:02:48 -08:00
|
|
|
end_def ();
|
|
|
|
if is_nonexpansive arg then generalize arg.exp_type
|
|
|
|
else generalize_expansive env arg.exp_type;
|
2014-05-05 04:49:37 -07:00
|
|
|
let rec split_cases vc ec = function
|
|
|
|
| [] -> List.rev vc, List.rev ec
|
|
|
|
| {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest ->
|
2014-05-05 04:54:34 -07:00
|
|
|
split_cases vc ({c with pc_lhs = p} :: ec) rest
|
2014-05-05 04:49:37 -07:00
|
|
|
| c :: rest ->
|
2014-05-05 04:54:34 -07:00
|
|
|
split_cases (c :: vc) ec rest
|
2002-11-20 21:39:01 -08:00
|
|
|
in
|
2014-05-05 04:49:37 -07:00
|
|
|
let val_caselist, exn_caselist = split_cases [] [] caselist in
|
2014-05-05 10:19:49 -07:00
|
|
|
if val_caselist = [] && exn_caselist <> [] then
|
|
|
|
raise (Error (loc, env, No_value_clauses));
|
|
|
|
(* Note: val_caselist = [] and exn_caselist = [], i.e. a fully
|
|
|
|
empty pattern matching can be generated by Camlp4 with its
|
|
|
|
revised syntax. Let's accept it for backward compatibility. *)
|
2014-05-05 04:49:37 -07:00
|
|
|
let val_cases, partial =
|
|
|
|
type_cases env arg.exp_type ty_expected true loc val_caselist in
|
|
|
|
let exn_cases, _ =
|
|
|
|
type_cases env Predef.type_exn ty_expected false loc exn_caselist in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
2014-05-05 04:49:37 -07:00
|
|
|
exp_desc = Texp_match(arg, val_cases, exn_cases, partial);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance env ty_expected;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_try(sbody, caselist) ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let body = type_expect env sbody ty_expected in
|
2000-11-06 01:49:27 -08:00
|
|
|
let cases, _ =
|
2010-11-11 19:09:11 -08:00
|
|
|
type_cases env Predef.type_exn ty_expected false loc caselist in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_try(body, cases);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = body.exp_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_tuple sexpl ->
|
2011-10-25 05:11:06 -07:00
|
|
|
let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
|
2010-11-11 19:09:11 -08:00
|
|
|
let to_unify = newgenty (Ttuple subtypes) in
|
|
|
|
unify_exp_types loc env to_unify ty_expected;
|
2011-10-25 05:11:06 -07:00
|
|
|
let expl =
|
|
|
|
List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes
|
2010-11-11 19:09:11 -08:00
|
|
|
in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_tuple expl;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-02-23 22:29:26 -08:00
|
|
|
(* Keep sharing *)
|
|
|
|
exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
2013-04-17 02:46:52 -07:00
|
|
|
| Pexp_construct(lid, sarg) ->
|
|
|
|
type_construct env loc lid sarg ty_expected sexp.pexp_attributes
|
1999-11-30 08:07:38 -08:00
|
|
|
| Pexp_variant(l, sarg) ->
|
2011-02-23 22:29:26 -08:00
|
|
|
(* Keep sharing *)
|
2011-11-24 01:02:48 -08:00
|
|
|
let ty_expected0 = instance env ty_expected in
|
2011-02-23 22:29:26 -08:00
|
|
|
begin try match
|
|
|
|
sarg, expand_head env ty_expected, expand_head env ty_expected0 with
|
|
|
|
| Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let row = row_repr row in
|
2011-02-23 22:29:26 -08:00
|
|
|
begin match row_field_repr (List.assoc l row.row_fields),
|
|
|
|
row_field_repr (List.assoc l row0.row_fields) with
|
|
|
|
Rpresent (Some ty), Rpresent (Some ty0) ->
|
|
|
|
let arg = type_argument env sarg ty ty0 in
|
2010-11-11 19:09:11 -08:00
|
|
|
re { exp_desc = Texp_variant(l, Some arg);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-02-23 22:29:26 -08:00
|
|
|
exp_type = ty_expected0;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env }
|
|
|
|
| _ -> raise Not_found
|
|
|
|
end
|
|
|
|
| _ -> raise Not_found
|
|
|
|
with Not_found ->
|
|
|
|
let arg = may_map (type_exp env) sarg in
|
|
|
|
let arg_type = may_map (fun arg -> arg.exp_type) arg in
|
|
|
|
rue {
|
|
|
|
exp_desc = Texp_variant(l, arg);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
|
|
|
|
row_more = newvar ();
|
|
|
|
row_bound = ();
|
|
|
|
row_closed = false;
|
|
|
|
row_fixed = false;
|
|
|
|
row_name = None});
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env }
|
|
|
|
end
|
1998-04-27 08:17:11 -07:00
|
|
|
| Pexp_record(lid_sexp_list, opt_sexp) ->
|
2012-09-21 04:16:02 -07:00
|
|
|
let opt_exp =
|
|
|
|
match opt_sexp with
|
|
|
|
None -> None
|
|
|
|
| Some sexp ->
|
|
|
|
if !Clflags.principal then begin_def ();
|
|
|
|
let exp = type_exp env sexp in
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure exp.exp_type
|
|
|
|
end;
|
|
|
|
Some exp
|
|
|
|
in
|
2012-11-08 01:39:23 -08:00
|
|
|
let ty_record, opath =
|
2012-09-21 04:16:02 -07:00
|
|
|
let get_path ty =
|
2013-09-04 08:12:37 -07:00
|
|
|
try
|
|
|
|
let (p0, p,_) = extract_concrete_record env ty in
|
|
|
|
(* XXX level may be wrong *)
|
2012-11-10 19:46:59 -08:00
|
|
|
Some (p0, p, ty.level = generic_level || not !Clflags.principal)
|
2012-10-18 00:35:30 -07:00
|
|
|
with Not_found -> None
|
2012-09-21 04:16:02 -07:00
|
|
|
in
|
|
|
|
match get_path ty_expected with
|
|
|
|
None ->
|
2013-09-19 00:25:51 -07:00
|
|
|
begin match opt_exp with
|
|
|
|
None -> newvar (), None
|
|
|
|
| Some exp ->
|
|
|
|
match get_path exp.exp_type with
|
|
|
|
None -> newvar (), None
|
|
|
|
| Some (_, p', _) as op ->
|
|
|
|
let decl = Env.find_type p' env in
|
|
|
|
begin_def ();
|
|
|
|
let ty =
|
|
|
|
newconstr p' (instance_list env decl.type_params) in
|
|
|
|
end_def ();
|
2014-01-22 17:58:37 -08:00
|
|
|
generalize_structure ty;
|
2013-09-19 00:25:51 -07:00
|
|
|
ty, op
|
|
|
|
end
|
2012-11-08 01:39:23 -08:00
|
|
|
| op -> ty_expected, op
|
2012-09-21 04:16:02 -07:00
|
|
|
in
|
2012-10-29 00:54:06 -07:00
|
|
|
let closed = (opt_sexp = None) in
|
2010-08-02 07:37:22 -07:00
|
|
|
let lbl_exp_list =
|
2013-09-19 00:25:51 -07:00
|
|
|
wrap_disambiguate "This record expression is expected to have" ty_record
|
|
|
|
(type_label_a_list loc closed env
|
|
|
|
(type_label_exp true env loc ty_record)
|
|
|
|
opath)
|
|
|
|
lid_sexp_list
|
|
|
|
in
|
2012-11-08 01:39:23 -08:00
|
|
|
unify_exp_types loc env ty_record (instance env ty_expected);
|
2013-09-04 08:12:37 -07:00
|
|
|
|
2012-11-14 08:59:33 -08:00
|
|
|
(* type_label_a_list returns a list of labels sorted by lbl_pos *)
|
|
|
|
(* note: check_duplicates would better be implemented in
|
|
|
|
type_label_a_list directly *)
|
2012-11-15 05:57:46 -08:00
|
|
|
let rec check_duplicates = function
|
|
|
|
| (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
|
2013-01-29 06:21:12 -08:00
|
|
|
raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name))
|
2012-11-14 08:59:33 -08:00
|
|
|
| _ :: rem ->
|
|
|
|
check_duplicates rem
|
|
|
|
| [] -> ()
|
|
|
|
in
|
|
|
|
check_duplicates lbl_exp_list;
|
1998-04-27 08:17:11 -07:00
|
|
|
let opt_exp =
|
2012-09-21 04:16:02 -07:00
|
|
|
match opt_exp, lbl_exp_list with
|
2000-06-12 23:59:29 -07:00
|
|
|
None, _ -> None
|
2012-11-08 01:39:23 -08:00
|
|
|
| Some exp, (lid, lbl, lbl_exp) :: _ ->
|
2012-09-21 04:16:02 -07:00
|
|
|
let ty_exp = instance env exp.exp_type in
|
2000-06-12 23:59:29 -07:00
|
|
|
let unify_kept lbl =
|
2012-09-21 04:16:02 -07:00
|
|
|
(* do not connect overridden labels *)
|
2012-05-31 01:07:31 -07:00
|
|
|
if List.for_all
|
2012-10-24 05:03:00 -07:00
|
|
|
(fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
|
2000-06-12 23:59:29 -07:00
|
|
|
lbl_exp_list
|
|
|
|
then begin
|
2002-04-18 00:27:47 -07:00
|
|
|
let _, ty_arg1, ty_res1 = instance_label false lbl
|
|
|
|
and _, ty_arg2, ty_res2 = instance_label false lbl in
|
2012-11-08 01:39:23 -08:00
|
|
|
unify env ty_arg1 ty_arg2;
|
2011-11-24 01:02:48 -08:00
|
|
|
unify env (instance env ty_expected) ty_res2;
|
2012-11-08 01:39:23 -08:00
|
|
|
unify_exp_types exp.exp_loc env ty_exp ty_res1;
|
2000-06-12 23:59:29 -07:00
|
|
|
end in
|
|
|
|
Array.iter unify_kept lbl.lbl_all;
|
2012-09-21 04:16:02 -07:00
|
|
|
Some {exp with exp_type = ty_exp}
|
2000-06-12 23:59:29 -07:00
|
|
|
| _ -> assert false
|
|
|
|
in
|
2010-08-02 07:37:22 -07:00
|
|
|
let num_fields =
|
|
|
|
match lbl_exp_list with [] -> assert false
|
2012-10-24 05:03:00 -07:00
|
|
|
| (_, lbl,_)::_ -> Array.length lbl.lbl_all in
|
2010-08-02 07:37:22 -07:00
|
|
|
if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin
|
2001-06-28 18:46:46 -07:00
|
|
|
let present_indices =
|
2012-10-24 05:03:00 -07:00
|
|
|
List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
|
2010-11-11 19:09:11 -08:00
|
|
|
let label_names = extract_label_names sexp env ty_expected in
|
2001-06-28 18:46:46 -07:00
|
|
|
let rec missing_labels n = function
|
|
|
|
[] -> []
|
|
|
|
| lbl :: rem ->
|
2002-12-09 01:27:54 -08:00
|
|
|
if List.mem n present_indices then missing_labels (n + 1) rem
|
|
|
|
else lbl :: missing_labels (n + 1) rem
|
2001-06-28 18:46:46 -07:00
|
|
|
in
|
|
|
|
let missing = missing_labels 0 label_names in
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env, Label_missing missing))
|
2005-09-14 20:09:26 -07:00
|
|
|
end
|
2010-08-02 07:37:22 -07:00
|
|
|
else if opt_sexp <> None && List.length lid_sexp_list = num_fields then
|
2009-09-04 09:19:35 -07:00
|
|
|
Location.prerr_warning loc Warnings.Useless_record_with;
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_record(lbl_exp_list, opt_exp);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance env ty_expected;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
2012-09-21 00:01:44 -07:00
|
|
|
| Pexp_field(srecord, lid) ->
|
2012-11-08 01:39:23 -08:00
|
|
|
let (record, label, _) = type_label_access env loc srecord lid in
|
2002-04-18 00:27:47 -07:00
|
|
|
let (_, ty_arg, ty_res) = instance_label false label in
|
2012-09-21 00:01:44 -07:00
|
|
|
unify_exp env record ty_res;
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2012-10-24 05:57:16 -07:00
|
|
|
exp_desc = Texp_field(record, lid, label);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = ty_arg;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_setfield(srecord, lid, snewval) ->
|
2012-11-08 01:39:23 -08:00
|
|
|
let (record, label, opath) = type_label_access env loc srecord lid in
|
|
|
|
let ty_record = if opath = None then newvar () else record.exp_type in
|
2012-10-24 05:03:00 -07:00
|
|
|
let (label_loc, label, newval) =
|
2012-11-08 01:39:23 -08:00
|
|
|
type_label_exp false env loc ty_record (lid, label, snewval) in
|
|
|
|
unify_exp env record ty_record;
|
1995-05-04 03:15:53 -07:00
|
|
|
if label.lbl_mut = Immutable then
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, env, Label_not_mutable lid.txt));
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2012-10-24 05:03:00 -07:00
|
|
|
exp_desc = Texp_setfield(record, label_loc, label, newval);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance_def Predef.type_unit;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_array(sargl) ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let ty = newgenvar() in
|
|
|
|
let to_unify = Predef.type_array ty in
|
|
|
|
unify_exp_types loc env to_unify ty_expected;
|
1995-05-04 03:15:53 -07:00
|
|
|
let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_array argl;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance env ty_expected;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_ifthenelse(scond, sifso, sifnot) ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let cond = type_expect env scond Predef.type_bool in
|
1995-05-04 03:15:53 -07:00
|
|
|
begin match sifnot with
|
|
|
|
None ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let ifso = type_expect env sifso Predef.type_unit in
|
|
|
|
rue {
|
2003-04-01 17:32:09 -08:00
|
|
|
exp_desc = Texp_ifthenelse(cond, ifso, None);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_type = ifso.exp_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1996-05-31 05:30:26 -07:00
|
|
|
| Some sifnot ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let ifso = type_expect env sifso ty_expected in
|
|
|
|
let ifnot = type_expect env sifnot ty_expected in
|
2011-02-23 22:29:26 -08:00
|
|
|
(* Keep sharing *)
|
|
|
|
unify_exp env ifnot ifso.exp_type;
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = ifso.exp_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
end
|
|
|
|
| Pexp_sequence(sexp1, sexp2) ->
|
|
|
|
let exp1 = type_statement env sexp1 in
|
2010-11-11 19:09:11 -08:00
|
|
|
let exp2 = type_expect env sexp2 ty_expected in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_sequence(exp1, exp2);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = exp2.exp_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_while(scond, sbody) ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let cond = type_expect env scond Predef.type_bool in
|
1995-05-04 03:15:53 -07:00
|
|
|
let body = type_statement env sbody in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2003-04-01 17:32:09 -08:00
|
|
|
exp_desc = Texp_while(cond, body);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance_def Predef.type_unit;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_for(param, slow, shigh, dir, sbody) ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let low = type_expect env slow Predef.type_int in
|
|
|
|
let high = type_expect env shigh Predef.type_int in
|
2013-12-02 10:00:18 -08:00
|
|
|
let id, new_env =
|
|
|
|
match param.ppat_desc with
|
|
|
|
| Ppat_any -> Ident.create "_for", env
|
|
|
|
| Ppat_var {txt} ->
|
|
|
|
Env.enter_value txt {val_type = instance_def Predef.type_int;
|
|
|
|
val_attributes = [];
|
|
|
|
val_kind = Val_reg; Types.val_loc = loc; } env
|
|
|
|
~check:(fun s -> Warnings.Unused_for_index s)
|
|
|
|
| _ ->
|
|
|
|
raise (Error (param.ppat_loc, env, Invalid_for_loop_index))
|
2011-12-29 09:49:58 -08:00
|
|
|
in
|
1995-05-04 03:15:53 -07:00
|
|
|
let body = type_statement new_env sbody in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_desc = Texp_for(id, param, low, high, dir, body);
|
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance_def Predef.type_unit;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
2013-04-17 05:23:44 -07:00
|
|
|
| Pexp_constraint (sarg, sty) ->
|
|
|
|
let separate = true in (* always separate, 1% slowdown for lablgtk *)
|
|
|
|
if separate then begin_def ();
|
|
|
|
let cty = Typetexp.transl_simple_type env false sty in
|
|
|
|
let ty = cty.ctyp_type in
|
|
|
|
let (arg, ty') =
|
|
|
|
if separate then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure ty;
|
|
|
|
(type_argument env sarg ty (instance env ty), instance env ty)
|
|
|
|
end else
|
|
|
|
(type_argument env sarg ty ty, ty)
|
|
|
|
in
|
|
|
|
rue {
|
|
|
|
exp_desc = arg.exp_desc;
|
|
|
|
exp_loc = arg.exp_loc;
|
|
|
|
exp_type = ty';
|
|
|
|
exp_attributes = arg.exp_attributes;
|
|
|
|
exp_env = env;
|
2014-01-22 17:58:37 -08:00
|
|
|
exp_extra =
|
|
|
|
(Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
|
2013-04-17 05:23:44 -07:00
|
|
|
}
|
|
|
|
| Pexp_coerce(sarg, sty, sty') ->
|
2012-02-14 02:00:18 -08:00
|
|
|
let separate = true (* always separate, 1% slowdown for lablgtk *)
|
|
|
|
(* !Clflags.principal || Env.has_local_constraints env *) in
|
2012-05-30 07:52:37 -07:00
|
|
|
let (arg, ty',cty,cty') =
|
2013-04-17 05:23:44 -07:00
|
|
|
match sty with
|
|
|
|
| None ->
|
2012-05-30 07:52:37 -07:00
|
|
|
let (cty', force) =
|
1997-01-20 09:11:47 -08:00
|
|
|
Typetexp.transl_simple_type_delayed env sty'
|
|
|
|
in
|
2012-05-30 07:52:37 -07:00
|
|
|
let ty' = cty'.ctyp_type in
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin_def ();
|
1996-05-26 06:42:34 -07:00
|
|
|
let arg = type_exp env sarg in
|
2008-07-17 19:48:38 -07:00
|
|
|
let gen =
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin
|
2008-07-17 19:48:38 -07:00
|
|
|
end_def ();
|
|
|
|
let tv = newvar () in
|
|
|
|
let gen = generalizable tv.level arg.exp_type in
|
|
|
|
unify_var env tv arg.exp_type;
|
|
|
|
gen
|
|
|
|
end else true
|
|
|
|
in
|
2001-11-05 01:12:59 -08:00
|
|
|
begin match arg.exp_desc, !self_coercion, (repr ty').desc with
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
|
2001-11-05 01:12:59 -08:00
|
|
|
Tconstr(path',_,_) when Path.same path path' ->
|
2009-05-20 04:52:42 -07:00
|
|
|
(* prerr_endline "self coercion"; *)
|
2009-09-04 09:19:35 -07:00
|
|
|
r := loc :: !r;
|
2001-11-05 01:12:59 -08:00
|
|
|
force ()
|
2009-05-20 04:52:42 -07:00
|
|
|
| _ when free_variables ~env arg.exp_type = []
|
|
|
|
&& free_variables ~env ty' = [] ->
|
2008-07-17 19:48:38 -07:00
|
|
|
if not gen && (* first try a single coercion *)
|
|
|
|
let snap = snapshot () in
|
|
|
|
let ty, b = enlarge_type env ty' in
|
|
|
|
try
|
|
|
|
force (); Ctype.unify env arg.exp_type ty; true
|
|
|
|
with Unify _ ->
|
|
|
|
backtrack snap; false
|
|
|
|
then ()
|
|
|
|
else begin try
|
|
|
|
let force' = subtype env arg.exp_type ty' in
|
|
|
|
force (); force' ();
|
|
|
|
if not gen then
|
2009-09-04 09:19:35 -07:00
|
|
|
Location.prerr_warning loc
|
2008-07-17 19:48:38 -07:00
|
|
|
(Warnings.Not_principal "this ground coercion");
|
|
|
|
with Subtype (tr1, tr2) ->
|
2009-05-20 04:52:42 -07:00
|
|
|
(* prerr_endline "coercion failed"; *)
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env, Not_subtype(tr1, tr2)))
|
2008-07-17 19:48:38 -07:00
|
|
|
end;
|
2001-11-05 01:12:59 -08:00
|
|
|
| _ ->
|
2002-05-29 23:24:45 -07:00
|
|
|
let ty, b = enlarge_type env ty' in
|
2001-11-05 01:12:59 -08:00
|
|
|
force ();
|
|
|
|
begin try Ctype.unify env arg.exp_type ty with Unify trace ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(sarg.pexp_loc, env,
|
2002-06-12 02:52:08 -07:00
|
|
|
Coercion_failure(ty', full_expand env ty', trace, b)))
|
2001-11-05 01:12:59 -08:00
|
|
|
end
|
1996-05-26 06:42:34 -07:00
|
|
|
end;
|
2013-04-17 05:23:44 -07:00
|
|
|
(arg, ty', None, cty')
|
|
|
|
| Some sty ->
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin_def ();
|
2012-05-30 07:52:37 -07:00
|
|
|
let (cty, force) =
|
1997-01-20 09:11:47 -08:00
|
|
|
Typetexp.transl_simple_type_delayed env sty
|
2012-05-30 07:52:37 -07:00
|
|
|
and (cty', force') =
|
1997-01-20 09:11:47 -08:00
|
|
|
Typetexp.transl_simple_type_delayed env sty'
|
|
|
|
in
|
2012-05-30 07:52:37 -07:00
|
|
|
let ty = cty.ctyp_type in
|
|
|
|
let ty' = cty'.ctyp_type in
|
1997-01-20 09:11:47 -08:00
|
|
|
begin try
|
|
|
|
let force'' = subtype env ty ty' in
|
|
|
|
force (); force' (); force'' ()
|
|
|
|
with Subtype (tr1, tr2) ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env, Not_subtype(tr1, tr2)))
|
1997-01-20 09:11:47 -08:00
|
|
|
end;
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin
|
2010-10-21 16:59:33 -07:00
|
|
|
end_def ();
|
|
|
|
generalize_structure ty;
|
|
|
|
generalize_structure ty';
|
2012-05-31 01:07:31 -07:00
|
|
|
(type_argument env sarg ty (instance env ty),
|
2013-04-17 05:23:44 -07:00
|
|
|
instance env ty', Some cty, cty')
|
2010-10-21 16:59:33 -07:00
|
|
|
end else
|
2013-04-17 05:23:44 -07:00
|
|
|
(type_argument env sarg ty ty, ty', Some cty, cty')
|
1996-05-26 06:42:34 -07:00
|
|
|
in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2003-04-01 17:32:09 -08:00
|
|
|
exp_desc = arg.exp_desc;
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = arg.exp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = ty';
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = arg.exp_attributes;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_env = env;
|
2013-04-17 05:23:44 -07:00
|
|
|
exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) ::
|
|
|
|
arg.exp_extra;
|
2012-05-30 07:52:37 -07:00
|
|
|
}
|
1996-04-22 04:15:41 -07:00
|
|
|
| Pexp_send (e, met) ->
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
1998-06-24 12:22:26 -07:00
|
|
|
let obj = type_exp env e in
|
1996-04-22 04:15:41 -07:00
|
|
|
begin try
|
2012-05-30 07:52:37 -07:00
|
|
|
let (meth, exp, typ) =
|
1998-06-24 12:22:26 -07:00
|
|
|
match obj.exp_desc with
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_ident(path, _, {val_kind = Val_self (meths, _, _, privty)}) ->
|
1998-06-24 12:22:26 -07:00
|
|
|
let (id, typ) =
|
2003-11-25 01:20:45 -08:00
|
|
|
filter_self_method env met Private meths privty
|
1998-06-24 12:22:26 -07:00
|
|
|
in
|
2011-09-22 02:05:42 -07:00
|
|
|
if is_Tvar (repr typ) then
|
2009-09-04 09:19:35 -07:00
|
|
|
Location.prerr_warning loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Undeclared_virtual_method met);
|
2012-05-30 07:52:37 -07:00
|
|
|
(Tmeth_val id, None, typ)
|
|
|
|
| Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) ->
|
1998-06-24 12:22:26 -07:00
|
|
|
let method_id =
|
|
|
|
begin try List.assoc met methods with Not_found ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(e.pexp_loc, env, Undefined_inherited_method met))
|
1998-06-24 12:22:26 -07:00
|
|
|
end
|
1996-04-22 04:15:41 -07:00
|
|
|
in
|
1998-06-24 12:22:26 -07:00
|
|
|
begin match
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.lookup_value (Longident.Lident ("selfpat-" ^ cl_num)) env,
|
|
|
|
Env.lookup_value (Longident.Lident ("self-" ^cl_num)) env
|
1998-06-24 12:22:26 -07:00
|
|
|
with
|
2003-11-25 01:20:45 -08:00
|
|
|
(_, ({val_kind = Val_self (meths, _, _, privty)} as desc)),
|
1998-06-24 12:22:26 -07:00
|
|
|
(path, _) ->
|
|
|
|
let (_, typ) =
|
2003-11-25 01:20:45 -08:00
|
|
|
filter_self_method env met Private meths privty
|
1998-06-24 12:22:26 -07:00
|
|
|
in
|
|
|
|
let method_type = newvar () in
|
1999-11-30 08:07:38 -08:00
|
|
|
let (obj_ty, res_ty) = filter_arrow env method_type "" in
|
1998-06-24 12:22:26 -07:00
|
|
|
unify env obj_ty desc.val_type;
|
2011-11-24 01:02:48 -08:00
|
|
|
unify env res_ty (instance env typ);
|
2012-07-30 11:04:46 -07:00
|
|
|
let exp =
|
|
|
|
Texp_apply({exp_desc =
|
2012-05-31 01:07:31 -07:00
|
|
|
Texp_ident(Path.Pident method_id, lid,
|
|
|
|
{val_type = method_type;
|
|
|
|
val_kind = Val_reg;
|
2013-09-26 08:24:11 -07:00
|
|
|
val_attributes = [];
|
2012-05-31 01:07:31 -07:00
|
|
|
Types.val_loc = Location.none});
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1998-06-24 12:22:26 -07:00
|
|
|
exp_type = method_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = []; (* check *)
|
2012-05-31 01:07:31 -07:00
|
|
|
exp_env = env},
|
2012-05-30 07:52:37 -07:00
|
|
|
["",
|
|
|
|
Some {exp_desc = Texp_ident(path, lid, desc);
|
2012-05-31 01:07:31 -07:00
|
|
|
exp_loc = obj.exp_loc; exp_extra = [];
|
|
|
|
exp_type = desc.val_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = []; (* check *)
|
2012-05-31 01:07:31 -07:00
|
|
|
exp_env = env},
|
2012-05-30 07:52:37 -07:00
|
|
|
Required])
|
2012-07-30 11:04:46 -07:00
|
|
|
in
|
2012-05-31 01:07:31 -07:00
|
|
|
(Tmeth_name met, Some (re {exp_desc = exp;
|
2012-07-30 11:04:46 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
|
|
|
exp_type = typ;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = []; (* check *)
|
2012-07-30 11:04:46 -07:00
|
|
|
exp_env = env}), typ)
|
1998-06-24 12:22:26 -07:00
|
|
|
| _ ->
|
|
|
|
assert false
|
|
|
|
end
|
1996-04-22 04:15:41 -07:00
|
|
|
| _ ->
|
2012-05-30 07:52:37 -07:00
|
|
|
(Tmeth_name met, None,
|
1998-06-24 12:22:26 -07:00
|
|
|
filter_method env met Public obj.exp_type)
|
2002-04-18 00:27:47 -07:00
|
|
|
in
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure typ;
|
|
|
|
end;
|
|
|
|
let typ =
|
|
|
|
match repr typ with
|
|
|
|
{desc = Tpoly (ty, [])} ->
|
2011-11-24 01:02:48 -08:00
|
|
|
instance env ty
|
2002-04-18 00:27:47 -07:00
|
|
|
| {desc = Tpoly (ty, tl); level = l} ->
|
|
|
|
if !Clflags.principal && l <> generic_level then
|
2009-09-04 09:19:35 -07:00
|
|
|
Location.prerr_warning loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Not_principal "this use of a polymorphic method");
|
2002-04-18 00:27:47 -07:00
|
|
|
snd (instance_poly false tl ty)
|
2011-09-22 02:05:42 -07:00
|
|
|
| {desc = Tvar _} as ty ->
|
2002-04-18 00:27:47 -07:00
|
|
|
let ty' = newvar () in
|
2011-11-24 01:02:48 -08:00
|
|
|
unify env (instance_def ty) (newty(Tpoly(ty',[])));
|
2002-04-18 00:27:47 -07:00
|
|
|
(* if not !Clflags.nolabels then
|
|
|
|
Location.prerr_warning loc (Warnings.Unknown_method met); *)
|
|
|
|
ty'
|
|
|
|
| _ ->
|
|
|
|
assert false
|
1996-04-22 04:15:41 -07:00
|
|
|
in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_desc = Texp_send(obj, meth, exp);
|
|
|
|
exp_loc = loc; exp_extra = [];
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_type = typ;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env }
|
1996-05-20 09:43:29 -07:00
|
|
|
with Unify _ ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(e.pexp_loc, env, Undefined_method (obj.exp_type, met)))
|
1996-04-22 04:15:41 -07:00
|
|
|
end
|
|
|
|
| Pexp_new cl ->
|
2012-05-30 07:52:37 -07:00
|
|
|
let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in
|
2013-09-27 08:04:03 -07:00
|
|
|
begin match cl_decl.cty_new with
|
1997-05-19 08:42:21 -07:00
|
|
|
None ->
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, env, Virtual_class cl.txt))
|
1996-04-22 04:15:41 -07:00
|
|
|
| Some ty ->
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_desc = Texp_new (cl_path, cl, cl_decl);
|
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance_def ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1996-04-22 04:15:41 -07:00
|
|
|
end
|
|
|
|
| Pexp_setinstvar (lab, snewval) ->
|
|
|
|
begin try
|
2012-05-30 07:52:37 -07:00
|
|
|
let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in
|
1996-04-22 04:15:41 -07:00
|
|
|
match desc.val_kind with
|
1998-11-29 09:34:05 -08:00
|
|
|
Val_ivar (Mutable, cl_num) ->
|
2012-05-31 01:07:31 -07:00
|
|
|
let newval =
|
|
|
|
type_expect env snewval (instance env desc.val_type) in
|
1997-05-19 08:42:21 -07:00
|
|
|
let (path_self, _) =
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
|
1996-04-22 04:15:41 -07:00
|
|
|
in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_desc = Texp_setinstvar(path_self, path, lab, newval);
|
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance_def Predef.type_unit;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1997-05-19 08:42:21 -07:00
|
|
|
| Val_ivar _ ->
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt)))
|
1997-05-19 08:42:21 -07:00
|
|
|
| _ ->
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt)))
|
1996-04-22 04:15:41 -07:00
|
|
|
with
|
1997-05-19 08:42:21 -07:00
|
|
|
Not_found ->
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, env, Unbound_instance_variable lab.txt))
|
2005-08-13 13:59:37 -07:00
|
|
|
end
|
1996-04-22 04:15:41 -07:00
|
|
|
| Pexp_override lst ->
|
2005-08-13 13:59:37 -07:00
|
|
|
let _ =
|
1998-11-12 06:53:46 -08:00
|
|
|
List.fold_right
|
1997-05-19 08:42:21 -07:00
|
|
|
(fun (lab, _) l ->
|
2012-05-30 07:52:37 -07:00
|
|
|
if List.exists (fun l -> l.txt = lab.txt) l then
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env,
|
2012-05-30 07:52:37 -07:00
|
|
|
Value_multiply_overridden lab.txt));
|
1997-05-19 08:42:21 -07:00
|
|
|
lab::l)
|
|
|
|
lst
|
1998-11-12 06:53:46 -08:00
|
|
|
[] in
|
1998-06-24 12:22:26 -07:00
|
|
|
begin match
|
1997-05-19 08:42:21 -07:00
|
|
|
try
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.lookup_value (Longident.Lident "selfpat-*") env,
|
|
|
|
Env.lookup_value (Longident.Lident "self-*") env
|
1997-05-19 08:42:21 -07:00
|
|
|
with Not_found ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env, Outside_class))
|
1998-06-24 12:22:26 -07:00
|
|
|
with
|
2003-11-25 01:20:45 -08:00
|
|
|
(_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
|
1998-06-24 12:22:26 -07:00
|
|
|
(path_self, _) ->
|
|
|
|
let type_override (lab, snewval) =
|
|
|
|
begin try
|
2012-05-30 07:52:37 -07:00
|
|
|
let (id, _, _, ty) = Vars.find lab.txt !vars in
|
|
|
|
(Path.Pident id, lab, type_expect env snewval (instance env ty))
|
1998-06-24 12:22:26 -07:00
|
|
|
with
|
|
|
|
Not_found ->
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, env, Unbound_instance_variable lab.txt))
|
1998-06-24 12:22:26 -07:00
|
|
|
end
|
|
|
|
in
|
|
|
|
let modifs = List.map type_override lst in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2003-04-01 17:32:09 -08:00
|
|
|
exp_desc = Texp_override(path_self, modifs);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
1998-06-24 12:22:26 -07:00
|
|
|
exp_type = self_ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1998-06-24 12:22:26 -07:00
|
|
|
exp_env = env }
|
|
|
|
| _ ->
|
|
|
|
assert false
|
|
|
|
end
|
1998-02-26 04:54:44 -08:00
|
|
|
| Pexp_letmodule(name, smodl, sbody) ->
|
|
|
|
let ty = newvar() in
|
2010-11-11 19:09:11 -08:00
|
|
|
(* remember original level *)
|
|
|
|
begin_def ();
|
1998-11-11 08:58:05 -08:00
|
|
|
Ident.set_current_time ty.level;
|
2002-08-04 22:58:08 -07:00
|
|
|
let context = Typetexp.narrow () in
|
1998-02-26 04:54:44 -08:00
|
|
|
let modl = !type_module env smodl in
|
2012-05-30 07:52:37 -07:00
|
|
|
let (id, new_env) = Env.enter_module name.txt modl.mod_type env in
|
1998-06-24 12:22:26 -07:00
|
|
|
Ctype.init_def(Ident.current_time());
|
2002-08-04 22:58:08 -07:00
|
|
|
Typetexp.widen context;
|
2010-11-11 19:09:11 -08:00
|
|
|
let body = type_expect new_env sbody ty_expected in
|
|
|
|
(* go back to original level *)
|
|
|
|
end_def ();
|
1998-02-26 04:54:44 -08:00
|
|
|
(* Unification of body.exp_type with the fresh variable ty
|
|
|
|
fails if and only if the prefix condition is violated,
|
|
|
|
i.e. if generative types rooted at id show up in the
|
|
|
|
type body.exp_type. Thus, this unification enforces the
|
|
|
|
scoping condition on "let module". *)
|
|
|
|
begin try
|
2010-11-11 19:09:11 -08:00
|
|
|
Ctype.unify_var new_env ty body.exp_type
|
1998-02-26 04:54:44 -08:00
|
|
|
with Unify _ ->
|
2012-08-21 00:10:35 -07:00
|
|
|
raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type)))
|
1998-02-26 04:54:44 -08:00
|
|
|
end;
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_desc = Texp_letmodule(id, name, modl, body);
|
|
|
|
exp_loc = loc; exp_extra = [];
|
1998-02-26 04:54:44 -08:00
|
|
|
exp_type = ty;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
1998-02-26 04:54:44 -08:00
|
|
|
exp_env = env }
|
2000-12-04 07:37:05 -08:00
|
|
|
| Pexp_assert (e) ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let cond = type_expect env e Predef.type_bool in
|
2013-04-17 02:18:03 -07:00
|
|
|
let exp_type =
|
|
|
|
match cond.exp_desc with
|
2013-04-17 02:46:52 -07:00
|
|
|
| Texp_construct(_, {cstr_name="false"}, _) ->
|
2013-04-17 02:18:03 -07:00
|
|
|
instance env ty_expected
|
|
|
|
| _ ->
|
|
|
|
instance_def Predef.type_unit
|
|
|
|
in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2013-04-17 02:18:03 -07:00
|
|
|
exp_desc = Texp_assert cond;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2013-04-17 02:18:03 -07:00
|
|
|
exp_type;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env;
|
|
|
|
}
|
2008-07-09 06:03:38 -07:00
|
|
|
| Pexp_lazy e ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let ty = newgenvar () in
|
|
|
|
let to_unify = Predef.type_lazy_t ty in
|
|
|
|
unify_exp_types loc env to_unify ty_expected;
|
|
|
|
let arg = type_expect env e ty in
|
|
|
|
re {
|
|
|
|
exp_desc = Texp_lazy arg;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance env ty_expected;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env;
|
|
|
|
}
|
2003-11-25 01:20:45 -08:00
|
|
|
| Pexp_object s ->
|
2009-09-04 09:19:35 -07:00
|
|
|
let desc, sign, meths = !type_object env loc s in
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_desc = Texp_object (desc, (*sign,*) meths);
|
|
|
|
exp_loc = loc; exp_extra = [];
|
2013-09-27 08:04:03 -07:00
|
|
|
exp_type = sign.csig_self;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
2003-11-25 01:20:45 -08:00
|
|
|
exp_env = env;
|
|
|
|
}
|
2010-11-11 19:09:11 -08:00
|
|
|
| Pexp_poly(sbody, sty) ->
|
|
|
|
if !Clflags.principal then begin_def ();
|
2012-05-30 07:52:37 -07:00
|
|
|
let ty, cty =
|
|
|
|
match sty with None -> repr ty_expected, None
|
2010-11-11 19:09:11 -08:00
|
|
|
| Some sty ->
|
2013-04-09 07:10:54 -07:00
|
|
|
let sty = Ast_helper.Typ.force_poly sty in
|
2012-05-30 07:52:37 -07:00
|
|
|
let cty = Typetexp.transl_simple_type env false sty in
|
|
|
|
repr cty.ctyp_type, Some cty
|
2010-11-11 19:09:11 -08:00
|
|
|
in
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure ty
|
|
|
|
end;
|
|
|
|
if sty <> None then
|
2011-11-24 01:02:48 -08:00
|
|
|
unify_exp_types loc env (instance env ty) (instance env ty_expected);
|
2012-05-30 07:52:37 -07:00
|
|
|
let exp =
|
2010-11-11 19:09:11 -08:00
|
|
|
match (expand_head env ty).desc with
|
|
|
|
Tpoly (ty', []) ->
|
|
|
|
let exp = type_expect env sbody ty' in
|
2012-07-10 01:25:58 -07:00
|
|
|
{ exp with exp_type = instance env ty }
|
2010-11-11 19:09:11 -08:00
|
|
|
| Tpoly (ty', tl) ->
|
|
|
|
(* One more level to generalize locally *)
|
|
|
|
begin_def ();
|
|
|
|
if !Clflags.principal then begin_def ();
|
|
|
|
let vars, ty'' = instance_poly true tl ty' in
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure ty''
|
|
|
|
end;
|
|
|
|
let exp = type_expect env sbody ty'' in
|
|
|
|
end_def ();
|
|
|
|
check_univars env false "method" exp ty_expected vars;
|
2012-07-10 01:25:58 -07:00
|
|
|
{ exp with exp_type = instance env ty }
|
2011-09-22 02:05:42 -07:00
|
|
|
| Tvar _ ->
|
2010-12-13 22:33:06 -08:00
|
|
|
let exp = type_exp env sbody in
|
|
|
|
let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
|
|
|
|
unify_exp env exp ty;
|
2012-07-10 01:25:58 -07:00
|
|
|
exp
|
2010-11-11 19:09:11 -08:00
|
|
|
| _ -> assert false
|
2012-05-30 07:52:37 -07:00
|
|
|
in
|
2014-01-22 17:58:37 -08:00
|
|
|
re { exp with exp_extra =
|
|
|
|
(Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
|
2009-10-06 05:51:42 -07:00
|
|
|
| Pexp_newtype(name, sbody) ->
|
2012-06-13 01:38:32 -07:00
|
|
|
let ty = newvar () in
|
|
|
|
(* remember original level *)
|
|
|
|
begin_def ();
|
2009-10-06 05:51:42 -07:00
|
|
|
(* Create a fake abstract type declaration for name. *)
|
2011-11-24 01:02:48 -08:00
|
|
|
let level = get_current_level () in
|
2009-10-06 05:51:42 -07:00
|
|
|
let decl = {
|
|
|
|
type_params = [];
|
|
|
|
type_arity = 0;
|
|
|
|
type_kind = Type_abstract;
|
|
|
|
type_private = Public;
|
|
|
|
type_manifest = None;
|
|
|
|
type_variance = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
type_newtype_level = Some (level, level);
|
2010-05-21 08:06:01 -07:00
|
|
|
type_loc = loc;
|
2013-09-27 03:54:55 -07:00
|
|
|
type_attributes = [];
|
2009-10-06 05:51:42 -07:00
|
|
|
}
|
|
|
|
in
|
|
|
|
Ident.set_current_time ty.level;
|
|
|
|
let (id, new_env) = Env.enter_type name decl env in
|
|
|
|
Ctype.init_def(Ident.current_time());
|
|
|
|
|
|
|
|
let body = type_exp new_env sbody in
|
2010-11-11 19:09:11 -08:00
|
|
|
(* Replace every instance of this type constructor in the resulting
|
|
|
|
type. *)
|
2009-10-06 05:51:42 -07:00
|
|
|
let seen = Hashtbl.create 8 in
|
|
|
|
let rec replace t =
|
|
|
|
if Hashtbl.mem seen t.id then ()
|
|
|
|
else begin
|
|
|
|
Hashtbl.add seen t.id ();
|
|
|
|
match t.desc with
|
|
|
|
| Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
|
|
|
|
| _ -> Btype.iter_type_expr replace t
|
|
|
|
end
|
|
|
|
in
|
|
|
|
let ety = Subst.type_expr Subst.identity body.exp_type in
|
|
|
|
replace ety;
|
2010-11-11 19:09:11 -08:00
|
|
|
(* back to original level *)
|
|
|
|
end_def ();
|
|
|
|
(* lower the levels of the result type *)
|
|
|
|
(* unify_var env ty ety; *)
|
2009-10-06 05:51:42 -07:00
|
|
|
|
|
|
|
(* non-expansive if the body is non-expansive, so we don't introduce
|
|
|
|
any new extra node in the typed AST. *)
|
2012-07-10 01:25:58 -07:00
|
|
|
rue { body with exp_loc = loc; exp_type = ety;
|
2014-01-22 17:58:37 -08:00
|
|
|
exp_extra =
|
|
|
|
(Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
|
2010-10-21 16:59:33 -07:00
|
|
|
| Pexp_pack m ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let (p, nl, tl) =
|
2011-11-24 01:02:48 -08:00
|
|
|
match Ctype.expand_head env (instance env ty_expected) with
|
2010-11-11 19:09:11 -08:00
|
|
|
{desc = Tpackage (p, nl, tl)} ->
|
|
|
|
if !Clflags.principal &&
|
|
|
|
(Ctype.expand_head env ty_expected).level < Btype.generic_level
|
|
|
|
then
|
|
|
|
Location.prerr_warning loc
|
|
|
|
(Warnings.Not_principal "this module packing");
|
|
|
|
(p, nl, tl)
|
2011-09-22 02:05:42 -07:00
|
|
|
| {desc = Tvar _} ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error (loc, env, Cannot_infer_signature))
|
2010-11-11 19:09:11 -08:00
|
|
|
| _ ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error (loc, env, Not_a_packed_module ty_expected))
|
2010-11-11 19:09:11 -08:00
|
|
|
in
|
|
|
|
let (modl, tl') = !type_package env m p nl tl in
|
|
|
|
rue {
|
|
|
|
exp_desc = Texp_pack modl;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_type = newty (Tpackage (p, nl, tl'));
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = sexp.pexp_attributes;
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env }
|
2013-05-16 06:34:53 -07:00
|
|
|
| Pexp_open (ovf, lid, e) ->
|
|
|
|
let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in
|
2012-05-30 07:52:37 -07:00
|
|
|
let exp = type_expect newenv e ty_expected in
|
|
|
|
{ exp with
|
2013-07-16 06:34:30 -07:00
|
|
|
exp_extra = (Texp_open (ovf, path, lid, newenv), loc,
|
|
|
|
sexp.pexp_attributes) ::
|
2013-05-16 06:34:53 -07:00
|
|
|
exp.exp_extra;
|
2012-05-30 07:52:37 -07:00
|
|
|
}
|
2014-05-07 01:26:17 -07:00
|
|
|
| Pexp_extension ext ->
|
|
|
|
raise (Error_forward (Typetexp.error_of_extension ext))
|
1996-04-22 04:15:41 -07:00
|
|
|
|
2013-04-17 04:43:29 -07:00
|
|
|
and type_function ?in_function loc attrs env ty_expected l caselist =
|
|
|
|
let (loc_fun, ty_fun) =
|
|
|
|
match in_function with Some p -> p
|
|
|
|
| None -> (loc, instance env ty_expected)
|
|
|
|
in
|
|
|
|
let separate = !Clflags.principal || Env.has_local_constraints env in
|
|
|
|
if separate then begin_def ();
|
|
|
|
let (ty_arg, ty_res) =
|
|
|
|
try filter_arrow env (instance env ty_expected) l
|
|
|
|
with Unify _ ->
|
|
|
|
match expand_head env ty_expected with
|
|
|
|
{desc = Tarrow _} as ty ->
|
|
|
|
raise(Error(loc, env, Abstract_wrong_label(l, ty)))
|
|
|
|
| _ ->
|
|
|
|
raise(Error(loc_fun, env,
|
|
|
|
Too_many_arguments (in_function <> None, ty_fun)))
|
|
|
|
in
|
|
|
|
let ty_arg =
|
|
|
|
if is_optional l then
|
|
|
|
let tv = newvar() in
|
|
|
|
begin
|
|
|
|
try unify env ty_arg (type_option tv)
|
|
|
|
with Unify _ -> assert false
|
|
|
|
end;
|
|
|
|
type_option tv
|
|
|
|
else ty_arg
|
|
|
|
in
|
|
|
|
if separate then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure ty_arg;
|
|
|
|
generalize_structure ty_res
|
|
|
|
end;
|
|
|
|
let cases, partial =
|
|
|
|
type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
|
|
|
|
true loc caselist in
|
|
|
|
let not_function ty =
|
|
|
|
let ls, tvar = list_labels env ty in
|
|
|
|
ls = [] && not tvar
|
|
|
|
in
|
|
|
|
if is_optional l && not_function ty_res then
|
|
|
|
Location.prerr_warning (List.hd cases).c_lhs.pat_loc
|
|
|
|
Warnings.Unerasable_optional_argument;
|
|
|
|
re {
|
|
|
|
exp_desc = Texp_function(l,cases, partial);
|
|
|
|
exp_loc = loc; exp_extra = [];
|
|
|
|
exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
|
|
|
|
exp_attributes = attrs;
|
|
|
|
exp_env = env }
|
|
|
|
|
|
|
|
|
2012-09-21 00:01:44 -07:00
|
|
|
and type_label_access env loc srecord lid =
|
2012-10-29 00:54:06 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
|
|
|
let record = type_exp env srecord in
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure record.exp_type
|
|
|
|
end;
|
|
|
|
let ty_exp = record.exp_type in
|
2012-10-30 02:02:04 -07:00
|
|
|
let opath =
|
2012-10-29 00:54:06 -07:00
|
|
|
try
|
2012-11-10 19:46:59 -08:00
|
|
|
let (p0, p,_) = extract_concrete_record env ty_exp in
|
|
|
|
Some(p0, p, ty_exp.level = generic_level || not !Clflags.principal)
|
2012-10-29 00:54:06 -07:00
|
|
|
with Not_found -> None
|
|
|
|
in
|
|
|
|
let labels = Typetexp.find_all_labels env lid.loc lid.txt in
|
2013-09-19 00:25:51 -07:00
|
|
|
let label =
|
|
|
|
wrap_disambiguate "This expression has" ty_exp
|
|
|
|
(Label.disambiguate lid env opath) labels in
|
2012-11-08 01:39:23 -08:00
|
|
|
(record, label, opath)
|
2012-09-21 00:01:44 -07:00
|
|
|
|
2013-09-04 08:12:37 -07:00
|
|
|
and type_label_exp create env loc ty_expected
|
2012-10-24 05:03:00 -07:00
|
|
|
(lid, label, sarg) =
|
2010-11-11 19:09:11 -08:00
|
|
|
(* Here also ty_expected may be at generic_level *)
|
2010-08-02 07:37:22 -07:00
|
|
|
begin_def ();
|
2011-11-24 01:02:48 -08:00
|
|
|
let separate = !Clflags.principal || Env.has_local_constraints env in
|
|
|
|
if separate then (begin_def (); begin_def ());
|
2010-08-02 07:37:22 -07:00
|
|
|
let (vars, ty_arg, ty_res) = instance_label true label in
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin
|
2010-08-02 07:37:22 -07:00
|
|
|
end_def ();
|
2010-11-11 19:09:11 -08:00
|
|
|
(* Generalize label information *)
|
2010-08-02 07:37:22 -07:00
|
|
|
generalize_structure ty_arg;
|
|
|
|
generalize_structure ty_res
|
|
|
|
end;
|
|
|
|
begin try
|
2011-11-24 01:02:48 -08:00
|
|
|
unify env (instance_def ty_res) (instance env ty_expected)
|
2010-08-02 07:37:22 -07:00
|
|
|
with Unify trace ->
|
2013-01-29 06:21:12 -08:00
|
|
|
raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace)))
|
2010-08-02 07:37:22 -07:00
|
|
|
end;
|
2010-11-11 19:09:11 -08:00
|
|
|
(* Instantiate so that we can generalize internal nodes *)
|
2011-11-24 01:02:48 -08:00
|
|
|
let ty_arg = instance_def ty_arg in
|
|
|
|
if separate then begin
|
2010-11-11 19:09:11 -08:00
|
|
|
end_def ();
|
|
|
|
(* Generalize information merged from ty_expected *)
|
|
|
|
generalize_structure ty_arg
|
2010-08-02 07:37:22 -07:00
|
|
|
end;
|
|
|
|
if label.lbl_private = Private then
|
2012-06-13 16:45:01 -07:00
|
|
|
if create then
|
2012-08-21 00:10:35 -07:00
|
|
|
raise (Error(loc, env, Private_type ty_expected))
|
2012-06-13 16:45:01 -07:00
|
|
|
else
|
2013-01-29 06:21:12 -08:00
|
|
|
raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
|
2010-08-02 07:37:22 -07:00
|
|
|
let arg =
|
|
|
|
let snap = if vars = [] then None else Some (Btype.snapshot ()) in
|
2011-11-24 01:02:48 -08:00
|
|
|
let arg = type_argument env sarg ty_arg (instance env ty_arg) in
|
2010-08-02 07:37:22 -07:00
|
|
|
end_def ();
|
|
|
|
try
|
|
|
|
check_univars env (vars <> []) "field value" arg label.lbl_arg vars;
|
|
|
|
arg
|
|
|
|
with exn when not (is_nonexpansive arg) -> try
|
|
|
|
(* Try to retype without propagating ty_arg, cf PR#4862 *)
|
|
|
|
may Btype.backtrack snap;
|
|
|
|
begin_def ();
|
|
|
|
let arg = type_exp env sarg in
|
|
|
|
end_def ();
|
|
|
|
generalize_expansive env arg.exp_type;
|
|
|
|
unify_exp env arg ty_arg;
|
|
|
|
check_univars env false "field value" arg label.lbl_arg vars;
|
|
|
|
arg
|
2012-01-21 19:15:14 -08:00
|
|
|
with Error (_, _, Less_general _) as e -> raise e
|
2010-08-02 07:37:22 -07:00
|
|
|
| _ -> raise exn (* In case of failure return the first error *)
|
|
|
|
in
|
2012-10-24 05:03:00 -07:00
|
|
|
(lid, label, {arg with exp_type = instance env arg.exp_type})
|
2010-08-02 07:37:22 -07:00
|
|
|
|
2011-02-23 22:29:26 -08:00
|
|
|
and type_argument env sarg ty_expected' ty_expected =
|
2002-04-18 00:27:47 -07:00
|
|
|
(* ty_expected' may be generic *)
|
2001-12-05 16:19:35 -08:00
|
|
|
let no_labels ty =
|
|
|
|
let ls, tvar = list_labels env ty in
|
|
|
|
not tvar && List.for_all ((=) "") ls
|
2000-04-04 03:03:53 -07:00
|
|
|
in
|
2012-03-24 23:41:42 -07:00
|
|
|
let rec is_inferred sexp =
|
|
|
|
match sexp.pexp_desc with
|
2014-04-02 20:59:17 -07:00
|
|
|
Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _
|
|
|
|
| Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true
|
|
|
|
| Pexp_sequence (_, e) | Pexp_open (_, _, e) -> is_inferred e
|
|
|
|
| Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2
|
2012-03-24 23:41:42 -07:00
|
|
|
| _ -> false
|
|
|
|
in
|
|
|
|
match expand_head env ty_expected' with
|
|
|
|
{desc = Tarrow("",ty_arg,ty_res,_); level = lv} when is_inferred sarg ->
|
1999-11-30 08:07:38 -08:00
|
|
|
(* apply optional arguments when expected type is "" *)
|
2000-04-04 03:03:53 -07:00
|
|
|
(* we must be very careful about not breaking the semantics *)
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
1999-11-30 08:07:38 -08:00
|
|
|
let texp = type_exp env sarg in
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure texp.exp_type
|
|
|
|
end;
|
1999-11-30 08:07:38 -08:00
|
|
|
let rec make_args args ty_fun =
|
|
|
|
match (expand_head env ty_fun).desc with
|
2001-04-19 01:34:21 -07:00
|
|
|
| Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
|
2012-09-11 04:33:56 -07:00
|
|
|
let ty = option_none (instance env ty_arg) sarg.pexp_loc in
|
|
|
|
make_args ((l, Some ty, Optional) :: args) ty_fun
|
2001-04-19 01:34:21 -07:00
|
|
|
| Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
|
2014-03-26 11:09:28 -07:00
|
|
|
List.rev args, ty_fun, no_labels ty_res'
|
|
|
|
| Tvar _ -> List.rev args, ty_fun, false
|
2001-04-19 01:34:21 -07:00
|
|
|
| _ -> [], texp.exp_type, false
|
1999-11-30 08:07:38 -08:00
|
|
|
in
|
2002-04-18 00:27:47 -07:00
|
|
|
let args, ty_fun', simple_res = make_args [] texp.exp_type in
|
|
|
|
let warn = !Clflags.principal &&
|
|
|
|
(lv <> generic_level || (repr ty_fun').level <> generic_level)
|
2011-11-24 01:02:48 -08:00
|
|
|
and texp = {texp with exp_type = instance env texp.exp_type}
|
|
|
|
and ty_fun = instance env ty_fun' in
|
2001-12-05 16:19:35 -08:00
|
|
|
if not (simple_res || no_labels ty_res) then begin
|
2001-10-21 19:39:25 -07:00
|
|
|
unify_exp env texp ty_expected;
|
|
|
|
texp
|
|
|
|
end else begin
|
1999-11-30 08:07:38 -08:00
|
|
|
unify_exp env {texp with exp_type = ty_fun} ty_expected;
|
|
|
|
if args = [] then texp else
|
|
|
|
(* eta-expand to avoid side effects *)
|
|
|
|
let var_pair name ty =
|
|
|
|
let id = Ident.create name in
|
2012-05-30 07:52:37 -07:00
|
|
|
{pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
|
2013-03-25 07:16:07 -07:00
|
|
|
pat_attributes = [];
|
1999-11-30 08:07:38 -08:00
|
|
|
pat_loc = Location.none; pat_env = env},
|
2012-05-30 07:52:37 -07:00
|
|
|
{exp_type = ty; exp_loc = Location.none; exp_env = env;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_extra = []; exp_attributes = [];
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_desc =
|
|
|
|
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
|
|
|
|
{val_type = ty; val_kind = Val_reg;
|
2013-09-26 08:24:11 -07:00
|
|
|
val_attributes = [];
|
2012-05-30 07:52:37 -07:00
|
|
|
Types.val_loc = Location.none})}
|
1999-11-30 08:07:38 -08:00
|
|
|
in
|
|
|
|
let eta_pat, eta_var = var_pair "eta" ty_arg in
|
|
|
|
let func texp =
|
2013-04-15 09:23:22 -07:00
|
|
|
let e =
|
|
|
|
{texp with exp_type = ty_res; exp_desc =
|
|
|
|
Texp_apply
|
|
|
|
(texp,
|
2014-03-26 11:09:28 -07:00
|
|
|
args @ ["", Some eta_var, Required])}
|
2013-04-15 09:23:22 -07:00
|
|
|
in
|
1999-11-30 08:07:38 -08:00
|
|
|
{ texp with exp_type = ty_fun; exp_desc =
|
2013-04-15 09:23:22 -07:00
|
|
|
Texp_function("", [case eta_pat e], Total) }
|
|
|
|
in
|
2014-03-26 11:09:28 -07:00
|
|
|
Location.prerr_warning texp.exp_loc
|
|
|
|
(Warnings.Eliminated_optional_arguments (List.map (fun (l, _, _) -> l) args));
|
2002-04-18 00:27:47 -07:00
|
|
|
if warn then Location.prerr_warning texp.exp_loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Without_principality "eliminated optional argument");
|
1999-11-30 08:07:38 -08:00
|
|
|
if is_nonexpansive texp then func texp else
|
|
|
|
(* let-expand to have side effects *)
|
2013-07-24 01:11:20 -07:00
|
|
|
let let_pat, let_var = var_pair "arg" texp.exp_type in
|
2003-04-01 17:32:09 -08:00
|
|
|
re { texp with exp_type = ty_fun; exp_desc =
|
2014-01-22 17:58:37 -08:00
|
|
|
Texp_let (Nonrecursive,
|
2014-04-22 08:28:20 -07:00
|
|
|
[{vb_pat=let_pat; vb_expr=texp; vb_attributes=[];
|
|
|
|
vb_loc=Location.none;
|
|
|
|
}],
|
2014-01-22 17:58:37 -08:00
|
|
|
func let_var) }
|
2001-04-19 01:34:21 -07:00
|
|
|
end
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ ->
|
2011-02-23 22:29:26 -08:00
|
|
|
let texp = type_expect env sarg ty_expected' in
|
|
|
|
unify_exp env texp ty_expected;
|
|
|
|
texp
|
1999-11-30 08:07:38 -08:00
|
|
|
|
|
|
|
and type_application env funct sargs =
|
2002-04-18 00:27:47 -07:00
|
|
|
(* funct.exp_type may be generic *)
|
1999-11-30 08:07:38 -08:00
|
|
|
let result_type omitted ty_fun =
|
|
|
|
List.fold_left
|
2001-04-19 01:34:21 -07:00
|
|
|
(fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
|
1999-11-30 08:07:38 -08:00
|
|
|
ty_fun omitted
|
|
|
|
in
|
2001-12-05 16:19:35 -08:00
|
|
|
let has_label l ty_fun =
|
|
|
|
let ls, tvar = list_labels env ty_fun in
|
|
|
|
tvar || List.mem l ls
|
2001-04-19 01:34:21 -07:00
|
|
|
in
|
2000-02-22 06:40:54 -08:00
|
|
|
let ignored = ref [] in
|
2012-05-30 07:52:37 -07:00
|
|
|
let rec type_unknown_args
|
|
|
|
(args :
|
|
|
|
(Asttypes.label * (unit -> Typedtree.expression) option *
|
|
|
|
Typedtree.optional) list)
|
|
|
|
omitted ty_fun = function
|
1999-11-30 08:07:38 -08:00
|
|
|
[] ->
|
2001-11-16 01:07:09 -08:00
|
|
|
(List.map
|
2012-05-30 07:52:37 -07:00
|
|
|
(function l, None, x -> l, None, x
|
|
|
|
| l, Some f, x -> l, Some (f ()), x)
|
2001-11-16 01:07:09 -08:00
|
|
|
(List.rev args),
|
2011-11-24 01:02:48 -08:00
|
|
|
instance env (result_type omitted ty_fun))
|
1999-11-30 08:07:38 -08:00
|
|
|
| (l1, sarg1) :: sargl ->
|
|
|
|
let (ty1, ty2) =
|
2004-11-28 18:27:25 -08:00
|
|
|
let ty_fun = expand_head env ty_fun in
|
|
|
|
match ty_fun.desc with
|
2011-09-22 02:05:42 -07:00
|
|
|
Tvar _ ->
|
2001-04-19 01:34:21 -07:00
|
|
|
let t1 = newvar () and t2 = newvar () in
|
2004-11-28 18:27:25 -08:00
|
|
|
let not_identity = function
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_ident(_,_,{val_kind=Val_prim
|
2004-11-28 18:27:25 -08:00
|
|
|
{Primitive.prim_name="%identity"}}) ->
|
|
|
|
false
|
|
|
|
| _ -> true
|
|
|
|
in
|
|
|
|
if ty_fun.level >= t1.level && not_identity funct.exp_desc then
|
2004-11-30 10:57:04 -08:00
|
|
|
Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
|
2001-04-19 01:34:21 -07:00
|
|
|
unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
|
|
|
|
(t1, t2)
|
|
|
|
| Tarrow (l,t1,t2,_) when l = l1
|
|
|
|
|| !Clflags.classic && l1 = "" && not (is_optional l) ->
|
|
|
|
(t1, t2)
|
|
|
|
| td ->
|
|
|
|
let ty_fun =
|
|
|
|
match td with Tarrow _ -> newty td | _ -> ty_fun in
|
|
|
|
let ty_res = result_type (omitted @ !ignored) ty_fun in
|
|
|
|
match ty_res.desc with
|
|
|
|
Tarrow _ ->
|
|
|
|
if (!Clflags.classic || not (has_label l1 ty_fun)) then
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error(sarg1.pexp_loc, env,
|
|
|
|
Apply_wrong_label(l1, ty_res)))
|
2001-04-19 01:34:21 -07:00
|
|
|
else
|
2012-01-21 19:15:14 -08:00
|
|
|
raise (Error(funct.exp_loc, env, Incoherent_label_order))
|
2001-04-19 01:34:21 -07:00
|
|
|
| _ ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(funct.exp_loc, env, Apply_non_function
|
2002-05-12 23:56:08 -07:00
|
|
|
(expand_head env funct.exp_type)))
|
2001-04-19 01:34:21 -07:00
|
|
|
in
|
2000-09-04 01:49:32 -07:00
|
|
|
let optional = if is_optional l1 then Optional else Required in
|
2000-03-15 19:30:59 -08:00
|
|
|
let arg1 () =
|
|
|
|
let arg1 = type_expect env sarg1 ty1 in
|
2000-09-04 01:49:32 -07:00
|
|
|
if optional = Optional then
|
|
|
|
unify_exp env arg1 (type_option(newvar()));
|
2000-03-15 19:30:59 -08:00
|
|
|
arg1
|
|
|
|
in
|
2012-05-30 07:52:37 -07:00
|
|
|
type_unknown_args ((l1, Some arg1, optional) :: args) omitted ty2 sargl
|
1999-11-30 08:07:38 -08:00
|
|
|
in
|
2001-09-06 01:52:32 -07:00
|
|
|
let ignore_labels =
|
|
|
|
!Clflags.classic ||
|
2001-12-05 16:19:35 -08:00
|
|
|
begin
|
|
|
|
let ls, tvar = list_labels env funct.exp_type in
|
|
|
|
not tvar &&
|
|
|
|
let labels = List.filter (fun l -> not (is_optional l)) ls in
|
|
|
|
List.length labels = List.length sargs &&
|
|
|
|
List.for_all (fun (l,_) -> l = "") sargs &&
|
|
|
|
List.exists (fun l -> l <> "") labels &&
|
|
|
|
(Location.prerr_warning funct.exp_loc Warnings.Labels_omitted;
|
|
|
|
true)
|
|
|
|
end
|
2001-09-06 01:52:32 -07:00
|
|
|
in
|
2002-04-18 00:27:47 -07:00
|
|
|
let warned = ref false in
|
2011-02-23 22:29:26 -08:00
|
|
|
let rec type_args args omitted ty_fun ty_fun0 ty_old sargs more_sargs =
|
|
|
|
match expand_head env ty_fun, expand_head env ty_fun0 with
|
|
|
|
{desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
|
|
|
|
{desc=Tarrow (_, ty0, ty_fun0, _)}
|
2001-04-19 01:34:21 -07:00
|
|
|
when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
|
2004-11-30 10:57:04 -08:00
|
|
|
let may_warn loc w =
|
2002-04-18 00:27:47 -07:00
|
|
|
if not !warned && !Clflags.principal && lv <> generic_level
|
|
|
|
then begin
|
|
|
|
warned := true;
|
2004-11-30 10:57:04 -08:00
|
|
|
Location.prerr_warning loc w
|
2002-04-18 00:27:47 -07:00
|
|
|
end
|
|
|
|
in
|
2000-09-04 01:49:32 -07:00
|
|
|
let name = label_name l
|
|
|
|
and optional = if is_optional l then Optional else Required in
|
1999-11-30 08:07:38 -08:00
|
|
|
let sargs, more_sargs, arg =
|
2001-09-06 01:52:32 -07:00
|
|
|
if ignore_labels && not (is_optional l) then begin
|
1999-11-30 08:07:38 -08:00
|
|
|
(* In classic mode, omitted = [] *)
|
|
|
|
match sargs, more_sargs with
|
|
|
|
(l', sarg0) :: _, _ ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(sarg0.pexp_loc, env,
|
|
|
|
Apply_wrong_label(l', ty_old)))
|
1999-11-30 08:07:38 -08:00
|
|
|
| _, (l', sarg0) :: more_sargs ->
|
|
|
|
if l <> l' && l' <> "" then
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(sarg0.pexp_loc, env,
|
|
|
|
Apply_wrong_label(l', ty_fun')))
|
2000-03-15 19:30:59 -08:00
|
|
|
else
|
2011-02-23 22:29:26 -08:00
|
|
|
([], more_sargs,
|
|
|
|
Some (fun () -> type_argument env sarg0 ty ty0))
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ ->
|
|
|
|
assert false
|
|
|
|
end else try
|
|
|
|
let (l', sarg0, sargs, more_sargs) =
|
|
|
|
try
|
2002-04-18 00:27:47 -07:00
|
|
|
let (l', sarg0, sargs1, sargs2) = extract_label name sargs in
|
|
|
|
if sargs1 <> [] then
|
|
|
|
may_warn sarg0.pexp_loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Not_principal "commuting this argument");
|
2002-04-18 00:27:47 -07:00
|
|
|
(l', sarg0, sargs1 @ sargs2, more_sargs)
|
1999-11-30 08:07:38 -08:00
|
|
|
with Not_found ->
|
2002-04-18 00:27:47 -07:00
|
|
|
let (l', sarg0, sargs1, sargs2) =
|
|
|
|
extract_label name more_sargs in
|
|
|
|
if sargs1 <> [] || sargs <> [] then
|
|
|
|
may_warn sarg0.pexp_loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Not_principal "commuting this argument");
|
2002-04-18 00:27:47 -07:00
|
|
|
(l', sarg0, sargs @ sargs1, sargs2)
|
1999-11-30 08:07:38 -08:00
|
|
|
in
|
2012-12-26 19:15:09 -08:00
|
|
|
if optional = Required && is_optional l' then
|
2013-02-18 19:12:36 -08:00
|
|
|
Location.prerr_warning sarg0.pexp_loc
|
|
|
|
(Warnings.Nonoptional_label l);
|
|
|
|
sargs, more_sargs,
|
|
|
|
if optional = Required || is_optional l' then
|
2011-02-23 22:29:26 -08:00
|
|
|
Some (fun () -> type_argument env sarg0 ty ty0)
|
2002-04-18 00:27:47 -07:00
|
|
|
else begin
|
|
|
|
may_warn sarg0.pexp_loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Not_principal "using an optional argument here");
|
2006-04-16 16:28:22 -07:00
|
|
|
Some (fun () -> option_some (type_argument env sarg0
|
2011-02-23 22:29:26 -08:00
|
|
|
(extract_option_type env ty)
|
|
|
|
(extract_option_type env ty0)))
|
2002-04-18 00:27:47 -07:00
|
|
|
end
|
1999-11-30 08:07:38 -08:00
|
|
|
with Not_found ->
|
|
|
|
sargs, more_sargs,
|
2000-09-04 01:49:32 -07:00
|
|
|
if optional = Optional &&
|
1999-11-30 08:07:38 -08:00
|
|
|
(List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
|
2000-02-22 06:40:54 -08:00
|
|
|
then begin
|
2002-04-18 00:27:47 -07:00
|
|
|
may_warn funct.exp_loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Without_principality "eliminated optional argument");
|
2000-03-14 23:55:24 -08:00
|
|
|
ignored := (l,ty,lv) :: !ignored;
|
2011-11-24 01:02:48 -08:00
|
|
|
Some (fun () -> option_none (instance env ty) Location.none)
|
2002-04-18 00:27:47 -07:00
|
|
|
end else begin
|
|
|
|
may_warn funct.exp_loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Without_principality "commuted an argument");
|
2002-04-18 00:27:47 -07:00
|
|
|
None
|
|
|
|
end
|
1999-11-30 08:07:38 -08:00
|
|
|
in
|
2002-04-18 00:27:47 -07:00
|
|
|
let omitted =
|
|
|
|
if arg = None then (l,ty,lv) :: omitted else omitted in
|
1999-11-30 08:07:38 -08:00
|
|
|
let ty_old = if sargs = [] then ty_fun else ty_old in
|
2012-05-30 07:52:37 -07:00
|
|
|
type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0
|
2011-02-23 22:29:26 -08:00
|
|
|
ty_old sargs more_sargs
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ ->
|
|
|
|
match sargs with
|
2001-09-06 01:52:32 -07:00
|
|
|
(l, sarg0) :: _ when ignore_labels ->
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(sarg0.pexp_loc, env,
|
|
|
|
Apply_wrong_label(l, ty_old)))
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ ->
|
2011-02-23 22:29:26 -08:00
|
|
|
type_unknown_args args omitted ty_fun0
|
2002-04-18 00:27:47 -07:00
|
|
|
(sargs @ more_sargs)
|
1999-11-30 08:07:38 -08:00
|
|
|
in
|
|
|
|
match funct.exp_desc, sargs with
|
|
|
|
(* Special case for ignore: avoid discarding warning *)
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}),
|
1999-11-30 08:07:38 -08:00
|
|
|
["", sarg] ->
|
2011-11-24 01:02:48 -08:00
|
|
|
let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) "" in
|
1999-11-30 08:07:38 -08:00
|
|
|
let exp = type_expect env sarg ty_arg in
|
2002-05-16 03:18:51 -07:00
|
|
|
begin match (expand_head env exp.exp_type).desc with
|
|
|
|
| Tarrow _ ->
|
2000-03-06 14:12:09 -08:00
|
|
|
Location.prerr_warning exp.exp_loc Warnings.Partial_application
|
2011-09-22 02:05:42 -07:00
|
|
|
| Tvar _ ->
|
2006-01-05 18:25:38 -08:00
|
|
|
add_delayed_check (fun () -> check_application_result env false exp)
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ -> ()
|
|
|
|
end;
|
2012-05-30 07:52:37 -07:00
|
|
|
(["", Some exp, Required], ty_res)
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ ->
|
|
|
|
let ty = funct.exp_type in
|
2001-09-06 01:52:32 -07:00
|
|
|
if ignore_labels then
|
2011-11-24 01:02:48 -08:00
|
|
|
type_args [] [] ty (instance env ty) ty [] sargs
|
1999-11-30 08:07:38 -08:00
|
|
|
else
|
2011-11-24 01:02:48 -08:00
|
|
|
type_args [] [] ty (instance env ty) ty sargs []
|
1999-11-30 08:07:38 -08:00
|
|
|
|
2013-04-17 02:46:52 -07:00
|
|
|
and type_construct env loc lid sarg ty_expected attrs =
|
2012-10-30 02:02:04 -07:00
|
|
|
let opath =
|
2012-10-29 00:54:06 -07:00
|
|
|
try
|
2012-11-10 19:46:59 -08:00
|
|
|
let (p0, p,_) = extract_concrete_variant env ty_expected in
|
|
|
|
Some(p0, p, ty_expected.level = generic_level || not !Clflags.principal)
|
2012-10-29 00:54:06 -07:00
|
|
|
with Not_found -> None
|
|
|
|
in
|
|
|
|
let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in
|
2013-09-19 00:25:51 -07:00
|
|
|
let constr =
|
|
|
|
wrap_disambiguate "This variant expression is expected to have" ty_expected
|
|
|
|
(Constructor.disambiguate lid env opath) constrs in
|
2012-05-31 01:07:31 -07:00
|
|
|
Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
|
2013-09-27 08:04:03 -07:00
|
|
|
Typetexp.check_deprecated loc constr.cstr_attributes constr.cstr_name;
|
1999-11-30 08:07:38 -08:00
|
|
|
let sargs =
|
|
|
|
match sarg with
|
|
|
|
None -> []
|
2014-04-15 02:53:51 -07:00
|
|
|
| Some {pexp_desc = Pexp_tuple sel} when
|
|
|
|
constr.cstr_arity > 1 || explicit_arity attrs
|
|
|
|
-> sel
|
1999-11-30 08:07:38 -08:00
|
|
|
| Some se -> [se] in
|
|
|
|
if List.length sargs <> constr.cstr_arity then
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env, Constructor_arity_mismatch
|
2012-05-30 07:52:37 -07:00
|
|
|
(lid.txt, constr.cstr_arity, List.length sargs)));
|
2011-11-24 01:02:48 -08:00
|
|
|
let separate = !Clflags.principal || Env.has_local_constraints env in
|
|
|
|
if separate then (begin_def (); begin_def ());
|
1999-11-30 08:07:38 -08:00
|
|
|
let (ty_args, ty_res) = instance_constructor constr in
|
|
|
|
let texp =
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
2013-04-17 02:46:52 -07:00
|
|
|
exp_desc = Texp_construct(lid, constr, []);
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2010-10-21 16:59:33 -07:00
|
|
|
exp_type = ty_res;
|
2013-03-25 07:16:07 -07:00
|
|
|
exp_attributes = attrs;
|
1999-11-30 08:07:38 -08:00
|
|
|
exp_env = env } in
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin
|
2010-10-21 16:59:33 -07:00
|
|
|
end_def ();
|
|
|
|
generalize_structure ty_res;
|
2011-11-24 01:02:48 -08:00
|
|
|
unify_exp env {texp with exp_type = instance_def ty_res}
|
|
|
|
(instance env ty_expected);
|
2010-10-21 16:59:33 -07:00
|
|
|
end_def ();
|
|
|
|
List.iter generalize_structure ty_args;
|
|
|
|
generalize_structure ty_res;
|
|
|
|
end;
|
2011-02-23 22:29:26 -08:00
|
|
|
let ty_args0, ty_res =
|
2011-11-24 01:02:48 -08:00
|
|
|
match instance_list env (ty_res :: ty_args) with
|
2011-02-23 22:29:26 -08:00
|
|
|
t :: tl -> tl, t
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
2011-11-24 01:02:48 -08:00
|
|
|
let texp = {texp with exp_type = ty_res} in
|
|
|
|
if not separate then unify_exp env texp (instance env ty_expected);
|
2011-02-23 22:29:26 -08:00
|
|
|
let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs
|
|
|
|
(List.combine ty_args ty_args0) in
|
2003-07-02 02:14:35 -07:00
|
|
|
if constr.cstr_private = Private then
|
2012-01-21 19:15:14 -08:00
|
|
|
raise(Error(loc, env, Private_type ty_res));
|
2013-04-17 02:46:52 -07:00
|
|
|
(* NOTE: shouldn't we call "re" on this final expression? -- AF *)
|
2012-05-31 01:07:31 -07:00
|
|
|
{ texp with
|
2013-04-17 02:46:52 -07:00
|
|
|
exp_desc = Texp_construct(lid, constr, args) }
|
1999-11-30 08:07:38 -08:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Typing of statements (expressions whose values are discarded) *)
|
|
|
|
|
|
|
|
and type_statement env sexp =
|
2012-07-24 01:57:52 -07:00
|
|
|
let loc = (final_subexpression sexp).pexp_loc in
|
2004-11-28 18:27:25 -08:00
|
|
|
begin_def();
|
|
|
|
let exp = type_exp env sexp in
|
|
|
|
end_def();
|
2009-12-09 01:17:12 -08:00
|
|
|
if !Clflags.strict_sequence then
|
2011-11-24 01:02:48 -08:00
|
|
|
let expected_ty = instance_def Predef.type_unit in
|
2009-12-09 01:32:39 -08:00
|
|
|
unify_exp env exp expected_ty;
|
2009-12-09 01:17:12 -08:00
|
|
|
exp else
|
2004-11-28 18:27:25 -08:00
|
|
|
let ty = expand_head env exp.exp_type and tv = newvar() in
|
|
|
|
begin match ty.desc with
|
|
|
|
| Tarrow _ ->
|
2009-09-04 09:19:35 -07:00
|
|
|
Location.prerr_warning loc Warnings.Partial_application
|
2004-11-28 18:27:25 -08:00
|
|
|
| Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
|
2011-09-22 02:05:42 -07:00
|
|
|
| Tvar _ when ty.level > tv.level ->
|
2009-09-04 09:19:35 -07:00
|
|
|
Location.prerr_warning loc Warnings.Nonreturning_statement
|
2011-09-22 02:05:42 -07:00
|
|
|
| Tvar _ ->
|
2006-01-05 18:25:38 -08:00
|
|
|
add_delayed_check (fun () -> check_application_result env true exp)
|
2004-11-28 18:27:25 -08:00
|
|
|
| _ ->
|
2009-09-04 09:19:35 -07:00
|
|
|
Location.prerr_warning loc Warnings.Statement_type
|
2004-11-28 18:27:25 -08:00
|
|
|
end;
|
|
|
|
unify_var env tv ty;
|
|
|
|
exp
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
(* Typing of match cases *)
|
|
|
|
|
2014-01-22 17:58:37 -08:00
|
|
|
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
|
2011-11-24 01:02:48 -08:00
|
|
|
(* ty_arg is _fully_ generalized *)
|
2013-04-15 09:23:22 -07:00
|
|
|
let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
|
2013-01-10 23:26:23 -08:00
|
|
|
let erase_either =
|
|
|
|
List.exists contains_polymorphic_variant patterns
|
|
|
|
&& contains_variant_either ty_arg
|
|
|
|
and has_gadts = List.exists (contains_gadt env) patterns in
|
2012-05-30 07:52:37 -07:00
|
|
|
(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
|
2013-01-10 23:26:23 -08:00
|
|
|
let ty_arg =
|
|
|
|
if (has_gadts || erase_either) && not !Clflags.principal
|
|
|
|
then correct_levels ty_arg else ty_arg
|
|
|
|
and ty_res, env =
|
2011-11-24 01:02:48 -08:00
|
|
|
if has_gadts && not !Clflags.principal then
|
2013-01-10 23:26:23 -08:00
|
|
|
correct_levels ty_res, duplicate_ident_types loc caselist env
|
|
|
|
else ty_res, env
|
|
|
|
in
|
2011-11-24 01:02:48 -08:00
|
|
|
let lev, env =
|
|
|
|
if has_gadts then begin
|
|
|
|
(* raise level for existentials *)
|
|
|
|
begin_def ();
|
2012-05-30 07:52:37 -07:00
|
|
|
Ident.set_current_time (get_current_level ());
|
2011-11-24 01:02:48 -08:00
|
|
|
let lev = Ident.current_time () in
|
|
|
|
Ctype.init_def (lev+1000); (* up to 1000 existentials *)
|
|
|
|
(lev, Env.add_gadt_instance_level lev env)
|
|
|
|
end else (get_current_level (), env)
|
|
|
|
in
|
2012-05-30 07:52:37 -07:00
|
|
|
(* if has_gadts then
|
|
|
|
Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *)
|
2011-11-24 01:02:48 -08:00
|
|
|
begin_def (); (* propagation of the argument *)
|
2000-05-12 11:22:35 -07:00
|
|
|
let ty_arg' = newvar () in
|
2002-06-03 00:33:48 -07:00
|
|
|
let pattern_force = ref [] in
|
2012-05-30 07:52:37 -07:00
|
|
|
(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
|
2010-12-12 18:59:58 -08:00
|
|
|
Printtyp.raw_type_expr ty_arg; *)
|
2000-05-12 11:22:35 -07:00
|
|
|
let pat_env_list =
|
|
|
|
List.map
|
2013-04-15 09:23:22 -07:00
|
|
|
(fun {pc_lhs; pc_guard; pc_rhs} ->
|
|
|
|
let loc =
|
|
|
|
let open Location in
|
|
|
|
match pc_guard with
|
|
|
|
| None -> pc_rhs.pexp_loc
|
|
|
|
| Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start}
|
|
|
|
in
|
2010-10-21 16:59:33 -07:00
|
|
|
if !Clflags.principal then begin_def (); (* propagation of pattern *)
|
2009-09-04 09:19:35 -07:00
|
|
|
let scope = Some (Annot.Idef loc) in
|
2011-10-25 05:11:06 -07:00
|
|
|
let (pat, ext_env, force, unpacks) =
|
2011-04-18 19:13:52 -07:00
|
|
|
let partial =
|
2013-01-10 23:26:23 -08:00
|
|
|
if !Clflags.principal || erase_either
|
|
|
|
then Some false else None in
|
|
|
|
let ty_arg = instance ?partial env ty_arg in
|
2013-04-15 09:23:22 -07:00
|
|
|
type_pattern ~lev env pc_lhs scope ty_arg
|
2011-10-25 05:11:06 -07:00
|
|
|
in
|
2002-06-03 00:33:48 -07:00
|
|
|
pattern_force := force @ !pattern_force;
|
2002-04-18 00:27:47 -07:00
|
|
|
let pat =
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
|
2011-11-24 01:02:48 -08:00
|
|
|
{ pat with pat_type = instance env pat.pat_type }
|
2002-04-18 00:27:47 -07:00
|
|
|
end else pat
|
|
|
|
in
|
2010-10-21 16:59:33 -07:00
|
|
|
(pat, (ext_env, unpacks)))
|
2000-05-12 11:22:35 -07:00
|
|
|
caselist in
|
2013-11-12 16:16:03 -08:00
|
|
|
(* Unify cases (delayed to keep it order-free) *)
|
2003-08-18 01:26:18 -07:00
|
|
|
let patl = List.map fst pat_env_list in
|
2013-11-12 16:16:03 -08:00
|
|
|
List.iter (fun pat -> unify_pat env pat ty_arg') patl;
|
|
|
|
(* Check for polymorphic variants to close *)
|
2003-08-18 01:26:18 -07:00
|
|
|
if List.exists has_variants patl then begin
|
|
|
|
Parmatch.pressure_variants env patl;
|
|
|
|
List.iter (iter_pattern finalize_variant) patl
|
|
|
|
end;
|
2000-11-06 01:49:27 -08:00
|
|
|
(* `Contaminating' unifications start here *)
|
2002-06-03 00:33:48 -07:00
|
|
|
List.iter (fun f -> f()) !pattern_force;
|
2011-11-24 01:02:48 -08:00
|
|
|
(* Post-processing and generalization *)
|
|
|
|
List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
|
|
|
|
patl;
|
|
|
|
List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl;
|
|
|
|
end_def ();
|
|
|
|
List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
|
|
|
|
(* type bodies *)
|
2001-11-21 22:47:29 -08:00
|
|
|
let in_function = if List.length caselist = 1 then in_function else None in
|
2000-06-13 02:41:06 -07:00
|
|
|
let cases =
|
|
|
|
List.map2
|
2013-04-15 09:23:22 -07:00
|
|
|
(fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} ->
|
|
|
|
let sexp = wrap_unpacks pc_rhs unpacks in
|
2010-11-08 22:23:53 -08:00
|
|
|
let ty_res' =
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
begin_def ();
|
2011-11-24 01:02:48 -08:00
|
|
|
let ty = instance ~partial:true env ty_res in
|
2010-11-08 22:23:53 -08:00
|
|
|
end_def ();
|
|
|
|
generalize_structure ty; ty
|
2011-11-24 01:02:48 -08:00
|
|
|
end
|
2013-04-15 09:23:22 -07:00
|
|
|
else if contains_gadt env pc_lhs then correct_levels ty_res
|
2011-11-24 01:02:48 -08:00
|
|
|
else ty_res in
|
2012-05-30 07:52:37 -07:00
|
|
|
(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
|
2010-12-12 18:59:58 -08:00
|
|
|
Printtyp.raw_type_expr ty_res'; *)
|
2013-04-15 09:23:22 -07:00
|
|
|
let guard =
|
|
|
|
match pc_guard with
|
|
|
|
| None -> None
|
|
|
|
| Some scond ->
|
|
|
|
Some
|
|
|
|
(type_expect ext_env (wrap_unpacks scond unpacks)
|
|
|
|
Predef.type_bool)
|
|
|
|
in
|
2010-11-08 22:23:53 -08:00
|
|
|
let exp = type_expect ?in_function ext_env sexp ty_res' in
|
2013-04-15 09:23:22 -07:00
|
|
|
{
|
|
|
|
c_lhs = pat;
|
|
|
|
c_guard = guard;
|
|
|
|
c_rhs = {exp with exp_type = instance env ty_res'}
|
|
|
|
}
|
|
|
|
)
|
2003-08-18 01:26:18 -07:00
|
|
|
pat_env_list caselist
|
|
|
|
in
|
2011-11-24 01:02:48 -08:00
|
|
|
if !Clflags.principal || has_gadts then begin
|
|
|
|
let ty_res' = instance env ty_res in
|
2013-04-15 09:23:22 -07:00
|
|
|
List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases
|
2010-11-08 22:23:53 -08:00
|
|
|
end;
|
2003-08-18 01:26:18 -07:00
|
|
|
let partial =
|
2010-11-08 23:11:08 -08:00
|
|
|
if partial_flag then
|
2010-12-13 16:53:47 -08:00
|
|
|
Parmatch.check_partial_gadt (partial_pred ~lev env ty_arg) loc cases
|
2010-11-08 23:11:08 -08:00
|
|
|
else
|
|
|
|
Partial
|
2003-08-18 01:26:18 -07:00
|
|
|
in
|
2013-01-10 23:26:23 -08:00
|
|
|
add_delayed_check
|
|
|
|
(fun () ->
|
|
|
|
List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
|
|
|
|
pat_env_list;
|
|
|
|
Parmatch.check_unused env cases);
|
2011-11-24 01:02:48 -08:00
|
|
|
if has_gadts then begin
|
|
|
|
end_def ();
|
|
|
|
(* Ensure that existential types do not escape *)
|
|
|
|
unify_exp_types loc env (instance env ty_res) (newvar ()) ;
|
|
|
|
end;
|
2000-11-06 01:49:27 -08:00
|
|
|
cases, partial
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
(* Typing of let bindings *)
|
|
|
|
|
2012-02-14 02:00:18 -08:00
|
|
|
and type_let ?(check = fun s -> Warnings.Unused_var s)
|
|
|
|
?(check_strict = fun s -> Warnings.Unused_var_strict s)
|
|
|
|
env rec_flag spat_sexp_list scope allow =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Ast_helper in
|
1995-05-04 03:15:53 -07:00
|
|
|
begin_def();
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
2011-12-29 09:49:58 -08:00
|
|
|
|
|
|
|
let is_fake_let =
|
|
|
|
match spat_sexp_list with
|
2013-06-03 08:14:19 -07:00
|
|
|
| [{pvb_expr={pexp_desc=Pexp_match(
|
|
|
|
{pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] ->
|
2011-12-29 09:49:58 -08:00
|
|
|
true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
|
|
|
|
| _ ->
|
|
|
|
false
|
|
|
|
in
|
|
|
|
let check = if is_fake_let then check_strict else check in
|
|
|
|
|
2011-04-18 19:13:52 -07:00
|
|
|
let spatl =
|
|
|
|
List.map
|
2013-06-03 08:14:19 -07:00
|
|
|
(fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=_} ->
|
2011-04-18 19:13:52 -07:00
|
|
|
match spat.ppat_desc, sexp.pexp_desc with
|
2011-04-18 19:34:54 -07:00
|
|
|
(Ppat_any | Ppat_constraint _), _ -> spat
|
2013-04-17 05:23:44 -07:00
|
|
|
| _, Pexp_coerce (_, _, sty)
|
|
|
|
| _, Pexp_constraint (_, sty) when !Clflags.principal ->
|
2011-04-18 19:34:54 -07:00
|
|
|
(* propagate type annotation to pattern,
|
|
|
|
to allow it to be generalized in -principal mode *)
|
2013-03-08 06:59:45 -08:00
|
|
|
Pat.constraint_
|
|
|
|
~loc:{spat.ppat_loc with Location.loc_ghost=true}
|
|
|
|
spat
|
|
|
|
sty
|
2011-04-18 19:13:52 -07:00
|
|
|
| _ -> spat)
|
|
|
|
spat_sexp_list in
|
2010-10-18 22:24:36 -07:00
|
|
|
let nvs = List.map (fun _ -> newvar ()) spatl in
|
2011-10-25 05:11:06 -07:00
|
|
|
let (pat_list, new_env, force, unpacks) =
|
2010-11-09 22:01:27 -08:00
|
|
|
type_pattern_list env spatl scope nvs allow in
|
2011-12-21 07:40:54 -08:00
|
|
|
let is_recursive = (rec_flag = Recursive) in
|
2012-02-14 02:00:18 -08:00
|
|
|
(* If recursive, first unify with an approximation of the expression *)
|
2011-12-21 07:40:54 -08:00
|
|
|
if is_recursive then
|
1999-11-30 08:07:38 -08:00
|
|
|
List.iter2
|
2013-06-03 08:14:19 -07:00
|
|
|
(fun pat binding ->
|
2009-10-26 00:11:36 -07:00
|
|
|
let pat =
|
|
|
|
match pat.pat_type.desc with
|
|
|
|
| Tpoly (ty, tl) ->
|
2011-12-27 00:52:45 -08:00
|
|
|
{pat with pat_type =
|
|
|
|
snd (instance_poly ~keep_names:true false tl ty)}
|
2009-10-26 00:11:36 -07:00
|
|
|
| _ -> pat
|
2013-06-03 08:14:19 -07:00
|
|
|
in unify_pat env pat (type_approx env binding.pvb_expr))
|
1999-11-30 08:07:38 -08:00
|
|
|
pat_list spat_sexp_list;
|
2012-02-14 02:00:18 -08:00
|
|
|
(* Polymorphic variant processing *)
|
|
|
|
List.iter
|
|
|
|
(fun pat ->
|
|
|
|
if has_variants pat then begin
|
|
|
|
Parmatch.pressure_variants env [pat];
|
|
|
|
iter_pattern finalize_variant pat
|
|
|
|
end)
|
|
|
|
pat_list;
|
|
|
|
(* Generalize the structure *)
|
2002-04-18 00:27:47 -07:00
|
|
|
let pat_list =
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
List.map
|
|
|
|
(fun pat ->
|
|
|
|
iter_pattern (fun pat -> generalize_structure pat.pat_type) pat;
|
2011-11-24 01:02:48 -08:00
|
|
|
{pat with pat_type = instance env pat.pat_type})
|
2002-04-18 00:27:47 -07:00
|
|
|
pat_list
|
|
|
|
end else pat_list in
|
2002-06-03 00:33:48 -07:00
|
|
|
(* Only bind pattern variables after generalizing *)
|
|
|
|
List.iter (fun f -> f()) force;
|
1995-05-04 03:15:53 -07:00
|
|
|
let exp_env =
|
2011-12-21 07:40:54 -08:00
|
|
|
if is_recursive then new_env else env in
|
|
|
|
|
|
|
|
let current_slot = ref None in
|
2012-05-29 05:30:49 -07:00
|
|
|
let rec_needed = ref false in
|
2012-03-28 03:39:05 -07:00
|
|
|
let warn_unused =
|
2012-05-31 01:07:31 -07:00
|
|
|
Warnings.is_active (check "") || Warnings.is_active (check_strict "") ||
|
|
|
|
(is_recursive && (Warnings.is_active Warnings.Unused_rec_flag))
|
2012-05-29 05:30:49 -07:00
|
|
|
in
|
2011-12-21 07:40:54 -08:00
|
|
|
let pat_slot_list =
|
|
|
|
(* Algorithm to detect unused declarations in recursive bindings:
|
|
|
|
- During type checking of the definitions, we capture the 'value_used'
|
|
|
|
events on the bound identifiers and record them in a slot corresponding
|
2012-02-14 02:00:18 -08:00
|
|
|
to the current definition (!current_slot).
|
|
|
|
In effect, this creates a dependency graph between definitions.
|
2011-12-21 07:40:54 -08:00
|
|
|
|
2012-05-29 05:30:49 -07:00
|
|
|
- After type checking the definition (!current_slot = None),
|
2012-02-14 02:00:18 -08:00
|
|
|
when one of the bound identifier is effectively used, we trigger
|
|
|
|
again all the events recorded in the corresponding slot.
|
|
|
|
The effect is to traverse the transitive closure of the graph created
|
2011-12-21 07:40:54 -08:00
|
|
|
in the first step.
|
2011-12-29 09:49:58 -08:00
|
|
|
|
2012-02-14 02:00:18 -08:00
|
|
|
We also keep track of whether *all* variables in a given pattern
|
|
|
|
are unused. If this is the case, for local declarations, the issued
|
|
|
|
warning is 26, not 27.
|
2011-12-21 07:40:54 -08:00
|
|
|
*)
|
|
|
|
List.map
|
|
|
|
(fun pat ->
|
2011-12-29 09:49:58 -08:00
|
|
|
if not warn_unused then pat, None
|
2011-12-21 07:40:54 -08:00
|
|
|
else
|
2012-02-14 02:00:18 -08:00
|
|
|
let some_used = ref false in
|
|
|
|
(* has one of the identifier of this pattern been used? *)
|
2011-12-21 07:40:54 -08:00
|
|
|
let slot = ref [] in
|
|
|
|
List.iter
|
2012-05-30 07:52:37 -07:00
|
|
|
(fun (id,_) ->
|
2012-02-14 02:00:18 -08:00
|
|
|
let vd = Env.find_value (Path.Pident id) new_env in
|
|
|
|
(* note: Env.find_value does not trigger the value_used event *)
|
2011-12-21 07:40:54 -08:00
|
|
|
let name = Ident.name id in
|
2011-12-29 09:49:58 -08:00
|
|
|
let used = ref false in
|
|
|
|
if not (name = "" || name.[0] = '_' || name.[0] = '#') then
|
|
|
|
add_delayed_check
|
|
|
|
(fun () ->
|
|
|
|
if not !used then
|
2012-05-30 07:52:37 -07:00
|
|
|
Location.prerr_warning vd.Types.val_loc
|
2011-12-29 09:49:58 -08:00
|
|
|
((if !some_used then check_strict else check) name)
|
|
|
|
);
|
2011-12-21 07:40:54 -08:00
|
|
|
Env.set_value_used_callback
|
|
|
|
name vd
|
2011-12-29 09:49:58 -08:00
|
|
|
(fun () ->
|
2011-12-21 07:40:54 -08:00
|
|
|
match !current_slot with
|
2012-05-31 01:07:31 -07:00
|
|
|
| Some slot ->
|
|
|
|
slot := (name, vd) :: !slot; rec_needed := true
|
2011-12-29 09:49:58 -08:00
|
|
|
| None ->
|
|
|
|
List.iter
|
|
|
|
(fun (name, vd) -> Env.mark_value_used name vd)
|
|
|
|
(get_ref slot);
|
|
|
|
used := true;
|
|
|
|
some_used := true
|
2011-12-21 07:40:54 -08:00
|
|
|
)
|
|
|
|
)
|
|
|
|
(Typedtree.pat_bound_idents pat);
|
|
|
|
pat, Some slot
|
|
|
|
)
|
|
|
|
pat_list
|
|
|
|
in
|
1995-05-04 03:15:53 -07:00
|
|
|
let exp_list =
|
1995-11-19 08:53:56 -08:00
|
|
|
List.map2
|
2013-06-03 08:14:19 -07:00
|
|
|
(fun {pvb_expr=sexp; _} (pat, slot) ->
|
2010-10-21 16:59:33 -07:00
|
|
|
let sexp =
|
|
|
|
if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
|
2011-12-29 09:49:58 -08:00
|
|
|
if is_recursive then current_slot := slot;
|
2009-10-26 00:11:36 -07:00
|
|
|
match pat.pat_type.desc with
|
|
|
|
| Tpoly (ty, tl) ->
|
|
|
|
begin_def ();
|
2011-04-18 19:13:52 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
2011-12-27 00:52:45 -08:00
|
|
|
let vars, ty' = instance_poly ~keep_names:true true tl ty in
|
2011-04-18 19:13:52 -07:00
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure ty'
|
|
|
|
end;
|
2009-10-26 00:11:36 -07:00
|
|
|
let exp = type_expect exp_env sexp ty' in
|
|
|
|
end_def ();
|
|
|
|
check_univars env true "definition" exp pat.pat_type vars;
|
2011-11-24 01:02:48 -08:00
|
|
|
{exp with exp_type = instance env exp.exp_type}
|
2009-10-26 00:11:36 -07:00
|
|
|
| _ -> type_expect exp_env sexp pat.pat_type)
|
2011-12-21 07:40:54 -08:00
|
|
|
spat_sexp_list pat_slot_list in
|
|
|
|
current_slot := None;
|
2012-05-31 01:07:31 -07:00
|
|
|
if is_recursive && not !rec_needed
|
|
|
|
&& Warnings.is_active Warnings.Unused_rec_flag then
|
2013-06-03 08:14:19 -07:00
|
|
|
Location.prerr_warning (List.hd spat_sexp_list).pvb_pat.ppat_loc
|
2012-05-29 05:30:49 -07:00
|
|
|
Warnings.Unused_rec_flag;
|
1995-05-04 03:15:53 -07:00
|
|
|
List.iter2
|
2013-04-15 09:23:22 -07:00
|
|
|
(fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [case pat exp]))
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_list exp_list;
|
|
|
|
end_def();
|
1997-03-07 14:00:19 -08:00
|
|
|
List.iter2
|
|
|
|
(fun pat exp ->
|
|
|
|
if not (is_nonexpansive exp) then
|
2002-12-02 18:57:23 -08:00
|
|
|
iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
|
1997-03-07 14:00:19 -08:00
|
|
|
pat_list exp_list;
|
1995-05-04 03:15:53 -07:00
|
|
|
List.iter
|
2011-12-27 00:52:45 -08:00
|
|
|
(fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
|
1997-03-07 14:00:19 -08:00
|
|
|
pat_list;
|
2013-06-03 08:14:19 -07:00
|
|
|
let l = List.combine pat_list exp_list in
|
|
|
|
let l =
|
|
|
|
List.map2
|
2014-01-22 17:58:37 -08:00
|
|
|
(fun (p, e) pvb ->
|
2014-04-22 08:28:20 -07:00
|
|
|
{vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes;
|
|
|
|
vb_loc=pvb.pvb_loc;
|
|
|
|
})
|
2013-06-03 08:14:19 -07:00
|
|
|
l spat_sexp_list
|
|
|
|
in
|
|
|
|
(l, new_env, unpacks)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
(* Typing of toplevel bindings *)
|
|
|
|
|
2011-12-29 09:49:58 -08:00
|
|
|
let type_binding env rec_flag spat_sexp_list scope =
|
|
|
|
Typetexp.reset_type_variables();
|
|
|
|
let (pat_exp_list, new_env, unpacks) =
|
|
|
|
type_let
|
|
|
|
~check:(fun s -> Warnings.Unused_value_declaration s)
|
|
|
|
~check_strict:(fun s -> Warnings.Unused_value_declaration s)
|
|
|
|
env rec_flag spat_sexp_list scope false
|
|
|
|
in
|
|
|
|
(pat_exp_list, new_env)
|
|
|
|
|
2010-10-21 16:59:33 -07:00
|
|
|
let type_let env rec_flag spat_sexp_list scope =
|
|
|
|
let (pat_exp_list, new_env, unpacks) =
|
|
|
|
type_let env rec_flag spat_sexp_list scope false in
|
|
|
|
(pat_exp_list, new_env)
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Typing of toplevel expressions *)
|
|
|
|
|
|
|
|
let type_expression env sexp =
|
|
|
|
Typetexp.reset_type_variables();
|
|
|
|
begin_def();
|
|
|
|
let exp = type_exp env sexp in
|
|
|
|
end_def();
|
1997-03-08 14:03:32 -08:00
|
|
|
if is_nonexpansive exp then generalize exp.exp_type
|
2002-12-02 18:57:23 -08:00
|
|
|
else generalize_expansive env exp.exp_type;
|
2011-12-26 23:12:06 -08:00
|
|
|
match sexp.pexp_desc with
|
|
|
|
Pexp_ident lid ->
|
|
|
|
(* Special case for keeping type variables when looking-up a variable *)
|
2012-05-30 07:52:37 -07:00
|
|
|
let (path, desc) = Env.lookup_value lid.txt env in
|
2011-12-26 23:12:06 -08:00
|
|
|
{exp with exp_type = desc.val_type}
|
|
|
|
| _ -> exp
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
(* Error report *)
|
|
|
|
|
2000-03-06 14:12:09 -08:00
|
|
|
open Format
|
1995-05-04 03:15:53 -07:00
|
|
|
open Printtyp
|
|
|
|
|
2013-01-29 06:21:12 -08:00
|
|
|
let report_error env ppf = function
|
2007-02-26 19:46:19 -08:00
|
|
|
| Polymorphic_label lid ->
|
2012-11-10 19:46:59 -08:00
|
|
|
fprintf ppf "@[The record field %a is polymorphic.@ %s@]"
|
2007-02-26 20:54:05 -08:00
|
|
|
longident lid "You cannot instantiate it in a pattern."
|
1995-05-04 03:15:53 -07:00
|
|
|
| Constructor_arity_mismatch(lid, expected, provided) ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf
|
|
|
|
"@[The constructor %a@ expects %i argument(s),@ \
|
2009-05-20 04:52:42 -07:00
|
|
|
but is applied here to %i argument(s)@]"
|
2000-03-06 14:12:09 -08:00
|
|
|
longident lid expected provided
|
1996-05-20 09:43:29 -07:00
|
|
|
| Label_mismatch(lid, trace) ->
|
2013-01-29 06:21:12 -08:00
|
|
|
report_unification_error ppf env trace
|
2000-03-06 14:12:09 -08:00
|
|
|
(function ppf ->
|
2012-11-10 19:46:59 -08:00
|
|
|
fprintf ppf "The record field %a@ belongs to the type"
|
2000-03-16 08:44:21 -08:00
|
|
|
longident lid)
|
2000-03-06 14:12:09 -08:00
|
|
|
(function ppf ->
|
2012-11-10 19:46:59 -08:00
|
|
|
fprintf ppf "but is mixed here with fields of type")
|
1996-05-20 09:43:29 -07:00
|
|
|
| Pattern_type_clash trace ->
|
2013-01-29 06:21:12 -08:00
|
|
|
report_unification_error ppf env trace
|
2000-03-06 14:12:09 -08:00
|
|
|
(function ppf ->
|
2012-05-31 01:07:31 -07:00
|
|
|
fprintf ppf "This pattern matches values of type")
|
2000-03-06 14:12:09 -08:00
|
|
|
(function ppf ->
|
2012-05-31 01:07:31 -07:00
|
|
|
fprintf ppf "but a pattern was expected which matches values of type")
|
2014-01-27 08:27:05 -08:00
|
|
|
| Or_pattern_type_clash (id, trace) ->
|
|
|
|
report_unification_error ppf env trace
|
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "The variable %s on the left-hand side of this or-pattern has type" (Ident.name id))
|
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "but on the right-hand side it has type")
|
2008-01-11 08:13:18 -08:00
|
|
|
| Multiply_bound_variable name ->
|
|
|
|
fprintf ppf "Variable %s is bound several times in this matching" name
|
2000-10-02 07:18:05 -07:00
|
|
|
| Orpat_vars id ->
|
|
|
|
fprintf ppf "Variable %s must occur on both sides of this | pattern"
|
|
|
|
(Ident.name id)
|
1996-05-20 09:43:29 -07:00
|
|
|
| Expr_type_clash trace ->
|
2013-01-29 06:21:12 -08:00
|
|
|
report_unification_error ppf env trace
|
2000-03-06 14:12:09 -08:00
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "This expression has type")
|
|
|
|
(function ppf ->
|
2009-05-20 04:52:42 -07:00
|
|
|
fprintf ppf "but an expression was expected of type")
|
1995-05-04 03:15:53 -07:00
|
|
|
| Apply_non_function typ ->
|
2012-05-28 04:56:28 -07:00
|
|
|
reset_and_mark_loops typ;
|
1996-04-22 04:15:41 -07:00
|
|
|
begin match (repr typ).desc with
|
1999-11-30 08:07:38 -08:00
|
|
|
Tarrow _ ->
|
2012-05-28 14:58:42 -07:00
|
|
|
fprintf ppf "@[<v>@[<2>This function has type@ %a@]"
|
2012-05-28 14:57:08 -07:00
|
|
|
type_expr typ;
|
|
|
|
fprintf ppf "@ @[It is applied to too many arguments;@ %s@]@]"
|
|
|
|
"maybe you forgot a `;'."
|
1995-05-04 03:15:53 -07:00
|
|
|
| _ ->
|
2012-05-28 14:57:08 -07:00
|
|
|
fprintf ppf "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
|
|
|
|
type_expr typ
|
|
|
|
"This is not a function; it cannot be applied."
|
1995-05-04 03:15:53 -07:00
|
|
|
end
|
1999-11-30 08:07:38 -08:00
|
|
|
| Apply_wrong_label (l, ty) ->
|
2000-03-06 14:12:09 -08:00
|
|
|
let print_label ppf = function
|
2000-03-16 08:44:21 -08:00
|
|
|
| "" -> fprintf ppf "without label"
|
2001-12-25 19:50:22 -08:00
|
|
|
| l ->
|
|
|
|
fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l
|
|
|
|
in
|
2000-03-06 14:12:09 -08:00
|
|
|
reset_and_mark_loops ty;
|
|
|
|
fprintf ppf
|
2009-05-20 04:52:42 -07:00
|
|
|
"@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
|
2000-03-16 08:44:21 -08:00
|
|
|
This argument cannot be applied %a@]"
|
2000-03-06 14:12:09 -08:00
|
|
|
type_expr ty print_label l
|
2012-11-14 08:59:33 -08:00
|
|
|
| Label_multiply_defined s ->
|
|
|
|
fprintf ppf "The record field label %s is defined several times" s
|
2001-06-28 18:46:46 -07:00
|
|
|
| Label_missing labels ->
|
2012-05-31 01:07:31 -07:00
|
|
|
let print_labels ppf =
|
|
|
|
List.iter (fun lbl -> fprintf ppf "@ %s" (Ident.name lbl)) in
|
2012-10-31 05:36:13 -07:00
|
|
|
fprintf ppf "@[<hov>Some record fields are undefined:%a@]"
|
2001-06-28 18:46:46 -07:00
|
|
|
print_labels labels
|
1995-05-04 03:15:53 -07:00
|
|
|
| Label_not_mutable lid ->
|
2012-10-31 05:36:13 -07:00
|
|
|
fprintf ppf "The record field %a is not mutable" longident lid
|
2013-09-19 00:25:51 -07:00
|
|
|
| Wrong_name (eorp, ty, kind, p, lid) ->
|
|
|
|
reset_and_mark_loops ty;
|
|
|
|
fprintf ppf "@[@[<2>%s type@ %a@]@ "
|
|
|
|
eorp type_expr ty;
|
|
|
|
fprintf ppf "The %s %a does not belong to type %a@]"
|
2013-09-04 08:12:37 -07:00
|
|
|
(if kind = "record" then "field" else "constructor")
|
2013-09-19 00:25:51 -07:00
|
|
|
longident lid (*kind*) path p;
|
2012-10-31 20:32:34 -07:00
|
|
|
if kind = "record" then Label.spellcheck ppf env p lid
|
|
|
|
else Constructor.spellcheck ppf env p lid
|
2012-11-10 19:46:59 -08:00
|
|
|
| Name_type_mismatch (kind, lid, tp, tpl) ->
|
|
|
|
let name = if kind = "record" then "field" else "constructor" in
|
2013-01-29 06:21:12 -08:00
|
|
|
report_ambiguous_type_error ppf env tp tpl
|
2012-11-10 19:46:59 -08:00
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "The %s %a@ belongs to the %s type"
|
|
|
|
name longident lid kind)
|
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "The %s %a@ belongs to one of the following %s types:"
|
|
|
|
name longident lid kind)
|
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "but a %s was expected belonging to the %s type"
|
|
|
|
name kind)
|
2005-03-04 06:51:31 -08:00
|
|
|
| Incomplete_format s ->
|
|
|
|
fprintf ppf "Premature end of format string ``%S''" s
|
|
|
|
| Bad_conversion (fmt, i, c) ->
|
|
|
|
fprintf ppf
|
|
|
|
"Bad conversion %%%c, at char number %d \
|
|
|
|
in format string ``%s''" c i fmt
|
1998-06-24 12:22:26 -07:00
|
|
|
| Undefined_method (ty, me) ->
|
2000-03-06 14:12:09 -08:00
|
|
|
reset_and_mark_loops ty;
|
|
|
|
fprintf ppf
|
|
|
|
"@[<v>@[This expression has type@;<1 2>%a@]@,\
|
|
|
|
It has no method %s@]" type_expr ty me
|
1998-06-24 12:22:26 -07:00
|
|
|
| Undefined_inherited_method me ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "This expression has no method %s" me
|
1996-04-22 04:15:41 -07:00
|
|
|
| Virtual_class cl ->
|
2009-05-20 04:52:42 -07:00
|
|
|
fprintf ppf "Cannot instantiate the virtual class %a"
|
2003-02-27 22:59:19 -08:00
|
|
|
longident cl
|
1996-04-22 04:15:41 -07:00
|
|
|
| Unbound_instance_variable v ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "Unbound instance variable %s" v
|
2010-04-26 05:54:11 -07:00
|
|
|
| Instance_variable_not_mutable (b, v) ->
|
|
|
|
if b then
|
|
|
|
fprintf ppf "The instance variable %s is not mutable" v
|
|
|
|
else
|
|
|
|
fprintf ppf "The value %s is not an instance variable" v
|
1996-05-26 06:42:34 -07:00
|
|
|
| Not_subtype(tr1, tr2) ->
|
2013-01-29 06:21:12 -08:00
|
|
|
report_subtyping_error ppf env tr1 "is not a subtype of" tr2
|
1996-04-22 04:15:41 -07:00
|
|
|
| Outside_class ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "This object duplication occurs outside a method definition"
|
1996-04-22 04:15:41 -07:00
|
|
|
| Value_multiply_overridden v ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "The instance variable %s is overridden several times" v
|
2002-06-12 02:52:08 -07:00
|
|
|
| Coercion_failure (ty, ty', trace, b) ->
|
2013-01-29 06:21:12 -08:00
|
|
|
report_unification_error ppf env trace
|
2000-03-06 14:12:09 -08:00
|
|
|
(function ppf ->
|
1999-11-30 08:07:38 -08:00
|
|
|
let ty, ty' = prepare_expansion (ty, ty') in
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf
|
|
|
|
"This expression cannot be coerced to type@;<1 2>%a;@ it has type"
|
|
|
|
(type_expansion ty) ty')
|
|
|
|
(function ppf ->
|
2002-05-29 23:24:45 -07:00
|
|
|
fprintf ppf "but is here used with type");
|
2002-06-12 02:52:08 -07:00
|
|
|
if b then
|
|
|
|
fprintf ppf ".@.@[<hov>%s@ %s@]"
|
|
|
|
"This simple coercion was not fully general."
|
|
|
|
"Consider using a double coercion."
|
2001-11-21 22:47:29 -08:00
|
|
|
| Too_many_arguments (in_function, ty) ->
|
|
|
|
reset_and_mark_loops ty;
|
|
|
|
if in_function then begin
|
|
|
|
fprintf ppf "This function expects too many arguments,@ ";
|
|
|
|
fprintf ppf "it should have type@ %a"
|
|
|
|
type_expr ty
|
|
|
|
end else begin
|
|
|
|
fprintf ppf "This expression should not be a function,@ ";
|
|
|
|
fprintf ppf "the expected type is@ %a"
|
|
|
|
type_expr ty
|
|
|
|
end
|
1999-11-30 08:07:38 -08:00
|
|
|
| Abstract_wrong_label (l, ty) ->
|
2000-03-06 14:12:09 -08:00
|
|
|
let label_mark = function
|
2009-05-20 04:52:42 -07:00
|
|
|
| "" -> "but its first argument is not labelled"
|
|
|
|
| l -> sprintf "but its first argument is labelled ~%s" l in
|
2000-03-06 14:12:09 -08:00
|
|
|
reset_and_mark_loops ty;
|
|
|
|
fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]"
|
|
|
|
type_expr ty (label_mark l)
|
1998-02-26 04:54:44 -08:00
|
|
|
| Scoping_let_module(id, ty) ->
|
2000-03-06 14:12:09 -08:00
|
|
|
reset_and_mark_loops ty;
|
|
|
|
fprintf ppf
|
|
|
|
"This `let module' expression has type@ %a@ " type_expr ty;
|
|
|
|
fprintf ppf
|
|
|
|
"In this type, the locally bound module name %s escapes its scope" id
|
1998-06-24 12:22:26 -07:00
|
|
|
| Masked_instance_variable lid ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf
|
|
|
|
"The instance variable %a@ \
|
|
|
|
cannot be accessed from the definition of another instance variable"
|
|
|
|
longident lid
|
2003-05-01 15:22:37 -07:00
|
|
|
| Private_type ty ->
|
2003-07-02 02:14:35 -07:00
|
|
|
fprintf ppf "Cannot create values of the private type %a" type_expr ty
|
|
|
|
| Private_label (lid, ty) ->
|
|
|
|
fprintf ppf "Cannot assign field %a of the private type %a"
|
|
|
|
longident lid type_expr ty
|
2000-02-21 19:08:08 -08:00
|
|
|
| Not_a_variant_type lid ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "The type %a@ is not a variant type" longident lid
|
2001-04-19 01:34:21 -07:00
|
|
|
| Incoherent_label_order ->
|
|
|
|
fprintf ppf "This function is applied to arguments@ ";
|
|
|
|
fprintf ppf "in an order different from other calls.@ ";
|
|
|
|
fprintf ppf "This is only allowed when the real type is known."
|
2002-04-18 00:27:47 -07:00
|
|
|
| Less_general (kind, trace) ->
|
2013-01-29 06:21:12 -08:00
|
|
|
report_unification_error ppf env trace
|
2002-04-18 00:27:47 -07:00
|
|
|
(fun ppf -> fprintf ppf "This %s has type" kind)
|
|
|
|
(fun ppf -> fprintf ppf "which is less general than")
|
2010-10-21 16:59:33 -07:00
|
|
|
| Modules_not_allowed ->
|
|
|
|
fprintf ppf "Modules are not allowed in this pattern."
|
|
|
|
| Cannot_infer_signature ->
|
|
|
|
fprintf ppf
|
|
|
|
"The signature for this packaged module couldn't be inferred."
|
|
|
|
| Not_a_packed_module ty ->
|
|
|
|
fprintf ppf
|
|
|
|
"This expression is packed module, but the expected type is@ %a"
|
|
|
|
type_expr ty
|
2011-07-29 03:32:43 -07:00
|
|
|
| Recursive_local_constraint trace ->
|
2013-01-29 06:21:12 -08:00
|
|
|
report_unification_error ppf env trace
|
2011-07-29 03:32:43 -07:00
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "Recursive local constraint when unifying")
|
|
|
|
(function ppf ->
|
2011-10-25 05:11:06 -07:00
|
|
|
fprintf ppf "with")
|
2010-12-03 08:13:01 -08:00
|
|
|
| Unexpected_existential ->
|
|
|
|
fprintf ppf
|
2011-10-25 05:11:06 -07:00
|
|
|
"Unexpected existential"
|
2012-12-07 18:40:56 -08:00
|
|
|
| Unqualified_gadt_pattern (tpath, name) ->
|
|
|
|
fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]"
|
|
|
|
name path tpath
|
|
|
|
"must be qualified in this pattern"
|
2013-04-16 08:34:09 -07:00
|
|
|
| Invalid_interval ->
|
|
|
|
fprintf ppf "@[Only character intervals are supported in patterns.@]"
|
2013-12-02 10:00:18 -08:00
|
|
|
| Invalid_for_loop_index ->
|
2014-01-22 17:58:37 -08:00
|
|
|
fprintf ppf
|
|
|
|
"@[Invalid for-loop index: only variables and _ are allowed.@]"
|
2014-05-05 04:49:37 -07:00
|
|
|
| No_value_clauses ->
|
|
|
|
fprintf ppf
|
|
|
|
"None of the patterns in this 'match' expression match values."
|
|
|
|
| Exception_pattern_below_toplevel ->
|
|
|
|
fprintf ppf
|
|
|
|
"@[Exception patterns must be at the top level of a match case.@]"
|
2011-12-21 07:40:54 -08:00
|
|
|
|
2012-01-22 23:59:45 -08:00
|
|
|
let report_error env ppf err =
|
2013-01-29 06:21:12 -08:00
|
|
|
wrap_printing_env env (fun () -> report_error env ppf err)
|
2012-01-22 23:59:45 -08:00
|
|
|
|
2013-09-11 09:08:00 -07:00
|
|
|
let () =
|
|
|
|
Location.register_error_of_exn
|
|
|
|
(function
|
|
|
|
| Error (loc, env, err) ->
|
|
|
|
Some (Location.error_of_printer loc (report_error env) err)
|
2014-05-07 01:26:17 -07:00
|
|
|
| Error_forward err ->
|
|
|
|
Some err
|
2013-09-11 09:08:00 -07:00
|
|
|
| _ ->
|
|
|
|
None
|
|
|
|
)
|
|
|
|
|
2011-12-21 07:40:54 -08:00
|
|
|
let () =
|
|
|
|
Env.add_delayed_check_forward := add_delayed_check
|