1995-08-09 08:06:35 -07:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
1996-04-30 07:53:58 -07:00
|
|
|
(* Objective Caml *)
|
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
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
|
|
|
|
|
|
|
(* $Id$ *)
|
|
|
|
|
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 =
|
|
|
|
Unbound_value of Longident.t
|
|
|
|
| Unbound_constructor of Longident.t
|
|
|
|
| Unbound_label of Longident.t
|
|
|
|
| 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
|
1995-05-04 03:15:53 -07:00
|
|
|
| Multiply_bound_variable
|
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
|
1995-05-04 03:15:53 -07:00
|
|
|
| Label_multiply_defined of Longident.t
|
2001-06-28 18:46:46 -07:00
|
|
|
| Label_missing of string 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
|
|
|
| Unbound_class of Longident.t
|
|
|
|
| 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
|
|
|
|
| Instance_variable_not_mutable of 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
|
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)
|
|
|
|
|
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 ->
|
|
|
|
class_structure * 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 =
|
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 =
|
2003-04-01 22:57:15 -08:00
|
|
|
Stypes.record (Stypes.Ti_pat node);
|
2003-04-01 17:32:09 -08:00
|
|
|
node
|
|
|
|
;;
|
|
|
|
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Typing of constants *)
|
|
|
|
|
|
|
|
let type_constant = function
|
1996-05-13 05:19:20 -07:00
|
|
|
Const_int _ -> instance Predef.type_int
|
|
|
|
| Const_char _ -> instance Predef.type_char
|
|
|
|
| Const_string _ -> instance Predef.type_string
|
|
|
|
| Const_float _ -> instance Predef.type_float
|
2003-04-25 05:27:31 -07:00
|
|
|
| Const_int32 _ -> instance Predef.type_int32
|
|
|
|
| Const_int64 _ -> instance Predef.type_int64
|
|
|
|
| Const_nativeint _ -> instance Predef.type_nativeint
|
|
|
|
|
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))
|
|
|
|
|
|
|
|
let option_none ty loc =
|
|
|
|
let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in
|
|
|
|
{ exp_desc = Texp_construct(cnone, []);
|
|
|
|
exp_type = ty; exp_loc = loc; exp_env = Env.initial }
|
|
|
|
|
|
|
|
let option_some texp =
|
|
|
|
let csome = Env.lookup_constructor (Longident.Lident "Some") Env.initial in
|
|
|
|
{ exp_desc = Texp_construct(csome, [texp]); exp_loc = texp.exp_loc;
|
|
|
|
exp_type = type_option texp.exp_type; exp_env = texp.exp_env }
|
|
|
|
|
|
|
|
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 =
|
2001-06-28 18:46:46 -07:00
|
|
|
let ty = repr ty in
|
|
|
|
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
|
2003-07-02 02:14:35 -07:00
|
|
|
| Type_record (fields, _, _) ->
|
|
|
|
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 *)
|
|
|
|
|
2000-05-11 19:52:55 -07:00
|
|
|
(* Creating new conjunctive types is not allowed when typing patterns *)
|
1995-05-04 03:15:53 -07:00
|
|
|
let unify_pat env pat expected_ty =
|
2000-05-12 11:22:35 -07:00
|
|
|
try
|
|
|
|
unify env pat.pat_type expected_ty
|
2002-01-03 18:02:50 -08:00
|
|
|
with
|
|
|
|
Unify trace ->
|
|
|
|
raise(Error(pat.pat_loc, Pattern_type_clash(trace)))
|
|
|
|
| Tags(l1,l2) ->
|
|
|
|
raise(Typetexp.Error(pat.pat_loc, Typetexp.Variant_tags (l1, l2)))
|
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
|
|
|
|
Tpat_variant(tag, opat, row) ->
|
|
|
|
let row = row_repr row in
|
2004-01-06 05:41:40 -08:00
|
|
|
let field = row_field tag row in
|
2003-08-18 01:26:18 -07:00
|
|
|
begin match field with
|
|
|
|
| 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
|
|
|
|
| Reither (c, l, true, e) when not row.row_fixed ->
|
|
|
|
set_row_field e (Reither (c, [], false, ref None))
|
|
|
|
| _ -> ()
|
|
|
|
end;
|
|
|
|
(* Force check of well-formedness *)
|
|
|
|
unify_pat pat.pat_env pat
|
|
|
|
(newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
|
|
|
|
row_bound=[]; row_fixed=false; row_name=None}));
|
|
|
|
| _ -> ()
|
|
|
|
|
|
|
|
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 *)
|
1995-05-04 03:15:53 -07:00
|
|
|
let pattern_variables = ref ([]: (Ident.t * type_expr) list)
|
2002-06-03 00:33:48 -07:00
|
|
|
let pattern_force = ref ([] : (unit -> unit) list)
|
|
|
|
let reset_pattern () =
|
|
|
|
pattern_variables := [];
|
|
|
|
pattern_force := []
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
let enter_variable loc name ty =
|
2000-10-02 07:18:05 -07:00
|
|
|
if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables
|
1995-05-04 03:15:53 -07:00
|
|
|
then raise(Error(loc, Multiply_bound_variable));
|
1996-04-22 04:15:41 -07:00
|
|
|
let id = Ident.create name in
|
1995-05-04 03:15:53 -07:00
|
|
|
pattern_variables := (id, ty) :: !pattern_variables;
|
|
|
|
id
|
|
|
|
|
2000-10-02 07:18:05 -07:00
|
|
|
let sort_pattern_variables vs =
|
|
|
|
List.sort
|
|
|
|
(fun (x,_) (y,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
|
|
|
|
vs
|
|
|
|
|
|
|
|
let enter_orpat_variables loc env p1_vs p2_vs =
|
|
|
|
(* unify_vars operate on sorted lists *)
|
|
|
|
|
|
|
|
let p1_vs = sort_pattern_variables p1_vs
|
|
|
|
and p2_vs = sort_pattern_variables p2_vs in
|
|
|
|
|
|
|
|
let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
|
|
|
|
| (x1,t1)::rem1, (x2,t2)::rem2 when Ident.equal x1 x2 ->
|
|
|
|
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)))
|
|
|
|
end ;
|
|
|
|
(x2,x1)::unify_vars rem1 rem2
|
|
|
|
end
|
|
|
|
| [],[] -> []
|
|
|
|
| (x,_)::_, [] -> raise (Error (loc, Orpat_vars x))
|
|
|
|
| [],(x,_)::_ -> raise (Error (loc, Orpat_vars x))
|
|
|
|
| (x,_)::_, (y,_)::_ ->
|
|
|
|
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
|
2000-06-29 02:11:42 -07:00
|
|
|
Tpat_alias(p1, _) -> build_as_type env p1
|
|
|
|
| Tpat_tuple pl ->
|
|
|
|
let tyl = List.map (build_as_type env) pl in
|
|
|
|
newty (Ttuple tyl)
|
|
|
|
| Tpat_construct(cstr, pl) ->
|
2005-02-18 05:38:00 -08:00
|
|
|
if cstr.cstr_private = Private 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();
|
2002-04-18 00:27:47 -07:00
|
|
|
row_bound=[]; row_name=None;
|
|
|
|
row_fixed=false; row_closed=false})
|
2000-06-29 02:11:42 -07:00
|
|
|
| Tpat_record lpl ->
|
|
|
|
let lbl = fst(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
|
2003-10-28 07:26:48 -08: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;
|
2003-10-28 07:26:48 -08:00
|
|
|
if lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl then begin
|
|
|
|
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
|
2001-09-25 02:54:18 -07:00
|
|
|
| Tpat_or(p1, p2, path) ->
|
2000-06-29 02:11:42 -07:00
|
|
|
let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in
|
|
|
|
unify_pat env {p2 with pat_type = ty2} ty1;
|
2001-09-25 02:54:18 -07:00
|
|
|
begin match path with None -> ()
|
|
|
|
| Some path ->
|
|
|
|
let td = try Env.find_type path env with Not_found -> assert false in
|
|
|
|
let params = List.map (fun _ -> newvar()) td.type_params in
|
|
|
|
match expand_head env (newty (Tconstr (path, params, ref Mnil)))
|
|
|
|
with {desc=Tvariant row} when static_row row ->
|
|
|
|
unify_pat env {p1 with pat_type = ty1}
|
|
|
|
(newty (Tvariant{row with row_closed=false; row_more=newvar()}))
|
|
|
|
| _ -> ()
|
|
|
|
end;
|
2000-06-29 02:11:42 -07:00
|
|
|
ty1
|
|
|
|
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ -> p.pat_type
|
2000-06-12 23:59:29 -07:00
|
|
|
|
2000-02-21 19:08:08 -08:00
|
|
|
let build_or_pat env loc lid =
|
|
|
|
let path, decl =
|
|
|
|
try Env.lookup_type lid env
|
|
|
|
with Not_found ->
|
|
|
|
raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid))
|
|
|
|
in
|
2000-02-24 02:18:25 -08:00
|
|
|
let tyl = List.map (fun _ -> newvar()) decl.type_params in
|
2000-02-21 19:08:08 -08:00
|
|
|
let fields =
|
2000-02-24 02:18:25 -08:00
|
|
|
let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
|
|
|
|
match ty.desc with
|
2000-02-21 19:08:08 -08:00
|
|
|
Tvariant row when static_row row ->
|
|
|
|
(row_repr row).row_fields
|
|
|
|
| _ -> raise(Error(loc, Not_a_variant_type lid))
|
|
|
|
in
|
|
|
|
let bound = ref [] 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) ->
|
|
|
|
bound := ty :: !bound;
|
2003-04-01 17:32:09 -08:00
|
|
|
(l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
|
|
|
|
pat_type=ty})
|
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)
|
|
|
|
([],[]) fields in
|
|
|
|
let row =
|
2000-02-22 18:57:15 -08:00
|
|
|
{ row_fields = List.rev fields; row_more = newvar(); row_bound = !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
|
2000-02-21 19:08:08 -08:00
|
|
|
let pats =
|
2002-05-26 20:09:18 -07:00
|
|
|
List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row); pat_loc=gloc;
|
2000-02-21 19:08:08 -08:00
|
|
|
pat_env=env; pat_type=ty})
|
|
|
|
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
|
2003-04-01 17:32:09 -08:00
|
|
|
(fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some path);
|
|
|
|
pat_loc=gloc; pat_env=env; pat_type=ty})
|
2003-02-24 07:13:01 -08:00
|
|
|
pat pats in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp { r with pat_loc = loc }
|
2000-02-21 19:08:08 -08:00
|
|
|
|
2004-06-14 14:29:05 -07:00
|
|
|
let rec find_record_qual = function
|
|
|
|
| [] -> None
|
|
|
|
| (Longident.Ldot (modname, _), _) :: _ -> Some modname
|
|
|
|
| _ :: rest -> find_record_qual rest
|
|
|
|
|
|
|
|
let type_label_a_list type_lid_a lid_a_list =
|
|
|
|
match find_record_qual lid_a_list with
|
|
|
|
| None -> List.map type_lid_a lid_a_list
|
|
|
|
| Some modname ->
|
|
|
|
List.map
|
|
|
|
(function
|
|
|
|
| (Longident.Lident id), sarg ->
|
|
|
|
type_lid_a (Longident.Ldot (modname, id), sarg)
|
|
|
|
| lid_a -> type_lid_a lid_a)
|
|
|
|
lid_a_list
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
let rec type_pat env sp =
|
|
|
|
match sp.ppat_desc with
|
|
|
|
Ppat_any ->
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_any;
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_type = newvar();
|
|
|
|
pat_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Ppat_var name ->
|
|
|
|
let ty = newvar() in
|
|
|
|
let id = enter_variable sp.ppat_loc name ty in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_var id;
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_type = ty;
|
|
|
|
pat_env = env }
|
2000-10-02 07:18:05 -07:00
|
|
|
| Ppat_alias(sq, name) ->
|
|
|
|
let q = type_pat env sq in
|
2000-06-29 02:11:42 -07:00
|
|
|
begin_def ();
|
2000-10-02 07:18:05 -07:00
|
|
|
let ty_var = build_as_type env q in
|
2000-06-29 02:11:42 -07:00
|
|
|
end_def ();
|
|
|
|
generalize ty_var;
|
1999-11-30 08:07:38 -08:00
|
|
|
let id = enter_variable sp.ppat_loc name ty_var in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_alias(q, id);
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
2000-10-02 07:18:05 -07:00
|
|
|
pat_type = q.pat_type;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Ppat_constant cst ->
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_constant cst;
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_type = type_constant cst;
|
|
|
|
pat_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Ppat_tuple spl ->
|
|
|
|
let pl = List.map (type_pat env) spl in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_tuple pl;
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
|
|
|
|
pat_env = env }
|
1997-06-16 11:10:35 -07:00
|
|
|
| Ppat_construct(lid, sarg, explicit_arity) ->
|
1995-05-04 03:15:53 -07:00
|
|
|
let constr =
|
|
|
|
try
|
|
|
|
Env.lookup_constructor lid env
|
|
|
|
with Not_found ->
|
|
|
|
raise(Error(sp.ppat_loc, Unbound_constructor lid)) in
|
|
|
|
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
|
1996-01-04 04:50:52 -08:00
|
|
|
| Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 ->
|
|
|
|
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
|
|
|
|
raise(Error(sp.ppat_loc, Constructor_arity_mismatch(lid,
|
|
|
|
constr.cstr_arity, List.length sargs)));
|
|
|
|
let args = List.map (type_pat env) sargs in
|
|
|
|
let (ty_args, ty_res) = instance_constructor constr in
|
|
|
|
List.iter2 (unify_pat env) args ty_args;
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_construct(constr, args);
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_type = ty_res;
|
|
|
|
pat_env = env }
|
1999-11-30 08:07:38 -08:00
|
|
|
| Ppat_variant(l, sarg) ->
|
|
|
|
let arg = may_map (type_pat env) sarg in
|
|
|
|
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)];
|
1999-11-30 08:07:38 -08:00
|
|
|
row_bound = arg_type;
|
|
|
|
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
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_variant(l, arg, row);
|
1999-11-30 08:07:38 -08:00
|
|
|
pat_loc = sp.ppat_loc;
|
|
|
|
pat_type = newty (Tvariant row);
|
|
|
|
pat_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Ppat_record lid_sp_list ->
|
1998-07-29 04:53:57 -07:00
|
|
|
let rec check_duplicates = function
|
|
|
|
[] -> ()
|
|
|
|
| (lid, sarg) :: remainder ->
|
|
|
|
if List.mem_assoc lid remainder
|
|
|
|
then raise(Error(sp.ppat_loc, Label_multiply_defined lid))
|
|
|
|
else check_duplicates remainder in
|
|
|
|
check_duplicates lid_sp_list;
|
1995-05-04 03:15:53 -07:00
|
|
|
let ty = newvar() in
|
|
|
|
let type_label_pat (lid, sarg) =
|
|
|
|
let label =
|
|
|
|
try
|
|
|
|
Env.lookup_label lid env
|
|
|
|
with Not_found ->
|
|
|
|
raise(Error(sp.ppat_loc, Unbound_label lid)) 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
|
|
|
begin try
|
2001-03-02 16:14:35 -08:00
|
|
|
unify env ty_res ty
|
1996-05-20 09:43:29 -07:00
|
|
|
with Unify trace ->
|
|
|
|
raise(Error(sp.ppat_loc, Label_mismatch(lid, trace)))
|
1995-05-04 03:15:53 -07:00
|
|
|
end;
|
|
|
|
let arg = type_pat env sarg in
|
|
|
|
unify_pat env arg ty_arg;
|
|
|
|
(label, arg)
|
|
|
|
in
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
2004-06-14 14:29:05 -07:00
|
|
|
pat_desc = Tpat_record(type_label_a_list type_label_pat lid_sp_list);
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_type = ty;
|
|
|
|
pat_env = env }
|
|
|
|
| Ppat_array spl ->
|
|
|
|
let pl = List.map (type_pat env) spl in
|
|
|
|
let ty_elt = newvar() in
|
|
|
|
List.iter (fun p -> unify_pat env p ty_elt) pl;
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_array pl;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
|
|
|
pat_type = instance (Predef.type_array ty_elt);
|
|
|
|
pat_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Ppat_or(sp1, sp2) ->
|
|
|
|
let initial_pattern_variables = !pattern_variables in
|
|
|
|
let p1 = type_pat env sp1 in
|
2000-10-02 07:18:05 -07:00
|
|
|
let p1_variables = !pattern_variables in
|
|
|
|
pattern_variables := initial_pattern_variables ;
|
1995-05-04 03:15:53 -07:00
|
|
|
let p2 = type_pat env sp2 in
|
2000-10-02 07:18:05 -07:00
|
|
|
let p2_variables = !pattern_variables in
|
1995-05-04 03:15:53 -07:00
|
|
|
unify_pat env p2 p1.pat_type;
|
2000-10-02 07:18:05 -07:00
|
|
|
let alpha_env =
|
|
|
|
enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in
|
|
|
|
pattern_variables := p1_variables ;
|
2003-04-01 17:32:09 -08:00
|
|
|
rp {
|
|
|
|
pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
|
1995-05-04 03:15:53 -07:00
|
|
|
pat_loc = sp.ppat_loc;
|
1998-04-06 02:23:01 -07:00
|
|
|
pat_type = p1.pat_type;
|
|
|
|
pat_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Ppat_constraint(sp, sty) ->
|
|
|
|
let p = type_pat env sp in
|
2002-06-03 00:33:48 -07:00
|
|
|
let ty, force = Typetexp.transl_simple_type_delayed env sty in
|
1995-05-04 03:15:53 -07:00
|
|
|
unify_pat env p ty;
|
2002-06-03 00:33:48 -07:00
|
|
|
pattern_force := force :: !pattern_force;
|
1995-05-04 03:15:53 -07:00
|
|
|
p
|
2000-02-21 19:08:08 -08:00
|
|
|
| Ppat_type lid ->
|
|
|
|
build_or_pat env sp.ppat_loc lid
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2002-06-03 00:33:48 -07:00
|
|
|
let get_ref r =
|
|
|
|
let v = !r in r := []; v
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
let add_pattern_variables env =
|
2002-06-03 00:33:48 -07:00
|
|
|
let pv = get_ref pattern_variables in
|
1995-05-04 03:15:53 -07:00
|
|
|
List.fold_right
|
|
|
|
(fun (id, ty) env ->
|
1998-06-24 12:22:26 -07:00
|
|
|
Env.add_value id {val_type = ty; val_kind = Val_reg} env)
|
1995-05-04 03:15:53 -07:00
|
|
|
pv env
|
|
|
|
|
|
|
|
let type_pattern env spat =
|
2002-06-03 00:33:48 -07:00
|
|
|
reset_pattern ();
|
1995-05-04 03:15:53 -07:00
|
|
|
let pat = type_pat env spat in
|
|
|
|
let new_env = add_pattern_variables env in
|
2002-06-03 00:33:48 -07:00
|
|
|
(pat, new_env, get_ref pattern_force)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
let type_pattern_list env spatl =
|
2002-06-03 00:33:48 -07:00
|
|
|
reset_pattern ();
|
1995-05-04 03:15:53 -07:00
|
|
|
let patl = List.map (type_pat env) spatl in
|
|
|
|
let new_env = add_pattern_variables env in
|
2002-06-03 00:33:48 -07:00
|
|
|
(patl, new_env, get_ref pattern_force)
|
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 =
|
2002-06-03 00:33:48 -07:00
|
|
|
reset_pattern ();
|
1998-06-24 12:22:26 -07:00
|
|
|
let pat = type_pat val_env spat 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
|
|
|
|
(fun (id, ty) (pv, env) ->
|
|
|
|
let id' = Ident.create (Ident.name id) in
|
|
|
|
((id', id, ty)::pv,
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.add_value id' {val_type = ty;
|
|
|
|
val_kind = Val_ivar (Immutable, cl_num)}
|
1998-06-24 12:22:26 -07:00
|
|
|
env))
|
|
|
|
!pattern_variables ([], met_env)
|
|
|
|
in
|
|
|
|
let val_env = add_pattern_variables val_env in
|
|
|
|
(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 =
|
1998-11-29 09:34:05 -08:00
|
|
|
let spat =
|
|
|
|
mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
|
|
|
|
"selfpat-" ^ cl_num))
|
|
|
|
in
|
2002-06-03 00:33:48 -07:00
|
|
|
reset_pattern ();
|
1998-06-24 12:22:26 -07:00
|
|
|
let pat = type_pat val_env spat 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
|
|
|
|
(fun (id, ty) (val_env, met_env, par_env) ->
|
|
|
|
(Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
|
1998-11-29 09:34:05 -08:00
|
|
|
Env.add_value id {val_type = ty;
|
2003-11-25 01:20:45 -08:00
|
|
|
val_kind = Val_self (meths, vars, cl_num, privty)}
|
1998-06-24 12:22:26 -07:00
|
|
|
met_env,
|
|
|
|
Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
|
|
|
|
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 () =
|
|
|
|
List.iter (fun f -> f ()) (List.rev !delayed_checks);
|
|
|
|
reset_delayed_checks ()
|
|
|
|
|
1997-03-07 14:00:19 -08:00
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Generalization criterion for expressions *)
|
|
|
|
|
|
|
|
let rec is_nonexpansive exp =
|
|
|
|
match exp.exp_desc with
|
|
|
|
Texp_ident(_,_) -> true
|
|
|
|
| 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
|
2000-09-04 01:49:32 -07:00
|
|
|
| Texp_apply(e, (None,_)::el) ->
|
|
|
|
is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map fst el)
|
1995-05-04 03:15:53 -07:00
|
|
|
| Texp_tuple el ->
|
|
|
|
List.for_all is_nonexpansive el
|
|
|
|
| Texp_construct(_, el) ->
|
|
|
|
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
|
2000-06-01 06:14:36 -07:00
|
|
|
(fun (lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
|
|
|
|
lbl_exp_list
|
|
|
|
&& is_nonexpansive_opt opt_init_exp
|
1995-05-04 03:15:53 -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
|
1998-08-31 12:41:24 -07:00
|
|
|
| Texp_new (_, cl_decl) when Ctype.class_type_arity cl_decl.cty_type > 0 ->
|
|
|
|
true
|
2003-11-25 01:20:45 -08:00
|
|
|
(* Note: nonexpansive only means no _observable_ side effects *)
|
|
|
|
| Texp_lazy e -> is_nonexpansive e
|
|
|
|
| Texp_object ({cl_field=fields}, {cty_vars=vars}, _) ->
|
|
|
|
let count = ref 0 in
|
|
|
|
List.for_all
|
|
|
|
(function
|
|
|
|
Cf_meth _ -> true
|
|
|
|
| Cf_val (_,_,e) -> incr count; is_nonexpansive e
|
|
|
|
| Cf_init e -> is_nonexpansive e
|
|
|
|
| Cf_inher _ | Cf_let _ -> false)
|
|
|
|
fields &&
|
|
|
|
Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
|
|
|
|
vars true &&
|
|
|
|
!count = 0
|
1995-05-04 03:15:53 -07:00
|
|
|
| _ -> false
|
|
|
|
|
2000-06-01 06:14:36 -07:00
|
|
|
and is_nonexpansive_opt = function
|
|
|
|
None -> true
|
|
|
|
| Some e -> is_nonexpansive e
|
|
|
|
|
2005-03-04 06:51:31 -08:00
|
|
|
(* Typing of printf formats.
|
2001-10-28 06:22:05 -08:00
|
|
|
(Handling of * modifiers contributed by Thorsten Ohl.) *)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
let type_format loc fmt =
|
2004-09-22 02:17:21 -07:00
|
|
|
|
2003-11-30 14:41:32 -08:00
|
|
|
let ty_arrow gty ty = newty (Tarrow ("", instance 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 =
|
|
|
|
let len = String.length fmt in
|
|
|
|
|
|
|
|
let ty_input = newvar ()
|
|
|
|
and ty_result = newvar ()
|
|
|
|
and ty_aresult = 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
|
|
|
|
then ty_aresult, ty_result
|
|
|
|
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
|
|
|
|
| '*' ->
|
|
|
|
let ty_aresult, ty_result = scan i (j + 1) in
|
|
|
|
ty_aresult, ty_arrow Predef.type_int ty_result
|
|
|
|
| '-' | '+' -> 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
|
|
|
|
|
|
|
|
and conversion j ty_arg =
|
|
|
|
let ty_aresult, ty_result = scan_format (j + 1) in
|
|
|
|
ty_aresult,
|
|
|
|
if skip then ty_result else ty_arrow ty_arg ty_result
|
|
|
|
|
|
|
|
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
|
|
|
|
| '%' | '!' -> scan_format (j + 1)
|
|
|
|
| 's' | 'S' | '[' -> conversion j Predef.type_string
|
|
|
|
| 'c' | 'C' -> conversion j Predef.type_char
|
|
|
|
| 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
|
|
|
|
conversion j Predef.type_int
|
|
|
|
| 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
|
|
|
|
| 'B' | 'b' -> conversion j Predef.type_bool
|
|
|
|
| 'a' ->
|
2003-04-28 02:44:21 -07:00
|
|
|
let ty_arg = newvar () in
|
2002-12-09 01:27:54 -08:00
|
|
|
let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult) in
|
|
|
|
let ty_aresult, ty_result = conversion j ty_arg in
|
|
|
|
ty_aresult, ty_arrow ty_a ty_result
|
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
|
|
|
|
| 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
|
|
|
|
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 =
|
2005-03-04 06:51:31 -08:00
|
|
|
Printf.sub_format incomplete_format bad_conversion c fmt j in
|
2004-09-22 02:17:21 -07:00
|
|
|
let sfmt = String.sub fmt j (sj - j - 1) in
|
|
|
|
let ty_sfmt = type_in_format sfmt in
|
|
|
|
begin match c with
|
2004-10-04 13:47:49 -07:00
|
|
|
| '{' -> conversion sj 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
|
|
|
|
|
|
|
|
let ty_ares, ty_res = scan_format 0 in
|
|
|
|
newty
|
|
|
|
(Tconstr(Predef.path_format4,
|
|
|
|
[ty_res; ty_input; ty_ares; ty_result],
|
|
|
|
ref Mnil)) in
|
|
|
|
|
|
|
|
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
|
|
|
|
let tyl = List.map (approx_type env) ctl in
|
|
|
|
let (path, _) = Env.lookup_type lid env in
|
|
|
|
newconstr path tyl
|
|
|
|
with Not_found -> newvar ()
|
|
|
|
end
|
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
|
|
|
|
| _ ->
|
|
|
|
List.rev ls, ty.desc = Tvar
|
|
|
|
|
|
|
|
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 *)
|
|
|
|
let check_univars env kind exp ty_expected vars =
|
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;
|
|
|
|
if t.desc = Tvar && t.level = generic_level then
|
2002-11-20 21:39:01 -08:00
|
|
|
(log_type t; t.desc <- Tunivar; true)
|
2002-04-18 00:27:47 -07:00
|
|
|
else false)
|
|
|
|
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 *)
|
|
|
|
let check_partial_application env exp =
|
|
|
|
match expand_head env exp.exp_type with
|
|
|
|
| {desc = Tarrow _} ->
|
|
|
|
Location.prerr_warning exp.exp_loc Warnings.Partial_application
|
|
|
|
| _ -> ()
|
|
|
|
|
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)
|
|
|
|
|
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; *)
|
1995-05-04 03:15:53 -07:00
|
|
|
try
|
|
|
|
unify env exp.exp_type expected_ty
|
2002-01-03 18:02:50 -08:00
|
|
|
with
|
|
|
|
Unify trace ->
|
|
|
|
raise(Error(exp.exp_loc, Expr_type_clash(trace)))
|
|
|
|
| Tags(l1,l2) ->
|
|
|
|
raise(Typetexp.Error(exp.exp_loc, Typetexp.Variant_tags (l1, l2)))
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
let rec type_exp env sexp =
|
|
|
|
match sexp.pexp_desc with
|
|
|
|
Pexp_ident lid ->
|
|
|
|
begin try
|
|
|
|
let (path, desc) = Env.lookup_value lid env in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
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
|
|
|
|
Texp_instvar(self_path, path)
|
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
|
1998-06-24 12:22:26 -07:00
|
|
|
Texp_ident(path, desc)
|
|
|
|
| Val_unbound ->
|
|
|
|
raise(Error(sexp.pexp_loc, Masked_instance_variable lid))
|
1997-05-19 08:42:21 -07:00
|
|
|
| _ ->
|
|
|
|
Texp_ident(path, desc)
|
|
|
|
end;
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = instance desc.val_type;
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
with Not_found ->
|
|
|
|
raise(Error(sexp.pexp_loc, Unbound_value lid))
|
|
|
|
end
|
|
|
|
| Pexp_constant cst ->
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_constant cst;
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = type_constant cst;
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
|
|
|
|
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
|
|
|
|
let body = type_exp new_env sbody in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = body.exp_type;
|
|
|
|
exp_env = env }
|
1999-12-01 07:57:03 -08:00
|
|
|
| Pexp_function _ -> (* defined in type_expect *)
|
1999-11-30 08:07:38 -08:00
|
|
|
type_expect env sexp (newvar())
|
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
|
|
|
|
end_def ();
|
|
|
|
generalize_structure funct.exp_type
|
|
|
|
end;
|
2004-11-28 18:27:25 -08:00
|
|
|
let rec lower_args ty_fun =
|
|
|
|
match (expand_head env ty_fun).desc with
|
|
|
|
Tarrow (l, ty, ty_fun, com) ->
|
|
|
|
unify_var env (newvar()) ty;
|
|
|
|
lower_args ty_fun
|
|
|
|
| _ -> ()
|
|
|
|
in
|
|
|
|
let ty = instance funct.exp_type in
|
|
|
|
end_def ();
|
|
|
|
lower_args ty;
|
|
|
|
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;
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_apply(funct, args);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
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) ->
|
|
|
|
let arg = type_exp env sarg in
|
|
|
|
let ty_res = newvar() in
|
2000-11-06 01:49:27 -08:00
|
|
|
let cases, partial =
|
2002-11-20 21:39:01 -08:00
|
|
|
type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist
|
|
|
|
in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_match(arg, cases, partial);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = ty_res;
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_try(sbody, caselist) ->
|
|
|
|
let body = type_exp env sbody in
|
2000-11-06 01:49:27 -08:00
|
|
|
let cases, _ =
|
|
|
|
type_cases env (instance Predef.type_exn) body.exp_type None
|
|
|
|
caselist in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_try(body, cases);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
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 ->
|
|
|
|
let expl = List.map (type_exp env) sexpl in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_tuple expl;
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = newty (Ttuple(List.map (fun exp -> exp.exp_type) expl));
|
|
|
|
exp_env = env }
|
1997-06-16 11:10:35 -07:00
|
|
|
| Pexp_construct(lid, sarg, explicit_arity) ->
|
1999-11-30 08:07:38 -08:00
|
|
|
type_construct env sexp.pexp_loc lid sarg explicit_arity (newvar ())
|
|
|
|
| Pexp_variant(l, sarg) ->
|
|
|
|
let arg = may_map (type_exp env) sarg in
|
|
|
|
let arg_type = may_map (fun arg -> arg.exp_type) arg in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_variant(l, arg);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1999-11-30 08:07:38 -08:00
|
|
|
exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
|
|
|
|
row_more = newvar ();
|
|
|
|
row_bound = [];
|
|
|
|
row_closed = false;
|
2002-04-18 00:27:47 -07:00
|
|
|
row_fixed = false;
|
1999-11-30 08:07:38 -08:00
|
|
|
row_name = None});
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_env = env }
|
1998-04-27 08:17:11 -07:00
|
|
|
| Pexp_record(lid_sexp_list, opt_sexp) ->
|
1995-05-04 03:15:53 -07:00
|
|
|
let ty = newvar() in
|
|
|
|
let num_fields = ref 0 in
|
|
|
|
let type_label_exp (lid, sarg) =
|
|
|
|
let label =
|
|
|
|
try
|
|
|
|
Env.lookup_label lid env
|
|
|
|
with Not_found ->
|
|
|
|
raise(Error(sexp.pexp_loc, Unbound_label lid)) in
|
2002-04-18 00:27:47 -07:00
|
|
|
begin_def ();
|
|
|
|
if !Clflags.principal then begin_def ();
|
|
|
|
let (vars, ty_arg, ty_res) = instance_label true label in
|
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure ty_arg;
|
|
|
|
generalize_structure ty_res
|
|
|
|
end;
|
1995-05-04 03:15:53 -07:00
|
|
|
begin try
|
2002-04-18 00:27:47 -07:00
|
|
|
unify env (instance ty_res) ty
|
1996-05-20 09:43:29 -07:00
|
|
|
with Unify trace ->
|
|
|
|
raise(Error(sexp.pexp_loc, Label_mismatch(lid, trace)))
|
1995-05-04 03:15:53 -07:00
|
|
|
end;
|
2002-04-18 00:27:47 -07:00
|
|
|
let arg = type_argument env sarg ty_arg in
|
|
|
|
end_def ();
|
2002-12-02 18:57:23 -08:00
|
|
|
if vars <> [] && not (is_nonexpansive arg) then
|
|
|
|
generalize_expansive env arg.exp_type;
|
2002-04-18 00:27:47 -07:00
|
|
|
check_univars env "field value" arg label.lbl_arg vars;
|
1995-05-04 03:15:53 -07:00
|
|
|
num_fields := Array.length label.lbl_all;
|
2003-07-02 02:14:35 -07:00
|
|
|
if label.lbl_private = Private then
|
|
|
|
raise(Error(sexp.pexp_loc, Private_type ty));
|
2002-12-02 18:57:23 -08:00
|
|
|
(label, {arg with exp_type = instance arg.exp_type}) in
|
2004-06-14 14:29:05 -07:00
|
|
|
let lbl_exp_list = type_label_a_list type_label_exp lid_sexp_list in
|
2002-07-17 07:22:57 -07:00
|
|
|
let rec check_duplicates seen_pos lid_sexp lbl_exp =
|
|
|
|
match (lid_sexp, lbl_exp) with
|
|
|
|
((lid, _) :: rem1, (lbl, _) :: rem2) ->
|
|
|
|
if List.mem lbl.lbl_pos seen_pos
|
|
|
|
then raise(Error(sexp.pexp_loc, Label_multiply_defined lid))
|
|
|
|
else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
|
|
|
|
| (_, _) -> () in
|
|
|
|
check_duplicates [] lid_sexp_list 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
|
|
|
|
| Some sexp, (lbl, _) :: _ ->
|
|
|
|
let ty_exp = newvar () in
|
|
|
|
let unify_kept lbl =
|
|
|
|
if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
|
|
|
|
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;
|
|
|
|
unify env ty ty_res2;
|
|
|
|
unify env ty_arg1 ty_arg2
|
|
|
|
end in
|
|
|
|
Array.iter unify_kept lbl.lbl_all;
|
|
|
|
Some(type_expect env sexp ty_exp)
|
|
|
|
| _ -> assert false
|
|
|
|
in
|
2001-06-28 18:46:46 -07:00
|
|
|
if opt_sexp = None && List.length lid_sexp_list <> !num_fields then begin
|
|
|
|
let present_indices =
|
|
|
|
List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in
|
2003-02-27 22:59:19 -08:00
|
|
|
let label_names = extract_label_names sexp env ty 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
|
|
|
|
raise(Error(sexp.pexp_loc, Label_missing missing))
|
|
|
|
end;
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_record(lbl_exp_list, opt_exp);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = ty;
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_field(sarg, lid) ->
|
|
|
|
let arg = type_exp env sarg in
|
|
|
|
let label =
|
|
|
|
try
|
|
|
|
Env.lookup_label lid env
|
|
|
|
with Not_found ->
|
|
|
|
raise(Error(sexp.pexp_loc, Unbound_label lid)) 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;
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_field(arg, label);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
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
|
|
|
|
let label =
|
|
|
|
try
|
|
|
|
Env.lookup_label lid env
|
|
|
|
with Not_found ->
|
|
|
|
raise(Error(sexp.pexp_loc, Unbound_label lid)) in
|
|
|
|
if label.lbl_mut = Immutable then
|
|
|
|
raise(Error(sexp.pexp_loc, Label_not_mutable lid));
|
2002-04-18 00:27:47 -07:00
|
|
|
begin_def ();
|
|
|
|
let (vars, ty_arg, ty_res) = instance_label true label in
|
1995-05-04 03:15:53 -07:00
|
|
|
unify_exp env record ty_res;
|
|
|
|
let newval = type_expect env snewval ty_arg in
|
2002-04-18 00:27:47 -07:00
|
|
|
end_def ();
|
2002-12-02 18:57:23 -08:00
|
|
|
if vars <> [] && not (is_nonexpansive newval) then
|
|
|
|
generalize_expansive env newval.exp_type;
|
2002-04-18 00:27:47 -07:00
|
|
|
check_univars env "field value" newval label.lbl_arg vars;
|
2003-07-02 02:14:35 -07:00
|
|
|
if label.lbl_private = Private then
|
|
|
|
raise(Error(sexp.pexp_loc, Private_label(lid, ty_res)));
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_setfield(record, label, newval);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = instance Predef.type_unit;
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_array(sargl) ->
|
|
|
|
let ty = newvar() in
|
|
|
|
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;
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = instance (Predef.type_array ty);
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_ifthenelse(scond, sifso, sifnot) ->
|
1996-05-13 05:19:20 -07:00
|
|
|
let cond = type_expect env scond (instance Predef.type_bool) in
|
1995-05-04 03:15:53 -07:00
|
|
|
begin match sifnot with
|
|
|
|
None ->
|
1996-05-13 05:19:20 -07:00
|
|
|
let ifso = type_expect env sifso (instance Predef.type_unit) in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_ifthenelse(cond, ifso, None);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = instance Predef.type_unit;
|
|
|
|
exp_env = env }
|
1996-05-31 05:30:26 -07:00
|
|
|
| Some sifnot ->
|
1995-05-04 03:15:53 -07:00
|
|
|
let ifso = type_exp env sifso in
|
1996-05-31 05:30:26 -07:00
|
|
|
let ifnot = type_expect env sifnot ifso.exp_type in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
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
|
|
|
|
let exp2 = type_exp env sexp2 in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_sequence(exp1, exp2);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
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) ->
|
1996-05-13 05:19:20 -07:00
|
|
|
let cond = type_expect env scond (instance Predef.type_bool) in
|
1995-05-04 03:15:53 -07:00
|
|
|
let body = type_statement env sbody in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_while(cond, body);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = instance Predef.type_unit;
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_for(param, slow, shigh, dir, sbody) ->
|
1996-05-13 05:19:20 -07:00
|
|
|
let low = type_expect env slow (instance Predef.type_int) in
|
|
|
|
let high = type_expect env shigh (instance Predef.type_int) in
|
1995-05-04 03:15:53 -07:00
|
|
|
let (id, new_env) =
|
1996-05-13 05:19:20 -07:00
|
|
|
Env.enter_value param {val_type = instance Predef.type_int;
|
1996-04-22 04:15:41 -07:00
|
|
|
val_kind = Val_reg} env in
|
1995-05-04 03:15:53 -07:00
|
|
|
let body = type_statement new_env sbody in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_for(id, low, high, dir, body);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = instance Predef.type_unit;
|
|
|
|
exp_env = env }
|
1996-04-22 04:15:41 -07:00
|
|
|
| Pexp_constraint(sarg, sty, sty') ->
|
1996-05-26 06:42:34 -07:00
|
|
|
let (arg, ty') =
|
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
|
1997-05-19 08:42:21 -07:00
|
|
|
(arg, arg.exp_type)
|
|
|
|
| (Some sty, None) ->
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
1996-04-22 04:15:41 -07:00
|
|
|
let ty = Typetexp.transl_simple_type env false sty in
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
generalize_structure ty;
|
|
|
|
let ty1 = instance ty and ty2 = instance ty in
|
|
|
|
(type_expect env sarg ty1, ty2)
|
|
|
|
end else
|
|
|
|
(type_expect env sarg ty, ty)
|
1997-05-19 08:42:21 -07:00
|
|
|
| (None, Some sty') ->
|
1997-01-20 09:11:47 -08:00
|
|
|
let (ty', force) =
|
|
|
|
Typetexp.transl_simple_type_delayed env sty'
|
|
|
|
in
|
1996-05-26 06:42:34 -07:00
|
|
|
let arg = type_exp env sarg in
|
2001-11-05 01:12:59 -08:00
|
|
|
begin match arg.exp_desc, !self_coercion, (repr ty').desc with
|
|
|
|
Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
|
|
|
|
Tconstr(path',_,_) when Path.same path path' ->
|
|
|
|
r := sexp.pexp_loc :: !r;
|
|
|
|
force ()
|
|
|
|
| _ ->
|
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;
|
|
|
|
(arg, ty')
|
1997-05-19 08:42:21 -07:00
|
|
|
| (Some sty, Some sty') ->
|
1997-01-20 09:11:47 -08:00
|
|
|
let (ty, force) =
|
|
|
|
Typetexp.transl_simple_type_delayed env sty
|
|
|
|
and (ty', force') =
|
|
|
|
Typetexp.transl_simple_type_delayed env sty'
|
|
|
|
in
|
|
|
|
begin try
|
|
|
|
let force'' = subtype env ty ty' in
|
|
|
|
force (); force' (); force'' ()
|
|
|
|
with Subtype (tr1, tr2) ->
|
1997-05-19 08:42:21 -07:00
|
|
|
raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
|
1997-01-20 09:11:47 -08:00
|
|
|
end;
|
1997-05-19 08:42:21 -07:00
|
|
|
(type_expect env sarg ty, ty')
|
1996-05-26 06:42:34 -07:00
|
|
|
in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
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';
|
|
|
|
exp_env = env }
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_when(scond, sbody) ->
|
1996-05-13 05:19:20 -07:00
|
|
|
let cond = type_expect env scond (instance Predef.type_bool) in
|
1995-05-04 03:15:53 -07:00
|
|
|
let body = type_exp env sbody in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_when(cond, body);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
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
|
1997-05-11 14:48:21 -07:00
|
|
|
let (exp, typ) =
|
1998-06-24 12:22:26 -07:00
|
|
|
match obj.exp_desc with
|
2003-11-25 01:20:45 -08: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
|
2004-11-17 00:14:56 -08:00
|
|
|
if (repr typ).desc = Tvar then
|
|
|
|
Location.prerr_warning sexp.pexp_loc
|
2004-11-30 10:57:04 -08:00
|
|
|
(Warnings.Undeclared_virtual_method met);
|
1998-06-24 12:22:26 -07:00
|
|
|
(Texp_send(obj, Tmeth_val id), typ)
|
1998-11-29 09:34:05 -08:00
|
|
|
| Texp_ident(path, {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;
|
2002-04-18 00:27:47 -07:00
|
|
|
unify env res_ty (instance typ);
|
2003-04-01 17:32:09 -08:00
|
|
|
(Texp_apply({ exp_desc = Texp_ident(Path.Pident method_id,
|
1998-06-24 12:22:26 -07:00
|
|
|
{val_type = method_type;
|
|
|
|
val_kind = Val_reg});
|
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type = method_type;
|
|
|
|
exp_env = env },
|
1999-11-30 08:07:38 -08:00
|
|
|
[Some {exp_desc = Texp_ident(path, desc);
|
|
|
|
exp_loc = obj.exp_loc;
|
|
|
|
exp_type = desc.val_type;
|
2000-09-04 01:49:32 -07:00
|
|
|
exp_env = env },
|
|
|
|
Required]),
|
1998-06-24 12:22:26 -07:00
|
|
|
typ)
|
|
|
|
| _ ->
|
|
|
|
assert false
|
|
|
|
end
|
1996-04-22 04:15:41 -07:00
|
|
|
| _ ->
|
1998-06-24 12:22:26 -07:00
|
|
|
(Texp_send(obj, Tmeth_name met),
|
|
|
|
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, [])} ->
|
|
|
|
instance ty
|
|
|
|
| {desc = Tpoly (ty, tl); level = l} ->
|
|
|
|
if !Clflags.principal && l <> generic_level then
|
|
|
|
Location.prerr_warning sexp.pexp_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)
|
|
|
|
| {desc = Tvar} as ty ->
|
|
|
|
let ty' = newvar () in
|
|
|
|
unify env (instance ty) (newty(Tpoly(ty',[])));
|
|
|
|
(* 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
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = exp;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
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 ->
|
1998-06-24 12:22:26 -07:00
|
|
|
let (cl_path, cl_decl) =
|
1996-04-22 04:15:41 -07:00
|
|
|
try Env.lookup_class cl env with Not_found ->
|
|
|
|
raise(Error(sexp.pexp_loc, Unbound_class cl))
|
|
|
|
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 ->
|
|
|
|
raise(Error(sexp.pexp_loc, Virtual_class cl))
|
1996-04-22 04:15:41 -07:00
|
|
|
| Some ty ->
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_new (cl_path, cl_decl);
|
1997-05-19 08:42:21 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type = instance 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
|
1996-05-16 09:10:16 -07:00
|
|
|
let (path, desc) = Env.lookup_value (Longident.Lident lab) 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) ->
|
2002-04-18 00:27:47 -07:00
|
|
|
let newval = type_expect env snewval (instance 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
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_setinstvar(path_self, path, newval);
|
1996-04-22 04:15:41 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = instance Predef.type_unit;
|
|
|
|
exp_env = env }
|
1997-05-19 08:42:21 -07:00
|
|
|
| Val_ivar _ ->
|
|
|
|
raise(Error(sexp.pexp_loc, Instance_variable_not_mutable lab))
|
|
|
|
| _ ->
|
1996-05-16 09:10:16 -07:00
|
|
|
raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
|
1996-04-22 04:15:41 -07:00
|
|
|
with
|
1997-05-19 08:42:21 -07:00
|
|
|
Not_found ->
|
1996-05-16 09:10:16 -07:00
|
|
|
raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
|
1996-04-22 04:15:41 -07:00
|
|
|
end
|
|
|
|
| Pexp_override lst ->
|
1998-11-12 06:53:46 -08:00
|
|
|
let _ =
|
|
|
|
List.fold_right
|
1997-05-19 08:42:21 -07:00
|
|
|
(fun (lab, _) l ->
|
|
|
|
if List.exists ((=) lab) l then
|
|
|
|
raise(Error(sexp.pexp_loc,
|
|
|
|
Value_multiply_overridden lab));
|
|
|
|
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 ->
|
|
|
|
raise(Error(sexp.pexp_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
|
|
|
|
let (id, _, ty) = Vars.find lab !vars in
|
2002-04-18 00:27:47 -07:00
|
|
|
(Path.Pident id, type_expect env snewval (instance ty))
|
1998-06-24 12:22:26 -07:00
|
|
|
with
|
|
|
|
Not_found ->
|
|
|
|
raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
|
|
|
|
end
|
|
|
|
in
|
|
|
|
let modifs = List.map type_override lst in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_override(path_self, modifs);
|
1998-06-24 12:22:26 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
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
|
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
|
|
|
|
let (id, new_env) = Env.enter_module name 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;
|
1998-02-26 04:54:44 -08:00
|
|
|
let body = type_exp new_env sbody in
|
|
|
|
(* 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
|
|
|
|
Ctype.unify new_env body.exp_type ty
|
|
|
|
with Unify _ ->
|
|
|
|
raise(Error(sexp.pexp_loc, Scoping_let_module(name, body.exp_type)))
|
|
|
|
end;
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_letmodule(id, modl, body);
|
1998-02-26 04:54:44 -08:00
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type = ty;
|
|
|
|
exp_env = env }
|
2000-12-04 07:37:05 -08:00
|
|
|
| Pexp_assert (e) ->
|
|
|
|
let cond = type_expect env e (instance Predef.type_bool) in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
2000-12-04 07:37:05 -08:00
|
|
|
exp_desc = Texp_assert (cond);
|
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type = instance Predef.type_unit;
|
|
|
|
exp_env = env;
|
|
|
|
}
|
|
|
|
| Pexp_assertfalse ->
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
2000-12-04 07:37:05 -08:00
|
|
|
exp_desc = Texp_assertfalse;
|
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type = newvar ();
|
|
|
|
exp_env = env;
|
|
|
|
}
|
2002-01-20 09:39:10 -08:00
|
|
|
| Pexp_lazy (e) ->
|
|
|
|
let arg = type_exp env e in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
2002-01-20 09:39:10 -08:00
|
|
|
exp_desc = Texp_lazy arg;
|
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type = instance (Predef.type_lazy_t arg.exp_type);
|
|
|
|
exp_env = env;
|
|
|
|
}
|
2003-11-25 01:20:45 -08:00
|
|
|
| Pexp_object s ->
|
|
|
|
let desc, sign, meths = !type_object env sexp.pexp_loc s in
|
|
|
|
re {
|
|
|
|
exp_desc = Texp_object (desc, sign, meths);
|
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type = sign.cty_self;
|
|
|
|
exp_env = env;
|
|
|
|
}
|
2002-04-18 00:27:47 -07:00
|
|
|
| Pexp_poly _ ->
|
|
|
|
assert false
|
1996-04-22 04:15:41 -07:00
|
|
|
|
2002-04-18 00:27:47 -07:00
|
|
|
and type_argument env sarg ty_expected' =
|
|
|
|
(* 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
|
2002-04-18 00:27:47 -07:00
|
|
|
let ty_expected = instance ty_expected' in
|
|
|
|
match expand_head env ty_expected', sarg with
|
1999-11-30 08:07:38 -08:00
|
|
|
| _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
|
|
|
|
type_expect env sarg ty_expected
|
2002-04-18 00:27:47 -07:00
|
|
|
| {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
|
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 ->
|
2000-09-04 01:49:32 -07:00
|
|
|
make_args
|
2002-04-18 00:27:47 -07:00
|
|
|
((Some(option_none (instance ty_arg) sarg.pexp_loc), Optional)
|
|
|
|
:: args)
|
2000-09-04 01:49:32 -07:00
|
|
|
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'
|
2001-04-19 01:34:21 -07:00
|
|
|
| Tvar -> args, ty_fun, false
|
|
|
|
| _ -> [], 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)
|
|
|
|
and texp = {texp with exp_type = instance texp.exp_type}
|
|
|
|
and ty_fun = instance 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
|
2002-05-16 20:58:35 -07:00
|
|
|
{pat_desc = Tpat_var id; pat_type = ty;
|
1999-11-30 08:07:38 -08:00
|
|
|
pat_loc = Location.none; pat_env = env},
|
2002-05-16 20:58:35 -07:00
|
|
|
{exp_type = ty; exp_loc = Location.none; exp_env = env; exp_desc =
|
|
|
|
Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg})}
|
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 =
|
|
|
|
Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc =
|
2000-09-04 01:49:32 -07:00
|
|
|
Texp_apply (texp, 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
|
|
|
| _ ->
|
|
|
|
type_expect env sarg ty_expected
|
|
|
|
|
|
|
|
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
|
1999-11-30 08:07:38 -08:00
|
|
|
let rec type_unknown_args args omitted ty_fun = function
|
|
|
|
[] ->
|
2001-11-16 01:07:09 -08:00
|
|
|
(List.map
|
2000-09-04 01:49:32 -07:00
|
|
|
(function None, x -> None, x | Some f, x -> Some (f ()), x)
|
2001-11-16 01:07:09 -08:00
|
|
|
(List.rev args),
|
2002-04-18 00:27:47 -07:00
|
|
|
instance (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
|
2001-04-19 01:34:21 -07:00
|
|
|
Tvar ->
|
|
|
|
let t1 = newvar () and t2 = newvar () in
|
2004-11-28 18:27:25 -08:00
|
|
|
let not_identity = function
|
|
|
|
Texp_ident(_,{val_kind=Val_prim
|
|
|
|
{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
|
2000-09-04 01:49:32 -07:00
|
|
|
type_unknown_args ((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
|
1999-11-30 08:07:38 -08:00
|
|
|
let rec type_args args omitted ty_fun ty_old sargs more_sargs =
|
|
|
|
match expand_head env ty_fun with
|
2001-04-19 01:34:21 -07:00
|
|
|
{desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun'
|
|
|
|
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
|
|
|
|
([], more_sargs, Some (fun () -> type_argument env sarg0 ty))
|
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
|
2000-03-15 19:30:59 -08:00
|
|
|
Some (fun () -> type_argument env sarg0 ty)
|
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");
|
2000-03-15 19:30:59 -08:00
|
|
|
Some (fun () -> option_some (type_argument env sarg0
|
|
|
|
(extract_option_type env ty)))
|
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;
|
2002-04-18 00:27:47 -07:00
|
|
|
Some (fun () -> option_none (instance ty) Location.none)
|
|
|
|
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
|
2000-09-04 01:49:32 -07:00
|
|
|
type_args ((arg,optional)::args) omitted ty_fun 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
|
|
|
| _ ->
|
2002-04-18 00:27:47 -07:00
|
|
|
type_unknown_args args omitted (instance ty_fun)
|
|
|
|
(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 *)
|
|
|
|
Texp_ident (_, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}),
|
|
|
|
["", sarg] ->
|
2002-04-18 00:27:47 -07:00
|
|
|
let ty_arg, ty_res = filter_arrow env (instance 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
|
2002-05-16 03:18:51 -07:00
|
|
|
| Tvar ->
|
|
|
|
add_delayed_check (fun () -> check_partial_application env exp)
|
1999-11-30 08:07:38 -08:00
|
|
|
| _ -> ()
|
|
|
|
end;
|
2000-09-04 01:49:32 -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
|
1999-11-30 08:07:38 -08:00
|
|
|
type_args [] [] ty ty [] sargs
|
|
|
|
else
|
|
|
|
type_args [] [] ty ty sargs []
|
|
|
|
|
|
|
|
and type_construct env loc lid sarg explicit_arity ty_expected =
|
|
|
|
let constr =
|
|
|
|
try
|
|
|
|
Env.lookup_constructor lid env
|
|
|
|
with Not_found ->
|
|
|
|
raise(Error(loc, Unbound_constructor lid)) in
|
|
|
|
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
|
|
|
|
(lid, constr.cstr_arity, List.length sargs)));
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
1999-11-30 08:07:38 -08:00
|
|
|
let (ty_args, ty_res) = instance_constructor constr in
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin
|
|
|
|
end_def ();
|
|
|
|
List.iter generalize_structure ty_args;
|
|
|
|
generalize_structure ty_res
|
|
|
|
end;
|
1999-11-30 08:07:38 -08:00
|
|
|
let texp =
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_construct(constr, []);
|
1999-11-30 08:07:38 -08:00
|
|
|
exp_loc = loc;
|
2002-04-18 00:27:47 -07:00
|
|
|
exp_type = instance ty_res;
|
1999-11-30 08:07:38 -08:00
|
|
|
exp_env = env } in
|
|
|
|
unify_exp env texp ty_expected;
|
2002-04-18 00:27:47 -07:00
|
|
|
let args = List.map2 (type_argument env) sargs ty_args in
|
2003-07-02 02:14:35 -07:00
|
|
|
if constr.cstr_private = Private then
|
|
|
|
raise(Error(loc, Private_type ty_res));
|
1999-11-30 08:07:38 -08:00
|
|
|
{ texp with exp_desc = Texp_construct(constr, args) }
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
(* Typing of an expression with an expected type.
|
|
|
|
Some constructs are treated specially to provide better error messages. *)
|
|
|
|
|
2001-11-21 22:47:29 -08:00
|
|
|
and type_expect ?in_function env sexp ty_expected =
|
1995-05-04 03:15:53 -07:00
|
|
|
match sexp.pexp_desc with
|
|
|
|
Pexp_constant(Const_string s as cst) ->
|
|
|
|
let exp =
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_constant cst;
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type =
|
|
|
|
(* Terrible hack for format strings *)
|
2003-01-07 05:48:29 -08:00
|
|
|
begin match (repr (expand_head env ty_expected)).desc with
|
2003-07-05 04:13:24 -07:00
|
|
|
Tconstr(path, _, _) when Path.same path Predef.path_format4 ->
|
1995-05-04 03:15:53 -07:00
|
|
|
type_format sexp.pexp_loc s
|
1996-09-23 04:33:27 -07:00
|
|
|
| _ -> instance Predef.type_string
|
|
|
|
end;
|
|
|
|
exp_env = env } in
|
1995-05-04 03:15:53 -07:00
|
|
|
unify_exp env exp ty_expected;
|
|
|
|
exp
|
1999-11-30 08:07:38 -08:00
|
|
|
| Pexp_construct(lid, sarg, explicit_arity) ->
|
|
|
|
type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected
|
1995-05-04 03:15:53 -07:00
|
|
|
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
|
|
|
|
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
|
|
|
|
let body = type_expect new_env sbody ty_expected in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
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_sequence(sexp1, sexp2) ->
|
|
|
|
let exp1 = type_statement env sexp1 in
|
|
|
|
let exp2 = type_expect env sexp2 ty_expected in
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_sequence(exp1, exp2);
|
1995-05-04 03:15:53 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
1996-09-23 04:33:27 -07:00
|
|
|
exp_type = exp2.exp_type;
|
|
|
|
exp_env = env }
|
1999-11-30 08:07:38 -08:00
|
|
|
| Pexp_function (l, Some default, [spat, sbody]) ->
|
|
|
|
let loc = default.pexp_loc in
|
|
|
|
let scases =
|
|
|
|
[{ppat_loc = loc; ppat_desc =
|
|
|
|
Ppat_construct(Longident.Lident"Some",
|
|
|
|
Some{ppat_loc = loc; ppat_desc = Ppat_var"*sth*"},
|
|
|
|
false)},
|
|
|
|
{pexp_loc = loc; pexp_desc = Pexp_ident(Longident.Lident"*sth*")};
|
|
|
|
{ppat_loc = loc; ppat_desc =
|
|
|
|
Ppat_construct(Longident.Lident"None", None, false)},
|
|
|
|
default] in
|
|
|
|
let smatch =
|
|
|
|
{pexp_loc = loc; pexp_desc =
|
|
|
|
Pexp_match({pexp_loc = loc; pexp_desc =
|
|
|
|
Pexp_ident(Longident.Lident"*opt*")},
|
|
|
|
scases)} in
|
|
|
|
let sfun =
|
|
|
|
{pexp_loc = sexp.pexp_loc; pexp_desc =
|
|
|
|
Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
|
|
|
|
{pexp_loc = sexp.pexp_loc; pexp_desc =
|
1999-12-06 09:05:19 -08:00
|
|
|
Pexp_let(Default, [spat, smatch], sbody)}])}
|
1999-11-30 08:07:38 -08:00
|
|
|
in
|
2001-11-21 22:47:29 -08:00
|
|
|
type_expect ?in_function env sfun ty_expected
|
1999-11-30 08:07:38 -08:00
|
|
|
| Pexp_function (l, _, caselist) ->
|
2001-11-21 22:47:29 -08:00
|
|
|
let (loc, ty_fun) =
|
|
|
|
match in_function with Some p -> p
|
|
|
|
| None -> (sexp.pexp_loc, ty_expected)
|
|
|
|
in
|
1998-06-24 12:22:26 -07:00
|
|
|
let (ty_arg, ty_res) =
|
1999-11-30 08:07:38 -08:00
|
|
|
try filter_arrow env ty_expected l
|
|
|
|
with Unify _ ->
|
|
|
|
match expand_head env ty_expected with
|
|
|
|
{desc = Tarrow _} as ty ->
|
|
|
|
raise(Error(sexp.pexp_loc, Abstract_wrong_label(l, ty)))
|
|
|
|
| _ ->
|
2001-11-21 22:47:29 -08:00
|
|
|
raise(Error(loc,
|
|
|
|
Too_many_arguments (in_function <> None, ty_fun)))
|
1998-06-24 12:22:26 -07:00
|
|
|
in
|
1999-11-30 08:07:38 -08:00
|
|
|
if is_optional l then begin
|
|
|
|
try unify env ty_arg (type_option(newvar()))
|
|
|
|
with Unify _ -> assert false
|
|
|
|
end;
|
2000-11-06 01:49:27 -08:00
|
|
|
let cases, partial =
|
2001-11-21 22:47:29 -08:00
|
|
|
type_cases ~in_function:(loc,ty_fun) env ty_arg ty_res
|
|
|
|
(Some sexp.pexp_loc) caselist in
|
2001-12-05 16:19:35 -08:00
|
|
|
let all_labeled ty =
|
|
|
|
let ls, tvar = list_labels env ty in
|
2001-12-06 23:27:59 -08:00
|
|
|
not (tvar || List.exists (fun l -> l = "" || l.[0] = '?') ls)
|
1999-11-30 08:07:38 -08:00
|
|
|
in
|
|
|
|
if is_optional l && all_labeled ty_res then
|
2000-03-06 14:12:09 -08:00
|
|
|
Location.prerr_warning (fst (List.hd cases)).pat_loc
|
2004-11-30 10:57:04 -08:00
|
|
|
Warnings.Unerasable_optional_argument;
|
2003-04-01 17:32:09 -08:00
|
|
|
re {
|
|
|
|
exp_desc = Texp_function(cases, partial);
|
1998-06-24 12:22:26 -07:00
|
|
|
exp_loc = sexp.pexp_loc;
|
2001-04-19 01:34:21 -07:00
|
|
|
exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok));
|
1998-06-24 12:22:26 -07:00
|
|
|
exp_env = env }
|
2002-04-18 00:27:47 -07:00
|
|
|
| Pexp_poly(sbody, sty) ->
|
|
|
|
let ty =
|
|
|
|
match sty with None -> repr ty_expected
|
|
|
|
| Some sty ->
|
|
|
|
let ty = Typetexp.transl_simple_type env false sty in
|
|
|
|
repr ty
|
|
|
|
in
|
|
|
|
let set_type ty =
|
|
|
|
unify_exp env
|
|
|
|
{ exp_desc = Texp_tuple []; exp_loc = sexp.pexp_loc;
|
|
|
|
exp_type = ty; exp_env = env } ty_expected in
|
|
|
|
begin
|
|
|
|
match ty.desc with
|
|
|
|
Tpoly (ty', []) ->
|
|
|
|
if sty <> None then set_type ty;
|
|
|
|
let exp = type_expect env sbody ty' in
|
2003-04-01 17:32:09 -08:00
|
|
|
re { exp with exp_type = ty }
|
2002-04-18 00:27:47 -07:00
|
|
|
| Tpoly (ty', tl) ->
|
|
|
|
if sty <> None then set_type ty;
|
|
|
|
(* One more level to generalize locally *)
|
|
|
|
begin_def ();
|
|
|
|
let vars, ty'' = instance_poly true tl ty' in
|
|
|
|
let exp = type_expect env sbody ty'' in
|
|
|
|
end_def ();
|
|
|
|
check_univars env "method" exp ty_expected vars;
|
2003-04-01 17:32:09 -08:00
|
|
|
re { exp with exp_type = ty }
|
2002-04-18 00:27:47 -07:00
|
|
|
| _ -> assert false
|
|
|
|
end
|
1995-05-04 03:15:53 -07:00
|
|
|
| _ ->
|
|
|
|
let exp = type_exp env sexp in
|
|
|
|
unify_exp env exp ty_expected;
|
|
|
|
exp
|
|
|
|
|
|
|
|
(* Typing of statements (expressions whose values are discarded) *)
|
|
|
|
|
|
|
|
and type_statement env sexp =
|
2004-11-28 18:27:25 -08:00
|
|
|
begin_def();
|
|
|
|
let exp = type_exp env sexp in
|
|
|
|
end_def();
|
|
|
|
let ty = expand_head env exp.exp_type and tv = newvar() in
|
|
|
|
begin match ty.desc with
|
|
|
|
| Tarrow _ ->
|
|
|
|
Location.prerr_warning sexp.pexp_loc Warnings.Partial_application
|
|
|
|
| Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
|
|
|
|
| Tvar when ty.level > tv.level ->
|
2004-11-30 10:57:04 -08:00
|
|
|
Location.prerr_warning sexp.pexp_loc Warnings.Nonreturning_statement
|
2004-11-28 18:27:25 -08:00
|
|
|
| Tvar ->
|
|
|
|
add_delayed_check (fun () -> check_partial_application env exp)
|
|
|
|
| _ ->
|
|
|
|
Location.prerr_warning sexp.pexp_loc Warnings.Statement_type
|
|
|
|
end;
|
|
|
|
unify_var env tv ty;
|
|
|
|
exp
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
(* Typing of match cases *)
|
|
|
|
|
2001-11-21 22:47:29 -08:00
|
|
|
and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
|
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
|
2000-05-12 11:22:35 -07:00
|
|
|
let pat_env_list =
|
|
|
|
List.map
|
|
|
|
(fun (spat, sexp) ->
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
2002-06-03 00:33:48 -07:00
|
|
|
let (pat, ext_env, force) = type_pattern env spat in
|
|
|
|
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;
|
|
|
|
{ pat with pat_type = instance pat.pat_type }
|
|
|
|
end else pat
|
|
|
|
in
|
2000-05-12 11:22:35 -07:00
|
|
|
unify_pat env pat ty_arg';
|
|
|
|
(pat, ext_env))
|
|
|
|
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;
|
2000-05-12 11:22:35 -07:00
|
|
|
begin match pat_env_list with [] -> ()
|
2001-03-02 16:14:35 -08:00
|
|
|
| (pat, _) :: _ -> unify_pat env pat ty_arg
|
2000-05-12 11:22:35 -07:00
|
|
|
end;
|
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
|
|
|
|
(fun (pat, ext_env) (spat, sexp) ->
|
2001-11-21 22:47:29 -08:00
|
|
|
let exp = type_expect ?in_function ext_env sexp ty_res in
|
2000-06-13 02:41:06 -07:00
|
|
|
(pat, exp))
|
2003-08-18 01:26:18 -07:00
|
|
|
pat_env_list caselist
|
|
|
|
in
|
|
|
|
let partial =
|
|
|
|
match partial_loc with None -> Partial
|
|
|
|
| Some loc -> Parmatch.check_partial loc cases
|
|
|
|
in
|
2002-05-26 20:09:18 -07:00
|
|
|
add_delayed_check (fun () -> Parmatch.check_unused env cases);
|
2000-11-06 01:49:27 -08:00
|
|
|
cases, partial
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
(* Typing of let bindings *)
|
|
|
|
|
|
|
|
and type_let env rec_flag spat_sexp_list =
|
|
|
|
begin_def();
|
2002-04-18 00:27:47 -07:00
|
|
|
if !Clflags.principal then begin_def ();
|
2002-06-03 00:33:48 -07:00
|
|
|
let (pat_list, new_env, force) =
|
1996-04-22 04:15:41 -07:00
|
|
|
type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list)
|
|
|
|
in
|
1999-11-30 08:07:38 -08:00
|
|
|
if rec_flag = Recursive then
|
|
|
|
List.iter2
|
2001-03-02 16:14:35 -08:00
|
|
|
(fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp))
|
1999-11-30 08:07:38 -08:00
|
|
|
pat_list spat_sexp_list;
|
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;
|
|
|
|
{pat with pat_type = instance pat.pat_type})
|
|
|
|
pat_list
|
|
|
|
end else pat_list in
|
2003-08-18 01:26:18 -07:00
|
|
|
(* Polymoprhic 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;
|
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 =
|
1999-12-06 09:05:19 -08:00
|
|
|
match rec_flag with Nonrecursive | Default -> env | Recursive -> new_env in
|
1995-05-04 03:15:53 -07:00
|
|
|
let exp_list =
|
1995-11-19 08:53:56 -08:00
|
|
|
List.map2
|
|
|
|
(fun (spat, sexp) pat -> type_expect exp_env sexp pat.pat_type)
|
|
|
|
spat_sexp_list pat_list in
|
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
|
1997-03-07 14:00:19 -08:00
|
|
|
(fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
|
|
|
|
pat_list;
|
1995-07-02 09:50:08 -07:00
|
|
|
(List.combine pat_list exp_list, new_env)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
|
|
|
(* Typing of toplevel bindings *)
|
|
|
|
|
|
|
|
let type_binding env rec_flag spat_sexp_list =
|
|
|
|
Typetexp.reset_type_variables();
|
1995-09-02 11:55:37 -07:00
|
|
|
type_let env rec_flag spat_sexp_list
|
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;
|
1995-05-04 03:15:53 -07:00
|
|
|
exp
|
|
|
|
|
|
|
|
(* 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
|
|
|
|
| Unbound_value lid ->
|
|
|
|
fprintf ppf "Unbound value %a" longident lid
|
1995-05-04 03:15:53 -07:00
|
|
|
| Unbound_constructor lid ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "Unbound constructor %a" longident lid
|
1995-05-04 03:15:53 -07:00
|
|
|
| Unbound_label lid ->
|
2000-03-16 08:44:21 -08:00
|
|
|
fprintf ppf "Unbound record field label %a" longident lid
|
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),@ \
|
|
|
|
but is here applied to %i argument(s)@]"
|
|
|
|
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 ->
|
|
|
|
fprintf ppf "but is here mixed 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 ->
|
|
|
|
fprintf ppf "This pattern matches values of type")
|
|
|
|
(function ppf ->
|
|
|
|
fprintf ppf "but is here used to match values of type")
|
1995-05-04 03:15:53 -07:00
|
|
|
| Multiply_bound_variable ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "This variable is bound several times in this matching"
|
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 ->
|
|
|
|
fprintf ppf "but is here used with type")
|
1995-05-04 03:15:53 -07:00
|
|
|
| Apply_non_function typ ->
|
1996-04-22 04:15:41 -07:00
|
|
|
begin match (repr typ).desc with
|
1999-11-30 08:07:38 -08:00
|
|
|
Tarrow _ ->
|
2003-03-07 00:59:15 -08:00
|
|
|
fprintf ppf "This function is applied to too many arguments,@ ";
|
|
|
|
fprintf ppf "maybe you forgot a `;'"
|
1995-05-04 03:15:53 -07:00
|
|
|
| _ ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf
|
1996-05-20 09:43:29 -07:00
|
|
|
"This expression 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
|
2001-12-25 19:50:22 -08:00
|
|
|
"@[<v>@[<2>Expecting function 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
|
1995-05-04 03:15:53 -07:00
|
|
|
| Label_multiply_defined lid ->
|
2000-03-16 08:44:21 -08:00
|
|
|
fprintf ppf "The record field label %a is defined several times"
|
|
|
|
longident lid
|
2001-06-28 18:46:46 -07:00
|
|
|
| Label_missing labels ->
|
|
|
|
let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in
|
|
|
|
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
|
|
|
| Unbound_class cl ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "Unbound class %a" longident cl
|
1996-04-22 04:15:41 -07:00
|
|
|
| Virtual_class cl ->
|
2000-03-06 14:12:09 -08:00
|
|
|
fprintf ppf "One cannot create instances of 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
|
1996-04-22 04:15:41 -07:00
|
|
|
| Instance_variable_not_mutable v ->
|
2000-03-16 08:44:21 -08:00
|
|
|
fprintf ppf "The instance variable %s is not mutable" v
|
1996-05-26 06:42:34 -07:00
|
|
|
| Not_subtype(tr1, tr2) ->
|
2001-08-07 23:58:58 -07:00
|
|
|
report_subtyping_error ppf tr1 "is not a subtype of type" 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
|
2000-04-13 20:41:18 -07:00
|
|
|
| "" -> "but its first argument is not labeled"
|
2000-07-26 23:30:28 -07:00
|
|
|
| l -> sprintf "but its first argument is labeled ~%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")
|