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
|
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
|
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
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
exception Error of Location.t * error
|
|
|
|
|
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
|
|
|
|
|
|
|
let snd3 (_,x,_) = x
|
|
|
|
|
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
|
|
|
|
| Pexp_ident _
|
|
|
|
| Pexp_assertfalse
|
|
|
|
| Pexp_new _
|
|
|
|
| Pexp_constant _ -> ()
|
2012-01-20 19:40:37 -08:00
|
|
|
| Pexp_function (_, eo, pel) ->
|
|
|
|
may expr eo; List.iter (fun (_, e) -> expr e) pel
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
|
|
|
|
| Pexp_let (_, pel, e)
|
|
|
|
| Pexp_match (e, pel)
|
|
|
|
| Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
|
|
|
|
| Pexp_array el
|
|
|
|
| Pexp_tuple el -> List.iter expr el
|
|
|
|
| Pexp_construct (_, eo, _)
|
|
|
|
| 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
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pexp_open (_, e)
|
|
|
|
| Pexp_newtype (_, e)
|
|
|
|
| Pexp_poly (e, _)
|
|
|
|
| Pexp_lazy e
|
|
|
|
| Pexp_assert e
|
|
|
|
| Pexp_setinstvar (_, e)
|
|
|
|
| Pexp_send (e, _)
|
|
|
|
| Pexp_constraint (e, _, _)
|
|
|
|
| Pexp_field (e, _) -> expr e
|
|
|
|
| Pexp_when (e1, e2)
|
|
|
|
| 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
|
|
|
|
|
|
|
|
and module_expr me =
|
|
|
|
match me.pmod_desc with
|
|
|
|
| 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
|
|
|
|
|
|
|
|
and structure_item str =
|
|
|
|
match str.pstr_desc with
|
|
|
|
| Pstr_eval e -> expr e
|
|
|
|
| Pstr_value (_, pel) -> List.iter (fun (_, e) -> expr e) pel
|
|
|
|
| Pstr_primitive _
|
|
|
|
| Pstr_type _
|
|
|
|
| Pstr_exception _
|
|
|
|
| Pstr_modtype _
|
|
|
|
| Pstr_open _
|
|
|
|
| Pstr_class_type _
|
|
|
|
| Pstr_exn_rebind _ -> ()
|
|
|
|
| Pstr_include me
|
|
|
|
| Pstr_module (_, me) -> module_expr me
|
|
|
|
| Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l
|
|
|
|
| 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) ->
|
|
|
|
List.iter (fun (_, e) -> expr e) pel; class_expr ce
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pcl_constraint (ce, _) -> class_expr ce
|
|
|
|
|
2012-05-30 07:52:37 -07:00
|
|
|
and class_field cf =
|
|
|
|
match cf.pcf_desc with
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pcf_inher (_, ce, _) -> class_expr ce
|
2012-05-30 07:52:37 -07:00
|
|
|
| Pcf_valvirt _ | Pcf_virt _ | Pcf_constr _ -> ()
|
|
|
|
| Pcf_val (_,_,_,e) | Pcf_meth (_,_,_,e) -> expr e
|
2012-01-18 09:41:12 -08:00
|
|
|
| Pcf_init e -> expr e
|
|
|
|
|
|
|
|
in
|
|
|
|
expr e
|
|
|
|
|
|
|
|
|
2012-01-20 06:26:15 -08:00
|
|
|
let all_idents 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
|
|
|
|
List.iter (iter_expression f) el;
|
|
|
|
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 *)
|
|
|
|
|
|
|
|
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 =
|
|
|
|
{ exp_desc; exp_type; exp_loc; exp_env; exp_extra = [] }
|
2012-05-30 07:52:37 -07:00
|
|
|
|
1999-11-30 08:07:38 -08:00
|
|
|
let option_none ty loc =
|
2012-05-30 07:52:37 -07:00
|
|
|
let lid = Longident.Lident "None" in
|
2012-10-24 05:03:00 -07:00
|
|
|
let cnone = Env.lookup_constructor lid Env.initial in
|
|
|
|
mkexp (Texp_construct(mknoloc lid, cnone, [], false))
|
2012-05-31 01:07:31 -07:00
|
|
|
ty loc Env.initial
|
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
|
2012-10-24 05:03:00 -07:00
|
|
|
let csome = Env.lookup_constructor lid Env.initial in
|
|
|
|
mkexp ( Texp_construct(mknoloc lid , csome, [texp],false) )
|
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
|
|
|
|
|
2003-02-27 22:59:19 -08:00
|
|
|
let rec extract_label_names sexp env ty =
|
2010-11-11 19:09:11 -08:00
|
|
|
let ty = expand_head env ty in
|
2001-06-28 18:46:46 -07:00
|
|
|
match ty.desc with
|
|
|
|
| Tconstr (path, _, _) ->
|
|
|
|
let td = Env.find_type path env in
|
2003-07-03 01:34:08 -07:00
|
|
|
begin match td.type_kind with
|
2007-10-09 03:29:37 -07:00
|
|
|
| Type_record (fields, _) ->
|
2003-07-02 02:14:35 -07:00
|
|
|
List.map (fun (name, _, _) -> name) fields
|
2001-06-28 18:46:46 -07:00
|
|
|
| Type_abstract when td.type_manifest <> None ->
|
2003-02-27 22:59:19 -08:00
|
|
|
extract_label_names sexp env (expand_head env ty)
|
2003-07-03 01:34:08 -07:00
|
|
|
| _ -> assert false
|
|
|
|
end
|
2001-06-28 18:46:46 -07:00
|
|
|
| _ ->
|
|
|
|
assert false
|
|
|
|
|
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 ->
|
|
|
|
raise(Error(loc, Pattern_type_clash(trace)))
|
|
|
|
| Tags(l1,l2) ->
|
|
|
|
raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
|
|
|
|
|
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 ->
|
2010-10-15 23:09:25 -07:00
|
|
|
raise(Error(loc, Expr_type_clash(trace)))
|
2002-01-03 18:02:50 -08:00
|
|
|
| Tags(l1,l2) ->
|
2010-10-15 23:09:25 -07:00
|
|
|
raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
|
|
|
|
|
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 ->
|
|
|
|
raise(Error(loc, Pattern_type_clash(trace)))
|
|
|
|
| Tags(l1,l2) ->
|
|
|
|
raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
|
2010-10-24 22:25:33 -07:00
|
|
|
| Unification_recursive_abbrev trace ->
|
|
|
|
raise(Error(loc, 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
|
2003-08-18 01:26:18 -07:00
|
|
|
| Rabsent -> assert false
|
|
|
|
| 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-05-30 07:52:37 -07:00
|
|
|
then raise(Error(loc, Multiply_bound_variable name.txt));
|
|
|
|
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 *)
|
|
|
|
if not !allow_modules then raise (Error (loc, Modules_not_allowed));
|
|
|
|
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 ->
|
|
|
|
raise(Error(loc, Pattern_type_clash(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-05-30 07:52:37 -07:00
|
|
|
| (x,_,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
|
|
|
|
| [],(x,_,_,_,_)::_ -> raise (Error (loc, Orpat_vars x))
|
|
|
|
| (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
|
|
|
|
raise (Error (loc, Orpat_vars min_var)) in
|
|
|
|
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)
|
2012-10-24 05:03:00 -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
|
2000-02-21 19:08:08 -08:00
|
|
|
| _ -> raise(Error(loc, Not_a_variant_type lid))
|
|
|
|
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;
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_type=ty; pat_extra=[];})
|
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 =
|
2008-01-11 08:13:18 -08:00
|
|
|
List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_env=env; pat_type=ty; pat_extra=[];})
|
2000-02-21 19:08:08 -08:00
|
|
|
pats
|
|
|
|
in
|
|
|
|
match pats with
|
|
|
|
[] -> raise(Error(loc, Not_a_variant_type lid))
|
|
|
|
| pat :: pats ->
|
2003-02-24 07:13:01 -08:00
|
|
|
let r =
|
|
|
|
List.fold_left
|
2012-05-30 07:52:37 -07:00
|
|
|
(fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
|
2003-04-01 17:32:09 -08:00
|
|
|
pat_loc=gloc; pat_env=env; pat_type=ty})
|
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
|
|
|
|
2011-06-15 02:26:30 -07:00
|
|
|
(* Records *)
|
2000-02-21 19:08:08 -08: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-06-13 16:45:01 -07:00
|
|
|
let type_label_a_list ?labels env type_lbl_a lid_a_list =
|
2011-06-15 02:26:30 -07:00
|
|
|
let record_qual = find_record_qual lid_a_list in
|
|
|
|
let lbl_a_list =
|
|
|
|
List.map
|
|
|
|
(fun (lid, a) ->
|
2012-10-24 05:03:00 -07:00
|
|
|
let label =
|
2012-05-30 07:52:37 -07:00
|
|
|
match lid.txt, labels, record_qual with
|
|
|
|
Longident.Lident s, Some labels, _ when Hashtbl.mem labels s ->
|
2012-10-24 05:03:00 -07:00
|
|
|
(Hashtbl.find labels s : Types.label_description)
|
2012-05-30 07:52:37 -07:00
|
|
|
| Longident.Lident s, _, Some modname ->
|
2012-06-13 16:45:01 -07:00
|
|
|
Typetexp.find_label env lid.loc (Longident.Ldot (modname, s))
|
2012-05-30 07:52:37 -07:00
|
|
|
| _ ->
|
2012-06-13 16:45:01 -07:00
|
|
|
Typetexp.find_label env lid.loc lid.txt
|
2012-10-24 05:03:00 -07:00
|
|
|
in (lid, label, a)
|
2012-05-30 07:52:37 -07:00
|
|
|
) lid_a_list 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-24 05:03:00 -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
|
|
|
|
|
|
|
let lid_of_label label =
|
|
|
|
match repr label.lbl_res with
|
|
|
|
| {desc = Tconstr(Path.Pdot(mpath,_,_),_,_)} ->
|
|
|
|
Longident.Ldot(lid_of_path mpath, label.lbl_name)
|
|
|
|
| _ -> Longident.Lident label.lbl_name
|
2004-06-14 14:29:05 -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)
|
2012-11-14 08:59:33 -08:00
|
|
|
then raise(Error(loc, 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
|
|
|
|
|
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;
|
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;
|
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;
|
|
|
|
pat_extra=[Tpat_unpack, loc];
|
2011-07-29 03:32:43 -07:00
|
|
|
pat_type = expected_ty;
|
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;
|
|
|
|
pat_extra = [Tpat_constraint cty, loc];
|
|
|
|
pat_type = ty;
|
|
|
|
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;
|
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 {
|
|
|
|
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;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
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;
|
2010-09-18 21:55:40 -07:00
|
|
|
pat_env = !env }
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_construct(lid, sarg, explicit_arity) ->
|
2012-10-24 05:03:00 -07:00
|
|
|
let constr =
|
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 ->
|
|
|
|
Hashtbl.find constrs s
|
2012-05-30 07:52:37 -07:00
|
|
|
| _ -> Typetexp.find_constructor !env loc lid.txt
|
2010-09-20 22:30:25 -07:00
|
|
|
in
|
2012-05-31 01:07:31 -07:00
|
|
|
Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr;
|
2010-12-13 22:33:06 -08:00
|
|
|
if no_existentials && constr.cstr_existentials <> [] then
|
|
|
|
raise (Error (loc, 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 -> []
|
1997-06-16 11:10:35 -07:00
|
|
|
| Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl
|
1995-05-04 03:15:53 -07:00
|
|
|
| Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> 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-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc, 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 {
|
2012-10-24 05:03:00 -07:00
|
|
|
pat_desc=Tpat_construct(lid, constr, args,explicit_arity);
|
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;
|
|
|
|
pat_env = !env }
|
2011-10-25 06:13:54 -07:00
|
|
|
| Ppat_variant(l, sarg) ->
|
2010-12-13 22:33:06 -08:00
|
|
|
let arg = may_map (fun p -> type_pat p (newvar())) sarg in
|
1999-11-30 08:07:38 -08:00
|
|
|
let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
|
2001-03-02 16:14:35 -08:00
|
|
|
let row = { row_fields =
|
|
|
|
[l, Reither(arg = 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;
|
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;
|
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-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
|
2010-10-15 23:09:25 -07:00
|
|
|
unify_pat_types loc !env ty_res expected_ty
|
1996-05-20 09:43:29 -07:00
|
|
|
with Unify trace ->
|
2011-06-15 02:26:30 -07:00
|
|
|
raise(Error(loc, Label_mismatch(lid_of_label label, 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
|
2011-06-15 02:26:30 -07:00
|
|
|
raise (Error(loc, Polymorphic_label (lid_of_label label)))
|
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 =
|
2012-06-13 16:45:01 -07:00
|
|
|
type_label_a_list ?labels !env type_label_pat lid_sp_list in
|
2009-09-12 05:41:07 -07:00
|
|
|
check_recordpat_labels loc lbl_pat_list closed;
|
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;
|
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;
|
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;
|
|
|
|
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;
|
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;
|
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;
|
2012-05-30 07:52:37 -07:00
|
|
|
pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id,s);
|
|
|
|
pat_extra = [Tpat_constraint cty, loc];
|
|
|
|
}
|
2012-05-31 01:07:31 -07:00
|
|
|
| _ -> {p with pat_type = ty;
|
|
|
|
pat_extra = (Tpat_constraint cty,loc) :: 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;
|
2012-05-30 07:52:37 -07:00
|
|
|
{ p with pat_extra = (Tpat_type (path, lid), loc) :: p.pat_extra }
|
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
|
|
|
|
{val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env
|
|
|
|
)
|
|
|
|
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);
|
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)
|
|
|
|
|
1998-11-29 09:34:05 -08:00
|
|
|
let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
|
2003-11-25 01:20:45 -08:00
|
|
|
|
|
|
|
let type_self_pattern cl_num privty val_env met_env par_env spat =
|
2005-08-13 13:59:37 -07:00
|
|
|
let spat =
|
2012-05-30 07:52:37 -07:00
|
|
|
mkpat (Ppat_alias (mkpat(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;
|
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);
|
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;
|
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-05-30 07:52:37 -07:00
|
|
|
let fst3 (x, _, _) = x
|
|
|
|
let snd3 (_, x, _) = x
|
1997-03-07 14:00:19 -08: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, _)
|
|
|
|
| Pexp_match (_, (_, e) :: _)
|
|
|
|
-> 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) ->
|
2000-06-01 06:14:36 -07:00
|
|
|
List.for_all (fun (pat, exp) -> is_nonexpansive exp) 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)
|
1995-05-04 03:15:53 -07:00
|
|
|
| Texp_tuple el ->
|
|
|
|
List.for_all is_nonexpansive el
|
2012-10-24 05:03:00 -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
|
2012-05-30 07:52:37 -07:00
|
|
|
| Texp_object ({cstr_fields=fields; cstr_type = { cty_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
|
|
|
|
Tcf_meth _ -> true
|
|
|
|
| Tcf_val (_,_, _, _, Tcfk_concrete e,_) ->
|
|
|
|
incr count; is_nonexpansive e
|
|
|
|
| Tcf_val (_,_, _, _, Tcfk_virtual _,_) ->
|
|
|
|
incr count; true
|
|
|
|
| Tcf_init e -> is_nonexpansive e
|
|
|
|
| Tcf_constr _ -> true
|
|
|
|
| Tcf_inher _ -> false)
|
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
|
2010-08-02 07:37:22 -07:00
|
|
|
| Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tstr_open _ | Tstr_class_type _ | Tstr_exn_rebind _ -> true
|
2010-08-02 07:37:22 -07:00
|
|
|
| Tstr_value (_, pat_exp_list) ->
|
|
|
|
List.for_all (fun (_, exp) -> is_nonexpansive exp) pat_exp_list
|
2012-05-30 07:52:37 -07:00
|
|
|
| Tstr_module (_, _, m) | Tstr_include (m, _) -> is_nonexpansive_mod m
|
2010-08-02 07:37:22 -07:00
|
|
|
| Tstr_recmodule id_mod_list ->
|
2012-05-31 01:07:31 -07:00
|
|
|
List.for_all (fun (_, _, _, m) -> is_nonexpansive_mod m)
|
|
|
|
id_mod_list
|
2010-08-02 07:37:22 -07:00
|
|
|
| Tstr_exception _ -> false (* true would be unsound *)
|
|
|
|
| Tstr_class _ -> false (* could be more precise *)
|
|
|
|
)
|
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 =
|
|
|
|
raise (Error (loc, Bad_conversion (fmt, i, c))) in
|
|
|
|
let incomplete_format fmt =
|
|
|
|
raise (Error (loc, Incomplete_format fmt)) in
|
|
|
|
|
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
|
|
|
|
| Pexp_function (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))
|
1999-11-30 08:07:38 -08:00
|
|
|
| Pexp_function (p,_,(_,e)::_) ->
|
2001-04-19 01:34:21 -07:00
|
|
|
newty (Tarrow(p, newvar (), type_approx env e, Cok))
|
1999-11-30 08:07:38 -08:00
|
|
|
| Pexp_match (_, (_,e)::_) -> type_approx env e
|
|
|
|
| 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
|
2000-06-11 22:22:13 -07:00
|
|
|
| Pexp_constraint (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
|
2005-04-03 21:34:53 -07:00
|
|
|
and ty2 = approx_ty_opt sty2 in
|
|
|
|
begin try unify env ty ty1 with Unify trace ->
|
|
|
|
raise(Error(sexp.pexp_loc, Expr_type_clash trace))
|
|
|
|
end;
|
|
|
|
if sty2 = None then ty1 else 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
|
|
|
|
|
|
|
let list_labels env ty = list_labels_aux env [] [] ty
|
|
|
|
|
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
|
|
|
|
raise (Error (exp.exp_loc,
|
|
|
|
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 =
|
|
|
|
List.fold_left
|
|
|
|
(fun sexp (name, loc) ->
|
|
|
|
{pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule (
|
|
|
|
name,
|
|
|
|
{pmod_loc = loc; pmod_desc = Pmod_unpack
|
2012-05-31 01:07:31 -07:00
|
|
|
{pexp_desc=Pexp_ident(mkloc (Longident.Lident name.txt) name.loc);
|
|
|
|
pexp_loc=name.loc}},
|
2011-11-24 01:02:48 -08:00
|
|
|
sexp)})
|
|
|
|
sexp unpacks
|
|
|
|
|
|
|
|
(* Helpers for type_cases *)
|
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
|
2012-05-30 07:52:37 -07:00
|
|
|
| Ppat_any | Ppat_var _ | Ppat_constant _
|
|
|
|
| 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
|
2011-11-24 01:02:48 -08: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
|
2011-10-25 05:11:06 -07:00
|
|
|
| Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p
|
|
|
|
| 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
|
|
|
|
Ppat_construct (lid, _, _) ->
|
|
|
|
begin try
|
2012-10-24 05:03:00 -07:00
|
|
|
let cstr = Env.lookup_constructor lid.txt env in
|
2012-05-30 07:52:37 -07:00
|
|
|
if cstr.cstr_generalized then raise Exit
|
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
|
|
|
|
|
|
|
|
let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
|
|
|
|
|
|
|
|
(* 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 =
|
|
|
|
List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
|
2012-01-20 06:26:15 -08:00
|
|
|
let idents = all_idents (List.map snd 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
|
|
|
|
let exp = type_expect_ ?in_function env sexp ty_expected in
|
|
|
|
Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types);
|
|
|
|
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-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc, Masked_instance_variable lid.txt))
|
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;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
end
|
2010-11-11 19:09:11 -08:00
|
|
|
| Pexp_constant(Const_string s as cst) ->
|
|
|
|
rue {
|
|
|
|
exp_desc = Texp_constant cst;
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_loc = loc; exp_extra = [];
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_type =
|
|
|
|
(* Terrible hack for format strings *)
|
|
|
|
begin match (repr (expand_head env ty_expected)).desc with
|
|
|
|
Tconstr(path, _, _) when Path.same path Predef.path_format6 ->
|
|
|
|
type_format loc s
|
2011-11-24 01:02:48 -08:00
|
|
|
| _ -> instance_def Predef.type_string
|
2010-11-11 19:09:11 -08:00
|
|
|
end;
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_constant cst ->
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2003-04-01 17:32:09 -08: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;
|
|
|
|
exp_env = env }
|
2011-11-24 01:02:48 -08:00
|
|
|
| Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
|
|
|
|
type_expect ?in_function env
|
|
|
|
{sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
|
|
|
|
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 =
|
|
|
|
match rec_flag with
|
2009-09-04 09:19:35 -07:00
|
|
|
| Recursive -> Some (Annot.Idef loc)
|
2007-05-16 01:21:41 -07:00
|
|
|
| Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
|
|
|
|
| Default -> None
|
|
|
|
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;
|
|
|
|
exp_env = env }
|
2010-11-11 19:09:11 -08:00
|
|
|
| Pexp_function (l, Some default, [spat, sbody]) ->
|
|
|
|
let default_loc = default.pexp_loc in
|
|
|
|
let scases = [
|
|
|
|
{ppat_loc = default_loc;
|
|
|
|
ppat_desc =
|
|
|
|
Ppat_construct
|
2012-05-30 07:52:37 -07:00
|
|
|
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))),
|
2012-05-31 01:07:31 -07:00
|
|
|
Some {ppat_loc = default_loc;
|
|
|
|
ppat_desc = Ppat_var (mknoloc "*sth*")},
|
2010-11-15 22:01:59 -08:00
|
|
|
false)},
|
2010-11-11 19:09:11 -08:00
|
|
|
{pexp_loc = default_loc;
|
2012-05-30 07:52:37 -07:00
|
|
|
pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*sth*"))};
|
2010-11-11 19:09:11 -08:00
|
|
|
{ppat_loc = default_loc;
|
|
|
|
ppat_desc = Ppat_construct
|
2012-05-30 07:52:37 -07:00
|
|
|
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))),
|
|
|
|
None, false)},
|
2010-11-11 19:09:11 -08:00
|
|
|
default;
|
|
|
|
] in
|
|
|
|
let smatch = {
|
|
|
|
pexp_loc = loc;
|
|
|
|
pexp_desc =
|
|
|
|
Pexp_match ({
|
|
|
|
pexp_loc = loc;
|
2012-05-30 07:52:37 -07:00
|
|
|
pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*opt*"))
|
2010-11-11 19:09:11 -08:00
|
|
|
},
|
|
|
|
scases
|
|
|
|
)
|
|
|
|
} in
|
|
|
|
let sfun = {
|
|
|
|
pexp_loc = loc;
|
|
|
|
pexp_desc =
|
|
|
|
Pexp_function (
|
|
|
|
l, None,
|
|
|
|
[ {ppat_loc = loc;
|
2012-05-30 07:52:37 -07:00
|
|
|
ppat_desc = Ppat_var (mknoloc "*opt*")},
|
2010-11-11 19:09:11 -08:00
|
|
|
{pexp_loc = loc;
|
|
|
|
pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
|
|
|
|
}
|
|
|
|
]
|
|
|
|
)
|
|
|
|
} in
|
|
|
|
type_expect ?in_function env sfun ty_expected
|
|
|
|
| Pexp_function (l, _, caselist) ->
|
|
|
|
let (loc_fun, ty_fun) =
|
|
|
|
match in_function with Some p -> p
|
2011-11-24 01:02:48 -08:00
|
|
|
| None -> (loc, instance env ty_expected)
|
2010-11-11 19:09:11 -08:00
|
|
|
in
|
2011-11-24 01:02:48 -08:00
|
|
|
let separate = !Clflags.principal || Env.has_local_constraints env in
|
|
|
|
if separate then begin_def ();
|
2010-11-11 19:09:11 -08:00
|
|
|
let (ty_arg, ty_res) =
|
2011-11-24 01:02:48 -08:00
|
|
|
try filter_arrow env (instance env ty_expected) l
|
2010-11-11 19:09:11 -08:00
|
|
|
with Unify _ ->
|
|
|
|
match expand_head env ty_expected with
|
|
|
|
{desc = Tarrow _} as ty ->
|
|
|
|
raise(Error(loc, Abstract_wrong_label(l, ty)))
|
|
|
|
| _ ->
|
|
|
|
raise(Error(loc_fun,
|
|
|
|
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
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin
|
2010-11-11 19:09:11 -08:00
|
|
|
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 (fst (List.hd cases)).pat_loc
|
|
|
|
Warnings.Unerasable_optional_argument;
|
|
|
|
re {
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_desc = Texp_function(l,cases, partial);
|
|
|
|
exp_loc = loc; exp_extra = [];
|
2011-11-24 01:02:48 -08:00
|
|
|
exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env }
|
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 ();
|
2006-08-11 15:40:19 -07:00
|
|
|
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;
|
|
|
|
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;
|
2000-11-06 01:49:27 -08:00
|
|
|
let cases, partial =
|
2010-11-11 19:09:11 -08:00
|
|
|
type_cases env arg.exp_type ty_expected true loc caselist
|
2002-11-20 21:39:01 -08:00
|
|
|
in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_match(arg, 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;
|
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;
|
|
|
|
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));
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1997-06-16 11:10:35 -07:00
|
|
|
| Pexp_construct(lid, sarg, explicit_arity) ->
|
2010-11-11 19:09:11 -08:00
|
|
|
type_construct env loc lid sarg explicit_arity ty_expected
|
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;
|
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});
|
|
|
|
exp_env = env }
|
|
|
|
end
|
1998-04-27 08:17:11 -07:00
|
|
|
| Pexp_record(lid_sexp_list, opt_sexp) ->
|
2010-08-02 07:37:22 -07:00
|
|
|
let lbl_exp_list =
|
2012-06-13 16:45:01 -07:00
|
|
|
type_label_a_list env (type_label_exp true env loc ty_expected)
|
2010-11-11 19:09:11 -08:00
|
|
|
lid_sexp_list in
|
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 *)
|
|
|
|
let rec check_duplicates seen_pos = function
|
|
|
|
| (_, lbl, _) :: (_, lbl, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos ->
|
|
|
|
raise(Error(loc, Label_multiply_defined lbl1.lbl_name))
|
|
|
|
| _ :: rem ->
|
|
|
|
check_duplicates rem
|
|
|
|
| [] -> ()
|
|
|
|
in
|
|
|
|
check_duplicates lbl_exp_list;
|
1998-04-27 08:17:11 -07:00
|
|
|
let opt_exp =
|
2000-06-12 23:59:29 -07:00
|
|
|
match opt_sexp, lbl_exp_list with
|
|
|
|
None, _ -> None
|
2012-10-24 05:03:00 -07:00
|
|
|
| Some sexp, (_, lbl, _) :: _ ->
|
2010-11-11 19:09:11 -08:00
|
|
|
if !Clflags.principal then begin_def ();
|
2000-06-12 23:59:29 -07:00
|
|
|
let ty_exp = newvar () in
|
|
|
|
let unify_kept lbl =
|
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
|
2000-06-12 23:59:29 -07:00
|
|
|
unify env ty_exp ty_res1;
|
2011-11-24 01:02:48 -08:00
|
|
|
unify env (instance env ty_expected) ty_res2;
|
2000-06-12 23:59:29 -07:00
|
|
|
unify env ty_arg1 ty_arg2
|
|
|
|
end in
|
|
|
|
Array.iter unify_kept lbl.lbl_all;
|
2010-11-11 19:09:11 -08:00
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure ty_exp
|
|
|
|
end;
|
2000-06-12 23:59:29 -07:00
|
|
|
Some(type_expect env sexp ty_exp)
|
|
|
|
| _ -> 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
|
2009-09-04 09:19:35 -07:00
|
|
|
raise(Error(loc, 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;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_field(sarg, lid) ->
|
|
|
|
let arg = type_exp env sarg in
|
2012-10-24 05:03:00 -07:00
|
|
|
let label = Typetexp.find_label env loc lid.txt in
|
2002-04-18 00:27:47 -07:00
|
|
|
let (_, ty_arg, ty_res) = instance_label false label in
|
1995-05-04 03:15:53 -07:00
|
|
|
unify_exp env arg ty_res;
|
2010-11-11 19:09:11 -08:00
|
|
|
rue {
|
2012-10-24 05:03:00 -07:00
|
|
|
exp_desc = Texp_field(arg, 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;
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_setfield(srecord, lid, snewval) ->
|
|
|
|
let record = type_exp env srecord in
|
2012-10-24 05:03:00 -07:00
|
|
|
let label = Typetexp.find_label env loc lid.txt in
|
|
|
|
let (label_loc, label, newval) =
|
2012-05-31 01:07:31 -07:00
|
|
|
type_label_exp false env loc record.exp_type
|
2012-10-24 05:03:00 -07:00
|
|
|
(lid, label, snewval) in
|
1995-05-04 03:15:53 -07:00
|
|
|
if label.lbl_mut = Immutable then
|
2012-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc, 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;
|
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;
|
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;
|
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;
|
|
|
|
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;
|
|
|
|
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;
|
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
|
1995-05-04 03:15:53 -07:00
|
|
|
let (id, new_env) =
|
2012-05-30 07:52:37 -07:00
|
|
|
Env.enter_value param.txt {val_type = instance_def Predef.type_int;
|
|
|
|
val_kind = Val_reg; Types.val_loc = loc; } env
|
2011-12-29 09:49:58 -08:00
|
|
|
~check:(fun s -> Warnings.Unused_for_index s)
|
|
|
|
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;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1996-04-22 04:15:41 -07:00
|
|
|
| Pexp_constraint(sarg, sty, sty') ->
|
2012-05-30 07:52:37 -07:00
|
|
|
|
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') =
|
1996-04-22 04:15:41 -07:00
|
|
|
match (sty, sty') with
|
1997-05-19 08:42:21 -07:00
|
|
|
(None, None) -> (* Case actually unused *)
|
1996-05-26 06:42:34 -07:00
|
|
|
let arg = type_exp env sarg in
|
2012-05-30 07:52:37 -07:00
|
|
|
(arg, arg.exp_type,None,None)
|
1997-05-19 08:42:21 -07:00
|
|
|
| (Some sty, None) ->
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin_def ();
|
2012-05-30 07:52:37 -07:00
|
|
|
let cty = Typetexp.transl_simple_type env false sty in
|
|
|
|
let ty = cty.ctyp_type in
|
2011-11-24 01:02:48 -08:00
|
|
|
if separate then begin
|
2002-04-18 00:27:47 -07:00
|
|
|
end_def ();
|
|
|
|
generalize_structure ty;
|
2012-05-31 01:07:31 -07:00
|
|
|
(type_argument env sarg ty (instance env ty),
|
|
|
|
instance env ty, Some cty, None)
|
2002-04-18 00:27:47 -07:00
|
|
|
end else
|
2012-05-30 07:52:37 -07:00
|
|
|
(type_argument env sarg ty ty, ty, Some cty, None)
|
1997-05-19 08:42:21 -07:00
|
|
|
| (None, Some sty') ->
|
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"; *)
|
2009-09-04 09:19:35 -07:00
|
|
|
raise(Error(loc, 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 ->
|
|
|
|
raise(Error(sarg.pexp_loc,
|
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;
|
2012-05-30 07:52:37 -07:00
|
|
|
(arg, ty', None, Some cty')
|
1997-05-19 08:42:21 -07:00
|
|
|
| (Some sty, 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) ->
|
2009-09-04 09:19:35 -07:00
|
|
|
raise(Error(loc, 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),
|
|
|
|
instance env ty', Some cty, Some cty')
|
2010-10-21 16:59:33 -07:00
|
|
|
end else
|
2012-05-30 07:52:37 -07:00
|
|
|
(type_argument env sarg ty ty, ty', Some cty, Some 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';
|
2012-05-30 07:52:37 -07:00
|
|
|
exp_env = env;
|
|
|
|
exp_extra = (Texp_constraint (cty, cty'), loc) :: arg.exp_extra;
|
|
|
|
}
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_when(scond, sbody) ->
|
2010-11-11 19:09:11 -08:00
|
|
|
let cond = type_expect env scond Predef.type_bool in
|
|
|
|
let body = type_expect env sbody ty_expected in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_when(cond, 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;
|
|
|
|
exp_env = env }
|
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 ->
|
|
|
|
raise(Error(e.pexp_loc, Undefined_inherited_method met))
|
|
|
|
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;
|
|
|
|
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;
|
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;
|
|
|
|
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;
|
|
|
|
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;
|
|
|
|
exp_env = env }
|
1996-05-20 09:43:29 -07:00
|
|
|
with Unify _ ->
|
1998-06-24 12:22:26 -07:00
|
|
|
raise(Error(e.pexp_loc, 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
|
1998-06-24 12:22:26 -07:00
|
|
|
begin match cl_decl.cty_new with
|
1997-05-19 08:42:21 -07:00
|
|
|
None ->
|
2012-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc, 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;
|
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;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1997-05-19 08:42:21 -07:00
|
|
|
| Val_ivar _ ->
|
2012-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc,Instance_variable_not_mutable(true,lab.txt)))
|
1997-05-19 08:42:21 -07:00
|
|
|
| _ ->
|
2012-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc,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-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc, 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
|
2009-09-04 09:19:35 -07:00
|
|
|
raise(Error(loc,
|
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 ->
|
2009-09-04 09:19:35 -07:00
|
|
|
raise(Error(loc, 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-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc, 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;
|
|
|
|
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-05-30 07:52:37 -07:00
|
|
|
raise(Error(loc, 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;
|
|
|
|
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
|
|
|
|
rue {
|
|
|
|
exp_desc = Texp_assert (cond);
|
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;
|
2010-11-11 19:09:11 -08:00
|
|
|
exp_env = env;
|
|
|
|
}
|
2000-12-04 07:37:05 -08:00
|
|
|
| Pexp_assertfalse ->
|
2010-11-11 19:09:11 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_assertfalse;
|
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;
|
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;
|
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 = [];
|
2003-11-25 01:20:45 -08:00
|
|
|
exp_type = sign.cty_self;
|
|
|
|
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 ->
|
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
|
2012-07-10 01:25:58 -07:00
|
|
|
re { exp with exp_extra = (Texp_poly cty, loc) :: 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;
|
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;
|
|
|
|
exp_extra = (Texp_newtype name, loc) :: 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 _} ->
|
2010-11-11 19:09:11 -08:00
|
|
|
raise (Error (loc, Cannot_infer_signature))
|
|
|
|
| _ ->
|
|
|
|
raise (Error (loc, Not_a_packed_module ty_expected))
|
|
|
|
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'));
|
|
|
|
exp_env = env }
|
2009-11-01 13:52:29 -08:00
|
|
|
| Pexp_open (lid, e) ->
|
2012-05-30 07:52:37 -07:00
|
|
|
let (path, newenv) = !type_open env sexp.pexp_loc lid in
|
|
|
|
let exp = type_expect newenv e ty_expected in
|
|
|
|
{ exp with
|
|
|
|
exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra;
|
|
|
|
}
|
1996-04-22 04:15:41 -07:00
|
|
|
|
2012-05-30 07:52: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 ->
|
2012-06-13 16:45:01 -07:00
|
|
|
raise (Error(lid.loc, Label_mismatch(lid_of_label label, 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
|
|
|
|
raise (Error(loc, Private_type ty_expected))
|
|
|
|
else
|
|
|
|
raise (Error(lid.loc, Private_label(lid_of_label label, 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
|
|
|
|
with Error (_, Less_general _) as e -> raise e
|
|
|
|
| _ -> 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
|
|
|
|
Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true
|
|
|
|
| Pexp_open (_, e) -> is_inferred e
|
|
|
|
| _ -> 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 ->
|
2001-12-05 16:19:35 -08:00
|
|
|
args, ty_fun, no_labels ty_res'
|
2011-09-22 02:05:42 -07:00
|
|
|
| Tvar _ -> 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=[];
|
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;
|
|
|
|
exp_extra = [];
|
|
|
|
exp_desc =
|
|
|
|
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
|
|
|
|
{val_type = ty; val_kind = Val_reg;
|
|
|
|
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 =
|
|
|
|
{ texp with exp_type = ty_fun; exp_desc =
|
2012-05-30 07:52:37 -07:00
|
|
|
Texp_function("", [eta_pat, {texp with exp_type = ty_res; exp_desc =
|
|
|
|
Texp_apply (texp,
|
2012-09-10 06:00:01 -07:00
|
|
|
List.rev args @ ["", Some eta_var, Required])}],
|
1999-11-30 08:07:38 -08:00
|
|
|
Total) } in
|
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 *)
|
|
|
|
let let_pat, let_var = var_pair "let" texp.exp_type in
|
2003-04-01 17:32:09 -08:00
|
|
|
re { texp with exp_type = ty_fun; exp_desc =
|
|
|
|
Texp_let (Nonrecursive, [let_pat, texp], 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
|
|
|
|
raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res)))
|
|
|
|
else
|
|
|
|
raise(Error(funct.exp_loc, Incoherent_label_order))
|
|
|
|
| _ ->
|
2002-05-12 23:56:08 -07:00
|
|
|
raise(Error(funct.exp_loc, Apply_non_function
|
|
|
|
(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) :: _, _ ->
|
|
|
|
raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_old)))
|
|
|
|
| _, (l', sarg0) :: more_sargs ->
|
|
|
|
if l <> l' && l' <> "" then
|
|
|
|
raise(Error(sarg0.pexp_loc, 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
|
|
|
|
sargs, more_sargs,
|
2000-09-04 01:49:32 -07:00
|
|
|
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 ->
|
2003-01-21 04:57:33 -08:00
|
|
|
raise(Error(sarg0.pexp_loc, 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
|
|
|
|
|
|
|
and type_construct env loc lid sarg explicit_arity ty_expected =
|
2012-10-24 05:03:00 -07:00
|
|
|
let constr = Typetexp.find_constructor env loc lid.txt in
|
2012-05-31 01:07:31 -07:00
|
|
|
Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
|
1999-11-30 08:07:38 -08:00
|
|
|
let sargs =
|
|
|
|
match sarg with
|
|
|
|
None -> []
|
|
|
|
| Some {pexp_desc = Pexp_tuple sel} when explicit_arity -> sel
|
|
|
|
| Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
|
|
|
|
| Some se -> [se] in
|
|
|
|
if List.length sargs <> constr.cstr_arity then
|
|
|
|
raise(Error(loc, 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 {
|
2012-10-24 05:03:00 -07:00
|
|
|
exp_desc = Texp_construct(lid, constr, [],explicit_arity);
|
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;
|
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
|
|
|
|
raise(Error(loc, Private_type ty_res));
|
2012-05-31 01:07:31 -07:00
|
|
|
{ texp with
|
2012-10-24 05:03:00 -07:00
|
|
|
exp_desc = Texp_construct(lid, constr, args, explicit_arity) }
|
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 *)
|
|
|
|
|
2010-11-08 23:11:08 -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 *)
|
|
|
|
let dont_propagate, has_gadts =
|
|
|
|
let patterns = List.map fst caselist in
|
|
|
|
List.exists contains_polymorphic_variant patterns,
|
|
|
|
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"); *)
|
2011-11-24 01:02:48 -08:00
|
|
|
let ty_arg, ty_res, env =
|
|
|
|
if has_gadts && not !Clflags.principal then
|
|
|
|
correct_levels ty_arg, correct_levels ty_res,
|
|
|
|
duplicate_ident_types loc caselist env
|
|
|
|
else ty_arg, ty_res, env in
|
|
|
|
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
|
|
|
|
(fun (spat, sexp) ->
|
2009-09-04 09:19:35 -07:00
|
|
|
let loc = sexp.pexp_loc 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 =
|
|
|
|
if !Clflags.principal then Some false else None in
|
2010-12-13 22:33:06 -08:00
|
|
|
let ty_arg =
|
2011-11-24 01:02:48 -08:00
|
|
|
if dont_propagate then newvar () else instance ?partial env ty_arg
|
2011-10-25 05:11:06 -07:00
|
|
|
in type_pattern ~lev env spat scope ty_arg
|
|
|
|
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
|
2000-05-12 11:22:35 -07:00
|
|
|
unify_pat env pat ty_arg';
|
2010-10-21 16:59:33 -07:00
|
|
|
(pat, (ext_env, unpacks)))
|
2000-05-12 11:22:35 -07:00
|
|
|
caselist in
|
2003-08-18 01:26:18 -07:00
|
|
|
(* Check for polymorphic variants to close *)
|
|
|
|
let patl = List.map fst pat_env_list in
|
|
|
|
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 *)
|
|
|
|
let patl = List.map fst pat_env_list in
|
|
|
|
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
|
2010-10-21 16:59:33 -07:00
|
|
|
(fun (pat, (ext_env, unpacks)) (spat, sexp) ->
|
|
|
|
let sexp = wrap_unpacks sexp 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
|
|
|
|
else if contains_gadt env spat then correct_levels ty_res
|
|
|
|
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'; *)
|
2010-11-08 22:23:53 -08:00
|
|
|
let exp = type_expect ?in_function ext_env sexp ty_res' in
|
2011-11-24 01:02:48 -08:00
|
|
|
(pat, {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
|
2010-11-08 22:23:53 -08:00
|
|
|
List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases
|
|
|
|
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
|
2002-05-26 20:09:18 -07:00
|
|
|
add_delayed_check (fun () -> 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 =
|
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
|
2012-02-14 02:00:18 -08:00
|
|
|
| [_, {pexp_desc=Pexp_match(
|
2012-05-30 07:52:37 -07:00
|
|
|
{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
|
|
|
|
(fun (spat, sexp) ->
|
|
|
|
match spat.ppat_desc, sexp.pexp_desc with
|
2011-04-18 19:34:54 -07:00
|
|
|
(Ppat_any | Ppat_constraint _), _ -> spat
|
2011-04-18 19:13:52 -07:00
|
|
|
| _, Pexp_constraint (_, _, Some sty)
|
2011-04-18 19:34:54 -07:00
|
|
|
| _, Pexp_constraint (_, Some sty, None) when !Clflags.principal ->
|
|
|
|
(* propagate type annotation to pattern,
|
|
|
|
to allow it to be generalized in -principal mode *)
|
2012-03-27 17:35:41 -07:00
|
|
|
{ppat_desc = Ppat_constraint (spat, sty);
|
2011-04-18 19:13:52 -07:00
|
|
|
ppat_loc = {spat.ppat_loc with Location.loc_ghost=true}}
|
|
|
|
| _ -> 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
|
2009-10-26 00:11:36 -07:00
|
|
|
(fun pat (_, sexp) ->
|
|
|
|
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
|
|
|
|
in unify_pat env pat (type_approx env sexp))
|
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
|
2011-12-21 07:40:54 -08:00
|
|
|
(fun (spat, 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
|
2012-05-29 05:30:49 -07:00
|
|
|
Location.prerr_warning (fst (List.hd spat_sexp_list)).ppat_loc
|
|
|
|
Warnings.Unused_rec_flag;
|
1995-05-04 03:15:53 -07:00
|
|
|
List.iter2
|
2003-08-18 01:26:18 -07:00
|
|
|
(fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [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;
|
2010-10-21 16:59:33 -07:00
|
|
|
(List.combine pat_list exp_list, 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
|
|
|
|
|
2000-03-06 14:12:09 -08:00
|
|
|
let report_error ppf = function
|
2007-02-26 19:46:19 -08:00
|
|
|
| Polymorphic_label lid ->
|
|
|
|
fprintf ppf "@[The record field label %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) ->
|
2000-03-06 14:12:09 -08:00
|
|
|
report_unification_error ppf trace
|
|
|
|
(function ppf ->
|
2000-03-16 08:44:21 -08:00
|
|
|
fprintf ppf "The record field label %a@ belongs to the type"
|
|
|
|
longident lid)
|
2000-03-06 14:12:09 -08:00
|
|
|
(function ppf ->
|
2009-05-20 04:52:42 -07:00
|
|
|
fprintf ppf "but is mixed here with labels of type")
|
1996-05-20 09:43:29 -07:00
|
|
|
| Pattern_type_clash trace ->
|
2000-03-06 14:12:09 -08:00
|
|
|
report_unification_error ppf trace
|
|
|
|
(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")
|
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 ->
|
2000-03-06 14:12:09 -08:00
|
|
|
report_unification_error ppf trace
|
|
|
|
(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
|
2001-06-28 18:46:46 -07:00
|
|
|
fprintf ppf "@[<hov>Some record field labels are undefined:%a@]"
|
|
|
|
print_labels labels
|
1995-05-04 03:15:53 -07:00
|
|
|
| Label_not_mutable lid ->
|
2000-03-16 08:44:21 -08:00
|
|
|
fprintf ppf "The record field label %a is not mutable" longident lid
|
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) ->
|
2009-05-20 04:52:42 -07:00
|
|
|
report_subtyping_error ppf 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) ->
|
2000-03-06 14:12:09 -08:00
|
|
|
report_unification_error ppf trace
|
|
|
|
(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) ->
|
|
|
|
report_unification_error ppf trace
|
|
|
|
(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 ->
|
|
|
|
report_unification_error ppf trace
|
|
|
|
(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"
|
2011-12-21 07:40:54 -08:00
|
|
|
|
|
|
|
let () =
|
|
|
|
Env.add_delayed_check_forward := add_delayed_check
|