1 (***********************************************************************)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. All rights reserved. This file is distributed *)
9 (* under the terms of the Q Public License version 1.0. *)
11 (***********************************************************************)
15 (* Typechecking for the core language *)
26 Unbound_value
of Longident.t
27 | Unbound_constructor
of Longident.t
28 | Unbound_label
of Longident.t
29 | Polymorphic_label
of Longident.t
30 | Constructor_arity_mismatch
of Longident.t
* int * int
31 | Label_mismatch
of Longident.t
* (type_expr
* type_expr
) list
32 | Pattern_type_clash
of (type_expr
* type_expr
) list
33 | Multiply_bound_variable
of string
34 | Orpat_vars
of Ident.t
35 | Expr_type_clash
of (type_expr
* type_expr
) list
36 | Apply_non_function
of type_expr
37 | Apply_wrong_label
of label
* type_expr
38 | Label_multiply_defined
of Longident.t
39 | Label_missing
of string list
40 | Label_not_mutable
of Longident.t
41 | Incomplete_format
of string
42 | Bad_conversion
of string * int * char
43 | Undefined_method
of type_expr
* string
44 | Undefined_inherited_method
of string
45 | Unbound_class
of Longident.t
46 | Virtual_class
of Longident.t
47 | Private_type
of type_expr
48 | Private_label
of Longident.t
* type_expr
49 | Unbound_instance_variable
of string
50 | Instance_variable_not_mutable
of string
51 | Not_subtype
of (type_expr
* type_expr
) list
* (type_expr
* type_expr
) list
53 | Value_multiply_overridden
of string
55 type_expr
* type_expr
* (type_expr
* type_expr
) list
* bool
56 | Too_many_arguments
of bool * type_expr
57 | Abstract_wrong_label
of label
* type_expr
58 | Scoping_let_module
of string * type_expr
59 | Masked_instance_variable
of Longident.t
60 | Not_a_variant_type
of Longident.t
61 | Incoherent_label_order
62 | Less_general
of string * (type_expr
* type_expr
) list
64 exception Error
of Location.t
* error
66 (* Forward declaration, to be filled in by Typemod.type_module *)
69 ref ((fun env md
-> assert false) :
70 Env.t
-> Parsetree.module_expr
-> Typedtree.module_expr
)
72 (* Forward declaration, to be filled in by Typeclass.class_structure *)
74 ref (fun env s
-> assert false :
75 Env.t
-> Location.t
-> Parsetree.class_structure
->
76 class_structure
* class_signature
* string list
)
79 Saving and outputting type information.
80 We keep these function names short, because they have to be
81 called each time we create a record of type [Typedtree.expression]
82 or [Typedtree.pattern] that will end up in the typed AST.
85 Stypes.record
(Stypes.Ti_expr node
);
89 Stypes.record
(Stypes.Ti_pat node
);
94 (* Typing of constants *)
96 let type_constant = function
97 Const_int _
-> instance
Predef.type_int
98 | Const_char _
-> instance
Predef.type_char
99 | Const_string _
-> instance
Predef.type_string
100 | Const_float _
-> instance
Predef.type_float
101 | Const_int32 _
-> instance
Predef.type_int32
102 | Const_int64 _
-> instance
Predef.type_int64
103 | Const_nativeint _
-> instance
Predef.type_nativeint
105 (* Specific version of type_option, using newty rather than newgenty *)
108 newty
(Tconstr
(Predef.path_option
,[ty
], ref Mnil
))
110 let option_none ty loc
=
111 let cnone = Env.lookup_constructor
(Longident.Lident
"None") Env.initial
in
112 { exp_desc
= Texp_construct
(cnone, []);
113 exp_type
= ty
; exp_loc
= loc
; exp_env
= Env.initial
}
115 let option_some texp
=
116 let csome = Env.lookup_constructor
(Longident.Lident
"Some") Env.initial
in
117 { exp_desc
= Texp_construct
(csome, [texp
]); exp_loc
= texp
.exp_loc
;
118 exp_type
= type_option texp
.exp_type
; exp_env
= texp
.exp_env
}
120 let extract_option_type env ty
=
121 match expand_head env ty
with {desc
= Tconstr
(path
, [ty
], _
)}
122 when Path.same path
Predef.path_option
-> ty
125 let rec extract_label_names sexp env ty
=
128 | Tconstr
(path
, _
, _
) ->
129 let td = Env.find_type path env
in
130 begin match td.type_kind
with
131 | Type_record
(fields
, _
, _
) ->
132 List.map
(fun (name
, _
, _
) -> name
) fields
133 | Type_abstract
when td.type_manifest
<> None
->
134 extract_label_names sexp env
(expand_head env
ty)
140 (* Typing of patterns *)
142 (* Creating new conjunctive types is not allowed when typing patterns *)
143 let unify_pat env pat expected_ty
=
145 unify env pat
.pat_type expected_ty
148 raise
(Error
(pat
.pat_loc
, Pattern_type_clash
(trace
)))
150 raise
(Typetexp.Error
(pat
.pat_loc
, Typetexp.Variant_tags
(l1
, l2
)))
152 (* make all Reither present in open variants *)
153 let finalize_variant pat
=
154 match pat
.pat_desc
with
155 Tpat_variant
(tag
, opat
, r
) ->
157 match expand_head pat
.pat_env pat
.pat_type
with
158 {desc
= Tvariant
row} -> r
:= row; row_repr
row
161 begin match row_field tag
row with
162 | Rabsent
-> assert false
163 | Reither
(true, [], _
, e
) when not
row.row_closed
->
164 set_row_field e
(Rpresent None
)
165 | Reither
(false, ty::tl
, _
, e
) when not
row.row_closed
->
166 set_row_field e
(Rpresent
(Some
ty));
167 begin match opat
with None
-> assert false
168 | Some pat
-> List.iter
(unify_pat pat
.pat_env pat
) (ty::tl
)
170 | Reither
(c
, l
, true, e
) when not
row.row_fixed
->
171 set_row_field e
(Reither
(c
, [], false, ref None
))
174 (* Force check of well-formedness WHY? *)
175 (* unify_pat pat.pat_env pat
176 (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
177 row_bound=(); row_fixed=false; row_name=None})); *)
180 let rec iter_pattern f p
=
182 iter_pattern_desc
(iter_pattern f
) p
.pat_desc
186 iter_pattern (function {pat_desc
=Tpat_variant _
} -> raise Exit
| _
-> ())
193 (* pattern environment *)
194 let pattern_variables = ref ([]: (Ident.t
* type_expr
) list
)
195 let pattern_force = ref ([] : (unit -> unit) list
)
196 let reset_pattern () =
197 pattern_variables := [];
200 let enter_variable loc name
ty =
201 if List.exists
(fun (id
, _
) -> Ident.name id
= name
) !pattern_variables
202 then raise
(Error
(loc
, Multiply_bound_variable name
));
203 let id = Ident.create name
in
204 pattern_variables := (id, ty) :: !pattern_variables;
207 let sort_pattern_variables vs
=
209 (fun (x
,_
) (y
,_
) -> Pervasives.compare
(Ident.name x
) (Ident.name y
))
212 let enter_orpat_variables loc env p1_vs p2_vs
=
213 (* unify_vars operate on sorted lists *)
215 let p1_vs = sort_pattern_variables p1_vs
216 and p2_vs
= sort_pattern_variables p2_vs
in
218 let rec unify_vars p1_vs p2_vs
= match p1_vs, p2_vs
with
219 | (x1
,t1
)::rem1
, (x2
,t2
)::rem2
when Ident.equal x1 x2
->
227 raise
(Error
(loc
, Pattern_type_clash
(trace
)))
229 (x2
,x1
)::unify_vars rem1 rem2
232 | (x
,_
)::_
, [] -> raise
(Error
(loc
, Orpat_vars x
))
233 | [],(x
,_
)::_
-> raise
(Error
(loc
, Orpat_vars x
))
234 | (x
,_
)::_
, (y
,_
)::_
->
236 if Ident.name x
< Ident.name y
then x
238 raise
(Error
(loc
, Orpat_vars
min_var)) in
239 unify_vars p1_vs p2_vs
241 let rec build_as_type env p
=
242 match p
.pat_desc
with
243 Tpat_alias
(p1
, _
) -> build_as_type env p1
245 let tyl = List.map
(build_as_type env
) pl
in
247 | Tpat_construct
(cstr
, pl
) ->
248 if cstr
.cstr_private
= Private
then p
.pat_type
else
249 let tyl = List.map
(build_as_type env
) pl
in
250 let ty_args, ty_res
= instance_constructor cstr
in
251 List.iter2
(fun (p
,ty) -> unify_pat env
{p
with pat_type
= ty})
252 (List.combine pl
tyl) ty_args;
254 | Tpat_variant
(l
, p'
, _
) ->
255 let ty = may_map
(build_as_type env
) p'
in
256 newty
(Tvariant
{row_fields
=[l
, Rpresent
ty]; row_more
=newvar
();
257 row_bound
=(); row_name
=None
;
258 row_fixed
=false; row_closed
=false})
260 let lbl = fst
(List.hd lpl
) in
261 if lbl.lbl_private
= Private
then p
.pat_type
else
262 let ty = newvar
() in
263 let ppl = List.map
(fun (l
,p
) -> l
.lbl_pos
, p
) lpl
in
265 let _, ty_arg
, ty_res
= instance_label
false lbl in
266 unify_pat env
{p
with pat_type
= ty} ty_res
;
268 lbl.lbl_mut
= Immutable
&& List.mem_assoc
lbl.lbl_pos
ppl &&
269 match (repr
lbl.lbl_arg
).desc
with Tpoly
_ -> false | _ -> true in
270 if refinable then begin
271 let arg = List.assoc
lbl.lbl_pos
ppl in
272 unify_pat env
{arg with pat_type
= build_as_type env
arg} ty_arg
274 let _, ty_arg'
, ty_res'
= instance_label
false lbl in
275 unify env ty_arg ty_arg'
;
276 unify_pat env p ty_res'
278 Array.iter
do_label lbl.lbl_all
;
280 | Tpat_or
(p1
, p2
, row) ->
283 let ty1 = build_as_type env p1
and ty2
= build_as_type env p2
in
284 unify_pat env
{p2
with pat_type
= ty2
} ty1;
287 let row = row_repr
row in
288 newty
(Tvariant
{row with row_closed
=false; row_more
=newvar
()})
290 | Tpat_any
| Tpat_var
_ | Tpat_constant
_ | Tpat_array
_ -> p
.pat_type
292 let build_or_pat env loc lid
=
294 try Env.lookup_type lid env
296 raise
(Typetexp.Error
(loc
, Typetexp.Unbound_type_constructor lid
))
298 let tyl = List.map
(fun _ -> newvar
()) decl
.type_params
in
300 let ty = expand_head env
(newty
(Tconstr
(path, tyl, ref Mnil
))) in
302 Tvariant
row when static_row
row -> row
303 | _ -> raise
(Error
(loc
, Not_a_variant_type lid
))
307 (fun (pats,fields
) (l
,f
) ->
308 match row_field_repr f
with
311 (l
, Reither
(true,[], true, ref None
)) :: fields
312 | Rpresent
(Some
ty) ->
313 (l
, Some
{pat_desc
=Tpat_any
; pat_loc
=Location.none
; pat_env
=env
;
316 (l
, Reither
(false, [ty], true, ref None
)) :: fields
318 ([],[]) (row_repr
row0).row_fields
in
320 { row_fields
= List.rev fields
; row_more
= newvar
(); row_bound
= ();
321 row_closed
= false; row_fixed
= false; row_name
= Some
(path, tyl) }
323 let ty = newty
(Tvariant
row) in
324 let gloc = {loc
with Location.loc_ghost
=true} in
325 let row'
= ref {row with row_more
=newvar
()} in
327 List.map
(fun (l
,p
) -> {pat_desc
=Tpat_variant
(l
,p
,row'
); pat_loc
=gloc;
328 pat_env
=env
; pat_type
=ty})
332 [] -> raise
(Error
(loc
, Not_a_variant_type lid
))
336 (fun pat pat0
-> {pat_desc
=Tpat_or
(pat0
,pat
,Some
row0);
337 pat_loc
=gloc; pat_env
=env
; pat_type
=ty})
339 rp { r with pat_loc
= loc
}
341 let rec find_record_qual = function
343 | (Longident.Ldot
(modname
, _), _) :: _ -> Some modname
344 | _ :: rest
-> find_record_qual rest
346 let type_label_a_list type_lid_a lid_a_list
=
347 match find_record_qual lid_a_list
with
348 | None
-> List.map type_lid_a lid_a_list
352 | (Longident.Lident
id), sarg
->
353 type_lid_a
(Longident.Ldot
(modname
, id), sarg
)
354 | lid_a
-> type_lid_a lid_a
)
357 let rec type_pat env sp
=
358 match sp
.ppat_desc
with
362 pat_loc
= sp
.ppat_loc
;
367 let id = enter_variable sp
.ppat_loc name
ty in
369 pat_desc
= Tpat_var
id;
370 pat_loc
= sp
.ppat_loc
;
373 | Ppat_alias
(sq
, name
) ->
374 let q = type_pat env sq
in
376 let ty_var = build_as_type env
q in
379 let id = enter_variable sp
.ppat_loc name
ty_var in
381 pat_desc
= Tpat_alias
(q, id);
382 pat_loc
= sp
.ppat_loc
;
383 pat_type
= q.pat_type
;
385 | Ppat_constant cst
->
387 pat_desc
= Tpat_constant cst
;
388 pat_loc
= sp
.ppat_loc
;
389 pat_type
= type_constant cst
;
392 let pl = List.map
(type_pat env
) spl
in
394 pat_desc
= Tpat_tuple
pl;
395 pat_loc
= sp
.ppat_loc
;
396 pat_type
= newty
(Ttuple
(List.map
(fun p
-> p
.pat_type
) pl));
398 | Ppat_construct
(lid
, sarg
, explicit_arity
) ->
401 Env.lookup_constructor lid env
403 raise
(Error
(sp
.ppat_loc
, Unbound_constructor lid
)) in
407 | Some
{ppat_desc
= Ppat_tuple spl
} when explicit_arity
-> spl
408 | Some
{ppat_desc
= Ppat_tuple spl
} when constr.cstr_arity
> 1 -> spl
409 | Some
({ppat_desc
= Ppat_any
} as sp
) when constr.cstr_arity
> 1 ->
410 replicate_list sp
constr.cstr_arity
412 if List.length
sargs <> constr.cstr_arity
then
413 raise
(Error
(sp
.ppat_loc
, Constructor_arity_mismatch
(lid
,
414 constr.cstr_arity
, List.length
sargs)));
415 let args = List.map
(type_pat env
) sargs in
416 let (ty_args, ty_res
) = instance_constructor
constr in
417 List.iter2
(unify_pat env
) args ty_args;
419 pat_desc
= Tpat_construct
(constr, args);
420 pat_loc
= sp
.ppat_loc
;
423 | Ppat_variant
(l
, sarg
) ->
424 let arg = may_map
(type_pat env
) sarg
in
425 let arg_type = match arg with None
-> [] | Some
arg -> [arg.pat_type
] in
426 let row = { row_fields
=
427 [l
, Reither
(arg = None
, arg_type, true, ref None
)];
430 row_more
= newvar
();
434 pat_desc
= Tpat_variant
(l
, arg, ref {row with row_more
= newvar
()});
435 pat_loc
= sp
.ppat_loc
;
436 pat_type
= newty
(Tvariant
row);
438 | Ppat_record lid_sp_list
->
439 let rec check_duplicates = function
441 | (lid
, sarg
) :: remainder
->
442 if List.mem_assoc lid remainder
443 then raise
(Error
(sp
.ppat_loc
, Label_multiply_defined lid
))
444 else check_duplicates remainder
in
445 check_duplicates lid_sp_list
;
447 let type_label_pat (lid
, sarg
) =
450 Env.lookup_label lid env
452 raise
(Error
(sp
.ppat_loc
, Unbound_label lid
)) in
454 let (vars
, ty_arg
, ty_res
) = instance_label
false label in
455 if vars
= [] then end_def
();
459 raise
(Error
(sp
.ppat_loc
, Label_mismatch
(lid
, trace
)))
461 let arg = type_pat env sarg
in
462 unify_pat env
arg ty_arg
;
463 if vars
<> [] then begin
466 List.iter generalize vars
;
467 let instantiated tv
=
468 let tv = expand_head env
tv in
469 tv.desc
<> Tvar
|| tv.level
<> generic_level
in
470 if List.exists
instantiated vars
then
471 raise
(Error
(sp
.ppat_loc
, Polymorphic_label lid
))
476 pat_desc
= Tpat_record
(type_label_a_list type_label_pat lid_sp_list
);
477 pat_loc
= sp
.ppat_loc
;
481 let pl = List.map
(type_pat env
) spl
in
482 let ty_elt = newvar
() in
483 List.iter
(fun p
-> unify_pat env p
ty_elt) pl;
485 pat_desc
= Tpat_array
pl;
486 pat_loc
= sp
.ppat_loc
;
487 pat_type
= instance
(Predef.type_array
ty_elt);
489 | Ppat_or
(sp1
, sp2
) ->
490 let initial_pattern_variables = !pattern_variables in
491 let p1 = type_pat env sp1
in
492 let p1_variables = !pattern_variables in
493 pattern_variables := initial_pattern_variables ;
494 let p2 = type_pat env sp2
in
495 let p2_variables = !pattern_variables in
496 unify_pat env
p2 p1.pat_type
;
498 enter_orpat_variables sp
.ppat_loc env
p1_variables p2_variables in
499 pattern_variables := p1_variables ;
501 pat_desc
= Tpat_or
(p1, alpha_pat
alpha_env p2, None
);
502 pat_loc
= sp
.ppat_loc
;
503 pat_type
= p1.pat_type
;
505 | Ppat_constraint
(sp
, sty
) ->
506 let p = type_pat env sp
in
507 let ty, force
= Typetexp.transl_simple_type_delayed env sty
in
509 pattern_force := force
:: !pattern_force;
512 build_or_pat env sp
.ppat_loc lid
515 let v = !r in r := []; v
517 let add_pattern_variables env
=
518 let pv = get_ref pattern_variables in
521 Env.add_value
id {val_type
= ty; val_kind
= Val_reg
} env
)
524 let type_pattern env spat
=
526 let pat = type_pat env spat
in
527 let new_env = add_pattern_variables env
in
528 (pat, new_env, get_ref pattern_force)
530 let type_pattern_list env spatl
=
532 let patl = List.map
(type_pat env
) spatl
in
533 let new_env = add_pattern_variables env
in
534 (patl, new_env, get_ref pattern_force)
536 let type_class_arg_pattern cl_num val_env met_env l spat
=
538 let pat = type_pat val_env spat
in
539 if has_variants pat then begin
540 Parmatch.pressure_variants val_env
[pat];
541 iter_pattern finalize_variant pat
543 List.iter
(fun f
-> f
()) (get_ref pattern_force);
544 if is_optional l
then unify_pat val_env
pat (type_option (newvar
()));
547 (fun (id, ty) (pv, env
) ->
548 let id'
= Ident.create
(Ident.name
id) in
550 Env.add_value
id'
{val_type
= ty;
551 val_kind
= Val_ivar
(Immutable
, cl_num
)}
553 !pattern_variables ([], met_env
)
555 let val_env = add_pattern_variables val_env in
556 (pat, pv, val_env, met_env
)
558 let mkpat d
= { ppat_desc
= d
; ppat_loc
= Location.none
}
560 let type_self_pattern cl_num privty
val_env met_env par_env spat
=
562 mkpat (Ppat_alias
(mkpat(Ppat_alias
(spat, "selfpat-*")),
563 "selfpat-" ^ cl_num
))
566 let pat = type_pat val_env spat in
567 List.iter
(fun f
-> f
()) (get_ref pattern_force);
568 let meths = ref Meths.empty
in
569 let vars = ref Vars.empty
in
570 let pv = !pattern_variables in
571 pattern_variables := [];
572 let (val_env, met_env
, par_env
) =
574 (fun (id, ty) (val_env, met_env
, par_env
) ->
575 (Env.add_value
id {val_type
= ty; val_kind
= Val_unbound
} val_env,
576 Env.add_value
id {val_type
= ty;
577 val_kind
= Val_self
(meths, vars, cl_num
, privty
)}
579 Env.add_value
id {val_type
= ty; val_kind
= Val_unbound
} par_env
))
580 pv (val_env, met_env
, par_env
)
582 (pat, meths, vars, val_env, met_env
, par_env
)
584 let delayed_checks = ref []
585 let reset_delayed_checks () = delayed_checks := []
586 let add_delayed_check f
= delayed_checks := f
:: !delayed_checks
587 let force_delayed_checks () =
588 (* checks may change type levels *)
589 let snap = Btype.snapshot
() in
590 List.iter
(fun f
-> f
()) (List.rev
!delayed_checks);
591 reset_delayed_checks ();
595 (* Generalization criterion for expressions *)
597 let rec is_nonexpansive exp
=
598 match exp
.exp_desc
with
599 Texp_ident
(_,_) -> true
600 | Texp_constant
_ -> true
601 | Texp_let
(rec_flag
, pat_exp_list
, body
) ->
602 List.for_all
(fun (pat, exp
) -> is_nonexpansive exp
) pat_exp_list
&&
604 | Texp_function
_ -> true
605 | Texp_apply
(e
, (None
,_)::el
) ->
606 is_nonexpansive e
&& List.for_all is_nonexpansive_opt
(List.map fst el
)
608 List.for_all
is_nonexpansive el
609 | Texp_construct
(_, el
) ->
610 List.for_all
is_nonexpansive el
611 | Texp_variant
(_, arg) -> is_nonexpansive_opt
arg
612 | Texp_record
(lbl_exp_list
, opt_init_exp
) ->
614 (fun (lbl, exp
) -> lbl.lbl_mut
= Immutable
&& is_nonexpansive exp
)
616 && is_nonexpansive_opt opt_init_exp
617 | Texp_field
(exp
, lbl) -> is_nonexpansive exp
618 | Texp_array
[] -> true
619 | Texp_ifthenelse
(cond
, ifso
, ifnot
) ->
620 is_nonexpansive ifso
&& is_nonexpansive_opt ifnot
621 | Texp_sequence
(e1
, e2
) -> is_nonexpansive e2
(* PR#4354 *)
622 | Texp_new
(_, cl_decl
) when Ctype.class_type_arity cl_decl
.cty_type
> 0 ->
624 (* Note: nonexpansive only means no _observable_ side effects *)
625 | Texp_lazy e
-> is_nonexpansive e
626 | Texp_object
({cl_field
=fields
}, {cty_vars
=vars}, _) ->
631 | Cf_val
(_,_,e
,_) -> incr
count; is_nonexpansive_opt e
632 | Cf_init e
-> is_nonexpansive e
633 | Cf_inher
_ | Cf_let
_ -> false)
635 Vars.fold
(fun _ (mut
,_,_) b
-> decr
count; b
&& mut
= Immutable
)
640 and is_nonexpansive_opt
= function
642 | Some e
-> is_nonexpansive e
644 (* Typing of printf formats.
645 (Handling of * modifiers contributed by Thorsten Ohl.) *)
647 external string_to_format
:
648 string -> ('a
, 'b
, 'c
, 'd
, 'e
, 'f
) format6
= "%identity"
649 external format_to_string
:
650 ('a
, 'b
, 'c
, 'd
, 'e
, 'f
) format6
-> string = "%identity"
652 let type_format loc fmt
=
654 let ty_arrow gty
ty = newty
(Tarrow
("", instance gty
, ty, Cok
)) in
656 let bad_conversion fmt i c
=
657 raise
(Error
(loc
, Bad_conversion
(fmt
, i
, c
))) in
658 let incomplete_format fmt
=
659 raise
(Error
(loc
, Incomplete_format fmt
)) in
661 let range_closing_index fmt i
=
663 let len = String.length fmt
in
665 if j
>= len then incomplete_format fmt
else
666 try String.index_from fmt j '
]'
with
667 | Not_found
-> incomplete_format fmt
in
669 if j
>= len then incomplete_format fmt
else
671 | '
]'
-> find_closing (j
+ 1)
672 | c
-> find_closing j
in
674 if j
>= len then incomplete_format fmt
else
676 | '^'
-> skip_pos (j
+ 1)
678 find_closing (skip_neg (i
+ 1)) in
680 let rec type_in_format fmt
=
682 let len = String.length fmt
in
684 let ty_input = newvar
()
685 and ty_result
= newvar
()
686 and ty_aresult
= newvar
()
687 and ty_uresult
= newvar
() in
691 let rec scan_format i
=
694 then ty_uresult
, ty_result
695 else incomplete_format fmt
else
697 | '
%'
-> scan_opts i
(i
+ 1)
698 | _ -> scan_format (i
+ 1)
700 if j
>= len then incomplete_format fmt
else
702 | '
_'
-> scan_rest
true i
(j
+ 1)
703 | _ -> scan_rest
false i j
704 and scan_rest skip i j
=
705 let rec scan_flags i j
=
706 if j
>= len then incomplete_format fmt
else
708 | '#'
| '
0'
| '
-'
| ' '
| '
+'
-> scan_flags i
(j
+ 1)
709 | _ -> scan_width i j
710 and scan_width i j
= scan_width_or_prec_value scan_precision i j
711 and scan_decimal_string scan i j
=
712 if j
>= len then incomplete_format fmt
else
714 | '
0'
.. '
9'
-> scan_decimal_string scan i
(j
+ 1)
716 and scan_width_or_prec_value scan i j
=
717 if j
>= len then incomplete_format fmt
else
720 let ty_uresult, ty_result
= scan i
(j
+ 1) in
721 ty_uresult, ty_arrow Predef.type_int ty_result
722 | '
-'
| '
+'
-> scan_decimal_string scan i
(j
+ 1)
723 | _ -> scan_decimal_string scan i j
724 and scan_precision i j
=
725 if j
>= len then incomplete_format fmt
else
727 | '
.'
-> scan_width_or_prec_value scan_conversion i
(j
+ 1)
728 | _ -> scan_conversion i j
730 and conversion j ty_arg
=
731 let ty_uresult, ty_result
= scan_format (j
+ 1) in
733 if skip
then ty_result
else ty_arrow ty_arg ty_result
735 and scan_conversion i j
=
736 if j
>= len then incomplete_format fmt
else
738 | '
%'
| '
!'
-> scan_format (j
+ 1)
739 | 's'
| 'S'
-> conversion j
Predef.type_string
741 let j = range_closing_index fmt
j in
742 conversion
j Predef.type_string
743 | 'c'
| 'C'
-> conversion
j Predef.type_char
744 | 'd'
| 'i'
| 'o'
| 'x'
| 'X'
| 'u'
| 'N'
->
745 conversion
j Predef.type_int
746 | 'f'
| 'e'
| 'E'
| 'g'
| 'G'
| 'F'
-> conversion
j Predef.type_float
747 | 'B'
| 'b'
-> conversion
j Predef.type_bool
749 let ty_arg = newvar
() in
750 let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult
) in
751 let ty_uresult, ty_result
= conversion
j ty_arg in
752 ty_uresult, ty_arrow ty_a ty_result
754 let ty_arg = newvar
() in
755 let ty_r = ty_arrow ty_input ty_arg in
756 let ty_uresult, ty_result
= conversion
j ty_arg in
757 ty_arrow ty_r ty_uresult, ty_result
758 | 't'
-> conversion
j (ty_arrow ty_input ty_aresult
)
759 | 'l'
| 'n'
| 'L'
as c
->
761 if j >= len then conversion
(j - 1) Predef.type_int
else begin
763 | 'd'
| 'i'
| 'o'
| 'x'
| 'X'
| 'u'
->
766 | 'l'
-> Predef.type_int32
767 | 'n'
-> Predef.type_nativeint
768 | _ -> Predef.type_int64
in
770 | c
-> conversion
(j - 1) Predef.type_int
774 if j >= len then incomplete_format fmt
else
776 Printf.CamlinternalPr.Tformat.sub_format
777 (fun fmt
-> incomplete_format (format_to_string fmt
))
778 (fun fmt
-> bad_conversion (format_to_string fmt
))
779 c
(string_to_format fmt
) j in
780 let sfmt = String.sub fmt
j (sj - 2 - j) in
781 let ty_sfmt = type_in_format sfmt in
783 | '
{'
-> conversion
(sj - 1) ty_sfmt
784 | _ -> incr
meta; conversion
(j - 1) ty_sfmt end
785 | '
)'
when !meta > 0 -> decr
meta; scan_format (j + 1)
786 | c
-> bad_conversion fmt i c
in
789 let ty_ureader, ty_args = scan_format 0 in
792 (Predef.path_format6
,
793 [ty_args; ty_input; ty_aresult
; ty_ureader; ty_uresult; ty_result
],
798 (* Approximate the type of an expression, for better recursion *)
800 let rec approx_type env sty
=
801 match sty
.ptyp_desc
with
802 Ptyp_arrow
(p, _, sty
) ->
803 let ty1 = if is_optional
p then type_option (newvar
()) else newvar
() in
804 newty
(Tarrow
(p, ty1, approx_type env sty
, Cok
))
806 newty
(Ttuple
(List.map
(approx_type env
) args))
807 | Ptyp_constr
(lid
, ctl
) ->
809 let (path, decl
) = Env.lookup_type lid env
in
810 if List.length ctl
<> decl
.type_arity
then raise Not_found
;
811 let tyl = List.map
(approx_type env
) ctl
in
813 with Not_found
-> newvar
()
817 let rec type_approx env sexp
=
818 match sexp
.pexp_desc
with
819 Pexp_let
(_, _, e
) -> type_approx env e
820 | Pexp_function
(p,_,(_,e
)::_) when is_optional
p ->
821 newty
(Tarrow
(p, type_option (newvar
()), type_approx env e
, Cok
))
822 | Pexp_function
(p,_,(_,e
)::_) ->
823 newty
(Tarrow
(p, newvar
(), type_approx env e
, Cok
))
824 | Pexp_match
(_, (_,e
)::_) -> type_approx env e
825 | Pexp_try
(e
, _) -> type_approx env e
826 | Pexp_tuple l
-> newty
(Ttuple
(List.map
(type_approx env
) l
))
827 | Pexp_ifthenelse
(_,e
,_) -> type_approx env e
828 | Pexp_sequence
(_,e
) -> type_approx env e
829 | Pexp_constraint
(e
, sty1
, sty2
) ->
830 let approx_ty_opt = function
832 | Some sty
-> approx_type env sty
834 let ty = type_approx env e
835 and ty1 = approx_ty_opt sty1
836 and ty2
= approx_ty_opt sty2
in
837 begin try unify env
ty ty1 with Unify trace
->
838 raise
(Error
(sexp
.pexp_loc
, Expr_type_clash trace
))
840 if sty2
= None
then ty1 else ty2
843 (* List labels in a function type, and whether return type is a variable *)
844 let rec list_labels_aux env visited ls ty_fun
=
845 let ty = expand_head env ty_fun
in
846 if List.memq
ty visited
then
848 else match ty.desc
with
849 Tarrow
(l
, _, ty_res
, _) ->
850 list_labels_aux env
(ty::visited
) (l
::ls
) ty_res
852 List.rev ls
, ty.desc
= Tvar
854 let list_labels env
ty = list_labels_aux env
[] [] ty
856 (* Check that all univars are safe in a type *)
857 let check_univars env kind exp ty_expected
vars =
858 (* need to expand twice? cf. Ctype.unify2 *)
859 let vars = List.map
(expand_head env
) vars in
860 let vars = List.map
(expand_head env
) vars in
866 if t.desc
= Tvar
&& t.level
= generic_level
then
867 (log_type
t; t.desc
<- Tunivar
; true)
870 if List.length
vars = List.length
vars'
then () else
871 let ty = newgenty
(Tpoly
(repr exp
.exp_type
, vars'
))
872 and ty_expected
= repr ty_expected
in
873 raise
(Error
(exp
.exp_loc
,
874 Less_general
(kind
, [ty, ty; ty_expected
, ty_expected
])))
876 (* Check that a type is not a function *)
877 let check_application_result env statement exp
=
878 match (expand_head env exp
.exp_type
).desc
with
880 Location.prerr_warning exp
.exp_loc
Warnings.Partial_application
882 | Tconstr
(p, _, _) when Path.same
p Predef.path_unit
-> ()
885 Location.prerr_warning exp
.exp_loc
Warnings.Statement_type
887 (* Hack to allow coercion of self. Will clean-up later. *)
888 let self_coercion = ref ([] : (Path.t * Location.t list
ref) list
)
890 (* Typing of expressions *)
892 let unify_exp env exp expected_ty
=
893 (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
894 Printtyp.raw_type_expr expected_ty; *)
896 unify env exp
.exp_type expected_ty
899 raise
(Error
(exp
.exp_loc
, Expr_type_clash
(trace
)))
901 raise
(Typetexp.Error
(exp
.exp_loc
, Typetexp.Variant_tags
(l1
, l2
)))
903 let rec type_exp env sexp
=
904 match sexp
.pexp_desc
with
907 let (path, desc
) = Env.lookup_value lid env
in
910 begin match desc
.val_kind
with
911 Val_ivar
(_, cl_num
) ->
913 Env.lookup_value
(Longident.Lident
("self-" ^ cl_num
)) env
915 Texp_instvar
(self_path
, path)
916 | Val_self
(_, _, cl_num
, _) ->
918 Env.lookup_value
(Longident.Lident
("self-" ^ cl_num
)) env
920 Texp_ident
(path, desc
)
922 raise
(Error
(sexp
.pexp_loc
, Masked_instance_variable lid
))
924 Texp_ident
(path, desc
)
926 exp_loc
= sexp
.pexp_loc
;
927 exp_type
= instance desc
.val_type
;
930 raise
(Error
(sexp
.pexp_loc
, Unbound_value lid
))
932 | Pexp_constant cst
->
934 exp_desc
= Texp_constant cst
;
935 exp_loc
= sexp
.pexp_loc
;
936 exp_type
= type_constant cst
;
938 | Pexp_let
(rec_flag
, spat_sexp_list
, sbody
) ->
939 let (pat_exp_list
, new_env) = type_let
env rec_flag spat_sexp_list
in
940 let body = type_exp new_env sbody
in
942 exp_desc
= Texp_let
(rec_flag
, pat_exp_list
, body);
943 exp_loc
= sexp
.pexp_loc
;
944 exp_type
= body.exp_type
;
946 | Pexp_function
_ -> (* defined in type_expect *)
947 type_expect
env sexp
(newvar
())
948 | Pexp_apply
(sfunct
, sargs) ->
949 begin_def
(); (* one more level for non-returning functions *)
950 if !Clflags.principal
then begin_def
();
951 let funct = type_exp env sfunct
in
952 if !Clflags.principal
then begin
954 generalize_structure
funct.exp_type
956 let rec lower_args seen ty_fun
=
957 let ty = expand_head
env ty_fun
in
958 if List.memq
ty seen
then () else
960 Tarrow
(l
, ty_arg, ty_fun
, com
) ->
961 unify_var
env (newvar
()) ty_arg;
962 lower_args (ty::seen
) ty_fun
965 let ty = instance
funct.exp_type
in
969 let (args, ty_res
) = type_application
env funct sargs in
971 unify_var
env (newvar
()) funct.exp_type
;
973 exp_desc
= Texp_apply
(funct, args);
974 exp_loc
= sexp
.pexp_loc
;
977 | Pexp_match
(sarg
, caselist
) ->
978 let arg = type_exp env sarg
in
979 let ty_res = newvar
() in
981 type_cases
env arg.exp_type
ty_res (Some sexp
.pexp_loc
) caselist
984 exp_desc
= Texp_match
(arg, cases, partial
);
985 exp_loc
= sexp
.pexp_loc
;
988 | Pexp_try
(sbody
, caselist
) ->
989 let body = type_exp env sbody
in
991 type_cases
env (instance
Predef.type_exn
) body.exp_type None
994 exp_desc
= Texp_try
(body, cases);
995 exp_loc
= sexp
.pexp_loc
;
996 exp_type
= body.exp_type
;
998 | Pexp_tuple sexpl
->
999 let expl = List.map
(type_exp env) sexpl
in
1001 exp_desc
= Texp_tuple
expl;
1002 exp_loc
= sexp
.pexp_loc
;
1003 exp_type
= newty
(Ttuple
(List.map
(fun exp
-> exp
.exp_type
) expl));
1005 | Pexp_construct
(lid
, sarg
, explicit_arity
) ->
1006 type_construct
env sexp
.pexp_loc lid sarg explicit_arity
(newvar
())
1007 | Pexp_variant
(l
, sarg
) ->
1008 let arg = may_map
(type_exp env) sarg
in
1009 let arg_type = may_map
(fun arg -> arg.exp_type
) arg in
1011 exp_desc
= Texp_variant
(l
, arg);
1012 exp_loc
= sexp
.pexp_loc
;
1013 exp_type
= newty
(Tvariant
{row_fields
= [l
, Rpresent
arg_type];
1014 row_more
= newvar
();
1020 | Pexp_record
(lid_sexp_list
, opt_sexp
) ->
1021 let ty = newvar
() in
1022 let num_fields = ref 0 in
1023 let type_label_exp (lid
, sarg
) =
1026 Env.lookup_label lid
env
1028 raise
(Error
(sexp
.pexp_loc
, Unbound_label lid
)) in
1030 if !Clflags.principal
then begin_def
();
1031 let (vars, ty_arg, ty_res) = instance_label
true label in
1032 if !Clflags.principal
then begin
1034 generalize_structure
ty_arg;
1035 generalize_structure
ty_res
1038 unify
env (instance
ty_res) ty
1040 raise
(Error
(sexp
.pexp_loc
, Label_mismatch
(lid
, trace
)))
1042 let arg = type_argument
env sarg
ty_arg in
1044 if vars <> [] && not
(is_nonexpansive arg) then
1045 generalize_expansive
env arg.exp_type
;
1046 check_univars env "field value" arg label.lbl_arg
vars;
1047 num_fields := Array.length
label.lbl_all
;
1048 if label.lbl_private
= Private
then
1049 raise
(Error
(sexp
.pexp_loc
, Private_type
ty));
1050 (label, {arg with exp_type
= instance
arg.exp_type
}) in
1051 let lbl_exp_list = type_label_a_list type_label_exp lid_sexp_list
in
1052 let rec check_duplicates seen_pos lid_sexp lbl_exp
=
1053 match (lid_sexp
, lbl_exp
) with
1054 ((lid
, _) :: rem1
, (lbl, _) :: rem2
) ->
1055 if List.mem
lbl.lbl_pos seen_pos
1056 then raise
(Error
(sexp
.pexp_loc
, Label_multiply_defined lid
))
1057 else check_duplicates (lbl.lbl_pos
:: seen_pos
) rem1 rem2
1059 check_duplicates [] lid_sexp_list
lbl_exp_list;
1061 match opt_sexp
, lbl_exp_list with
1063 | Some sexp
, (lbl, _) :: _ ->
1064 let ty_exp = newvar
() in
1065 let unify_kept lbl =
1066 if List.for_all
(fun (lbl'
,_) -> lbl'
.lbl_pos
<> lbl.lbl_pos
)
1069 let _, ty_arg1
, ty_res1
= instance_label
false lbl
1070 and _, ty_arg2
, ty_res2
= instance_label
false lbl in
1071 unify
env ty_exp ty_res1
;
1072 unify
env ty ty_res2
;
1073 unify
env ty_arg1 ty_arg2
1075 Array.iter
unify_kept lbl.lbl_all
;
1076 Some
(type_expect
env sexp
ty_exp)
1079 if opt_sexp
= None
&& List.length lid_sexp_list
<> !num_fields then begin
1080 let present_indices =
1081 List.map
(fun (lbl, _) -> lbl.lbl_pos
) lbl_exp_list in
1082 let label_names = extract_label_names sexp
env ty in
1083 let rec missing_labels n
= function
1086 if List.mem n
present_indices then missing_labels (n
+ 1) rem
1087 else lbl :: missing_labels (n
+ 1) rem
1089 let missing = missing_labels 0 label_names in
1090 raise
(Error
(sexp
.pexp_loc
, Label_missing
missing))
1092 else if opt_sexp
<> None
&& List.length lid_sexp_list
= !num_fields then
1093 Location.prerr_warning sexp
.pexp_loc
Warnings.Useless_record_with
;
1095 exp_desc
= Texp_record
(lbl_exp_list, opt_exp);
1096 exp_loc
= sexp
.pexp_loc
;
1099 | Pexp_field
(sarg
, lid
) ->
1100 let arg = type_exp env sarg
in
1103 Env.lookup_label lid
env
1105 raise
(Error
(sexp
.pexp_loc
, Unbound_label lid
)) in
1106 let (_, ty_arg, ty_res) = instance_label
false label in
1107 unify_exp env arg ty_res;
1109 exp_desc
= Texp_field
(arg, label);
1110 exp_loc
= sexp
.pexp_loc
;
1113 | Pexp_setfield
(srecord
, lid
, snewval
) ->
1114 let record = type_exp env srecord
in
1117 Env.lookup_label lid
env
1119 raise
(Error
(sexp
.pexp_loc
, Unbound_label lid
)) in
1120 if label.lbl_mut
= Immutable
then
1121 raise
(Error
(sexp
.pexp_loc
, Label_not_mutable lid
));
1123 let (vars, ty_arg, ty_res) = instance_label
true label in
1124 unify_exp env record ty_res;
1125 let newval = type_expect
env snewval
ty_arg in
1127 if vars <> [] && not
(is_nonexpansive newval) then
1128 generalize_expansive
env newval.exp_type
;
1129 check_univars env "field value" newval label.lbl_arg
vars;
1130 if label.lbl_private
= Private
then
1131 raise
(Error
(sexp
.pexp_loc
, Private_label
(lid
, ty_res)));
1133 exp_desc
= Texp_setfield
(record, label, newval);
1134 exp_loc
= sexp
.pexp_loc
;
1135 exp_type
= instance
Predef.type_unit
;
1137 | Pexp_array
(sargl
) ->
1138 let ty = newvar
() in
1139 let argl = List.map
(fun sarg
-> type_expect
env sarg
ty) sargl
in
1141 exp_desc
= Texp_array
argl;
1142 exp_loc
= sexp
.pexp_loc
;
1143 exp_type
= instance
(Predef.type_array
ty);
1145 | Pexp_ifthenelse
(scond
, sifso
, sifnot
) ->
1146 let cond = type_expect
env scond
(instance
Predef.type_bool
) in
1147 begin match sifnot
with
1149 let ifso = type_expect
env sifso
(instance
Predef.type_unit
) in
1151 exp_desc
= Texp_ifthenelse
(cond, ifso, None
);
1152 exp_loc
= sexp
.pexp_loc
;
1153 exp_type
= instance
Predef.type_unit
;
1156 let ifso = type_exp env sifso
in
1157 let ifnot = type_expect
env sifnot
ifso.exp_type
in
1159 exp_desc
= Texp_ifthenelse
(cond, ifso, Some
ifnot);
1160 exp_loc
= sexp
.pexp_loc
;
1161 exp_type
= ifso.exp_type
;
1164 | Pexp_sequence
(sexp1
, sexp2
) ->
1165 let exp1 = type_statement
env sexp1
in
1166 let exp2 = type_exp env sexp2
in
1168 exp_desc
= Texp_sequence
(exp1, exp2);
1169 exp_loc
= sexp
.pexp_loc
;
1170 exp_type
= exp2.exp_type
;
1172 | Pexp_while
(scond
, sbody
) ->
1173 let cond = type_expect
env scond
(instance
Predef.type_bool
) in
1174 let body = type_statement
env sbody
in
1176 exp_desc
= Texp_while
(cond, body);
1177 exp_loc
= sexp
.pexp_loc
;
1178 exp_type
= instance
Predef.type_unit
;
1180 | Pexp_for
(param
, slow
, shigh
, dir
, sbody
) ->
1181 let low = type_expect
env slow
(instance
Predef.type_int
) in
1182 let high = type_expect
env shigh
(instance
Predef.type_int
) in
1184 Env.enter_value param
{val_type
= instance
Predef.type_int
;
1185 val_kind
= Val_reg
} env in
1186 let body = type_statement
new_env sbody
in
1188 exp_desc
= Texp_for
(id, low, high, dir
, body);
1189 exp_loc
= sexp
.pexp_loc
;
1190 exp_type
= instance
Predef.type_unit
;
1192 | Pexp_constraint
(sarg
, sty
, sty'
) ->
1194 match (sty
, sty'
) with
1195 (None
, None
) -> (* Case actually unused *)
1196 let arg = type_exp env sarg
in
1198 | (Some sty
, None
) ->
1199 if !Clflags.principal
then begin_def
();
1200 let ty = Typetexp.transl_simple_type
env false sty
in
1201 if !Clflags.principal
then begin
1203 generalize_structure
ty;
1204 let ty1 = instance
ty and ty2
= instance
ty in
1205 (type_expect
env sarg
ty1, ty2
)
1207 (type_expect
env sarg
ty, ty)
1208 | (None
, Some sty'
) ->
1210 Typetexp.transl_simple_type_delayed
env sty'
1212 let arg = type_exp env sarg
in
1213 begin match arg.exp_desc
, !self_coercion, (repr
ty'
).desc
with
1214 Texp_ident
(_, {val_kind
=Val_self
_}), (path,r) :: _,
1215 Tconstr
(path'
,_,_) when Path.same
path path'
->
1216 r := sexp
.pexp_loc
:: !r;
1219 let ty, b
= enlarge_type
env ty'
in
1221 begin try Ctype.unify
env arg.exp_type
ty with Unify trace
->
1222 raise
(Error
(sarg
.pexp_loc
,
1223 Coercion_failure
(ty'
, full_expand
env ty'
, trace
, b
)))
1227 | (Some sty
, Some sty'
) ->
1229 Typetexp.transl_simple_type_delayed
env sty
1231 Typetexp.transl_simple_type_delayed
env sty'
1234 let force''
= subtype
env ty ty'
in
1235 force (); force'
(); force''
()
1236 with Subtype
(tr1
, tr2
) ->
1237 raise
(Error
(sexp
.pexp_loc
, Not_subtype
(tr1
, tr2
)))
1239 (type_expect
env sarg
ty, ty'
)
1242 exp_desc
= arg.exp_desc
;
1243 exp_loc
= arg.exp_loc
;
1246 | Pexp_when
(scond
, sbody
) ->
1247 let cond = type_expect
env scond
(instance
Predef.type_bool
) in
1248 let body = type_exp env sbody
in
1250 exp_desc
= Texp_when
(cond, body);
1251 exp_loc
= sexp
.pexp_loc
;
1252 exp_type
= body.exp_type
;
1254 | Pexp_send
(e
, met
) ->
1255 if !Clflags.principal
then begin_def
();
1256 let obj = type_exp env e
in
1259 match obj.exp_desc
with
1260 Texp_ident
(path, {val_kind
= Val_self
(meths, _, _, privty
)}) ->
1262 filter_self_method
env met Private
meths privty
1264 if (repr typ
).desc
= Tvar
then
1265 Location.prerr_warning sexp
.pexp_loc
1266 (Warnings.Undeclared_virtual_method met
);
1267 (Texp_send
(obj, Tmeth_val
id), typ
)
1268 | Texp_ident
(path, {val_kind
= Val_anc
(methods
, cl_num
)}) ->
1270 begin try List.assoc met methods
with Not_found
->
1271 raise
(Error
(e
.pexp_loc
, Undefined_inherited_method met
))
1275 Env.lookup_value
(Longident.Lident
("selfpat-" ^ cl_num
)) env,
1276 Env.lookup_value
(Longident.Lident
("self-" ^cl_num
)) env
1278 (_, ({val_kind
= Val_self
(meths, _, _, privty
)} as desc
)),
1281 filter_self_method
env met Private
meths privty
1283 let method_type = newvar
() in
1284 let (obj_ty
, res_ty
) = filter_arrow
env method_type "" in
1285 unify
env obj_ty desc
.val_type
;
1286 unify
env res_ty
(instance typ
);
1287 (Texp_apply
({ exp_desc
= Texp_ident
(Path.Pident
method_id,
1288 {val_type
= method_type;
1289 val_kind
= Val_reg
});
1290 exp_loc
= sexp
.pexp_loc
;
1291 exp_type
= method_type;
1293 [Some
{exp_desc
= Texp_ident
(path, desc
);
1294 exp_loc
= obj.exp_loc
;
1295 exp_type
= desc
.val_type
;
1303 (Texp_send
(obj, Tmeth_name met
),
1304 filter_method
env met Public
obj.exp_type
)
1306 if !Clflags.principal
then begin
1308 generalize_structure typ
;
1312 {desc
= Tpoly
(ty, [])} ->
1314 | {desc
= Tpoly
(ty, tl
); level
= l
} ->
1315 if !Clflags.principal
&& l
<> generic_level
then
1316 Location.prerr_warning sexp
.pexp_loc
1317 (Warnings.Not_principal
"this use of a polymorphic method");
1318 snd
(instance_poly
false tl
ty)
1319 | {desc
= Tvar
} as ty ->
1320 let ty'
= newvar
() in
1321 unify
env (instance
ty) (newty
(Tpoly
(ty'
,[])));
1322 (* if not !Clflags.nolabels then
1323 Location.prerr_warning loc (Warnings.Unknown_method met); *)
1330 exp_loc
= sexp
.pexp_loc
;
1334 raise
(Error
(e
.pexp_loc
, Undefined_method
(obj.exp_type
, met
)))
1337 let (cl_path
, cl_decl
) =
1338 try Env.lookup_class cl
env with Not_found
->
1339 raise
(Error
(sexp
.pexp_loc
, Unbound_class cl
))
1341 begin match cl_decl
.cty_new
with
1343 raise
(Error
(sexp
.pexp_loc
, Virtual_class cl
))
1346 exp_desc
= Texp_new
(cl_path
, cl_decl
);
1347 exp_loc
= sexp
.pexp_loc
;
1348 exp_type
= instance
ty;
1351 | Pexp_setinstvar
(lab
, snewval
) ->
1353 let (path, desc
) = Env.lookup_value
(Longident.Lident lab
) env in
1354 match desc
.val_kind
with
1355 Val_ivar
(Mutable
, cl_num
) ->
1356 let newval = type_expect
env snewval
(instance desc
.val_type
) in
1357 let (path_self
, _) =
1358 Env.lookup_value
(Longident.Lident
("self-" ^ cl_num
)) env
1361 exp_desc
= Texp_setinstvar
(path_self
, path, newval);
1362 exp_loc
= sexp
.pexp_loc
;
1363 exp_type
= instance
Predef.type_unit
;
1366 raise
(Error
(sexp
.pexp_loc
, Instance_variable_not_mutable lab
))
1368 raise
(Error
(sexp
.pexp_loc
, Unbound_instance_variable lab
))
1371 raise
(Error
(sexp
.pexp_loc
, Unbound_instance_variable lab
))
1373 | Pexp_override lst
->
1377 if List.exists
((=) lab
) l
then
1378 raise
(Error
(sexp
.pexp_loc
,
1379 Value_multiply_overridden lab
));
1385 Env.lookup_value
(Longident.Lident
"selfpat-*") env,
1386 Env.lookup_value
(Longident.Lident
"self-*") env
1388 raise
(Error
(sexp
.pexp_loc
, Outside_class
))
1390 (_, {val_type
= self_ty
; val_kind
= Val_self
(_, vars, _, _)}),
1392 let type_override (lab
, snewval
) =
1394 let (id, _, _, ty) = Vars.find lab
!vars in
1395 (Path.Pident
id, type_expect
env snewval
(instance
ty))
1398 raise
(Error
(sexp
.pexp_loc
, Unbound_instance_variable lab
))
1401 let modifs = List.map
type_override lst
in
1403 exp_desc
= Texp_override
(path_self
, modifs);
1404 exp_loc
= sexp
.pexp_loc
;
1410 | Pexp_letmodule
(name
, smodl
, sbody
) ->
1411 let ty = newvar
() in
1412 Ident.set_current_time
ty.level
;
1413 let context = Typetexp.narrow
() in
1414 let modl = !type_module env smodl
in
1415 let (id, new_env) = Env.enter_module name
modl.mod_type
env in
1416 Ctype.init_def
(Ident.current_time
());
1417 Typetexp.widen
context;
1418 let body = type_exp new_env sbody
in
1419 (* Unification of body.exp_type with the fresh variable ty
1420 fails if and only if the prefix condition is violated,
1421 i.e. if generative types rooted at id show up in the
1422 type body.exp_type. Thus, this unification enforces the
1423 scoping condition on "let module". *)
1425 Ctype.unify
new_env body.exp_type
ty
1427 raise
(Error
(sexp
.pexp_loc
, Scoping_let_module
(name
, body.exp_type
)))
1430 exp_desc
= Texp_letmodule
(id, modl, body);
1431 exp_loc
= sexp
.pexp_loc
;
1434 | Pexp_assert
(e
) ->
1435 let cond = type_expect
env e
(instance
Predef.type_bool
) in
1437 exp_desc
= Texp_assert
(cond);
1438 exp_loc
= sexp
.pexp_loc
;
1439 exp_type
= instance
Predef.type_unit
;
1442 | Pexp_assertfalse
->
1444 exp_desc
= Texp_assertfalse
;
1445 exp_loc
= sexp
.pexp_loc
;
1446 exp_type
= newvar
();
1450 let arg = type_exp env e
in
1452 exp_desc
= Texp_lazy
arg;
1453 exp_loc
= sexp
.pexp_loc
;
1454 exp_type
= instance
(Predef.type_lazy_t
arg.exp_type
);
1458 let desc, sign
, meths = !type_object env sexp
.pexp_loc s
in
1460 exp_desc
= Texp_object
(desc, sign
, meths);
1461 exp_loc
= sexp
.pexp_loc
;
1462 exp_type
= sign
.cty_self
;
1468 and type_argument
env sarg ty_expected'
=
1469 (* ty_expected' may be generic *)
1471 let ls, tvar
= list_labels env ty in
1472 not tvar
&& List.for_all
((=) "") ls
1474 let ty_expected = instance
ty_expected'
in
1475 match expand_head
env ty_expected'
, sarg
with
1476 | _, {pexp_desc
= Pexp_function
(l
,_,_)} when not
(is_optional l
) ->
1477 type_expect
env sarg
ty_expected
1478 | {desc = Tarrow
("",ty_arg,ty_res,_); level
= lv
}, _ ->
1479 (* apply optional arguments when expected type is "" *)
1480 (* we must be very careful about not breaking the semantics *)
1481 if !Clflags.principal
then begin_def
();
1482 let texp = type_exp env sarg
in
1483 if !Clflags.principal
then begin
1485 generalize_structure
texp.exp_type
1487 let rec make_args args ty_fun
=
1488 match (expand_head
env ty_fun
).desc with
1489 | Tarrow
(l
,ty_arg,ty_fun
,_) when is_optional l
->
1491 ((Some
(option_none (instance
ty_arg) sarg
.pexp_loc
), Optional
)
1494 | Tarrow
(l
,_,ty_res'
,_) when l
= "" || !Clflags.classic
->
1495 args, ty_fun
, no_labels ty_res'
1496 | Tvar
-> args, ty_fun
, false
1497 | _ -> [], texp.exp_type
, false
1499 let args, ty_fun'
, simple_res
= make_args [] texp.exp_type
in
1500 let warn = !Clflags.principal
&&
1501 (lv
<> generic_level
|| (repr ty_fun'
).level
<> generic_level
)
1502 and texp = {texp with exp_type
= instance
texp.exp_type
}
1503 and ty_fun
= instance ty_fun'
in
1504 if not
(simple_res
|| no_labels ty_res) then begin
1505 unify_exp env texp ty_expected;
1508 unify_exp env {texp with exp_type
= ty_fun
} ty_expected;
1509 if args = [] then texp else
1510 (* eta-expand to avoid side effects *)
1511 let var_pair name
ty =
1512 let id = Ident.create name
in
1513 {pat_desc
= Tpat_var
id; pat_type
= ty;
1514 pat_loc
= Location.none
; pat_env
= env},
1515 {exp_type
= ty; exp_loc
= Location.none
; exp_env
= env; exp_desc
=
1516 Texp_ident
(Path.Pident
id,{val_type
= ty; val_kind
= Val_reg
})}
1518 let eta_pat, eta_var
= var_pair "eta" ty_arg in
1520 { texp with exp_type
= ty_fun
; exp_desc
=
1521 Texp_function
([eta_pat, {texp with exp_type
= ty_res; exp_desc
=
1522 Texp_apply
(texp, args@
1523 [Some eta_var
, Required
])}],
1525 if warn then Location.prerr_warning
texp.exp_loc
1526 (Warnings.Without_principality
"eliminated optional argument");
1527 if is_nonexpansive texp then func texp else
1528 (* let-expand to have side effects *)
1529 let let_pat, let_var
= var_pair "let" texp.exp_type
in
1530 re { texp with exp_type
= ty_fun
; exp_desc
=
1531 Texp_let
(Nonrecursive
, [let_pat, texp], func let_var
) }
1534 type_expect
env sarg
ty_expected
1536 and type_application
env funct sargs =
1537 (* funct.exp_type may be generic *)
1538 let result_type omitted ty_fun
=
1540 (fun ty_fun
(l
,ty,lv
) -> newty2 lv
(Tarrow
(l
,ty,ty_fun
,Cok
)))
1543 let has_label l ty_fun
=
1544 let ls, tvar
= list_labels env ty_fun
in
1545 tvar
|| List.mem l
ls
1547 let ignored = ref [] in
1548 let rec type_unknown_args args omitted ty_fun
= function
1551 (function None
, x
-> None
, x
| Some f
, x
-> Some
(f
()), x
)
1553 instance
(result_type omitted ty_fun
))
1554 | (l1
, sarg1
) :: sargl
->
1556 let ty_fun = expand_head
env ty_fun in
1557 match ty_fun.desc with
1559 let t1 = newvar
() and t2
= newvar
() in
1560 let not_identity = function
1561 Texp_ident
(_,{val_kind
=Val_prim
1562 {Primitive.prim_name
="%identity"}}) ->
1566 if ty_fun.level
>= t1.level
&& not_identity funct.exp_desc
then
1567 Location.prerr_warning sarg1
.pexp_loc
Warnings.Unused_argument
;
1568 unify
env ty_fun (newty
(Tarrow
(l1
,t1,t2
,Clink
(ref Cunknown
))));
1570 | Tarrow
(l
,t1,t2
,_) when l
= l1
1571 || !Clflags.classic
&& l1
= "" && not
(is_optional l
) ->
1575 match td with Tarrow
_ -> newty
td | _ -> ty_fun in
1576 let ty_res = result_type (omitted
@ !ignored) ty_fun in
1577 match ty_res.desc with
1579 if (!Clflags.classic
|| not
(has_label l1
ty_fun)) then
1580 raise
(Error
(sarg1
.pexp_loc
, Apply_wrong_label
(l1
, ty_res)))
1582 raise
(Error
(funct.exp_loc
, Incoherent_label_order
))
1584 raise
(Error
(funct.exp_loc
, Apply_non_function
1585 (expand_head
env funct.exp_type
)))
1587 let optional = if is_optional l1
then Optional
else Required
in
1589 let arg1 = type_expect
env sarg1
ty1 in
1590 if optional = Optional
then
1591 unify_exp env arg1 (type_option(newvar
()));
1594 type_unknown_args ((Some
arg1, optional) :: args) omitted ty2 sargl
1599 let ls, tvar
= list_labels env funct.exp_type
in
1601 let labels = List.filter
(fun l
-> not
(is_optional l
)) ls in
1602 List.length
labels = List.length
sargs &&
1603 List.for_all
(fun (l
,_) -> l
= "") sargs &&
1604 List.exists
(fun l
-> l
<> "") labels &&
1605 (Location.prerr_warning
funct.exp_loc
Warnings.Labels_omitted
;
1609 let warned = ref false in
1610 let rec type_args args omitted
ty_fun ty_old
sargs more_sargs
=
1611 match expand_head
env ty_fun with
1612 {desc=Tarrow
(l
, ty, ty_fun, com
); level
=lv
} as ty_fun'
1613 when (sargs <> [] || more_sargs
<> []) && commu_repr com
= Cok
->
1614 let may_warn loc w
=
1615 if not
!warned && !Clflags.principal
&& lv
<> generic_level
1618 Location.prerr_warning loc w
1621 let name = label_name l
1622 and optional = if is_optional l
then Optional
else Required
in
1623 let sargs, more_sargs
, arg =
1624 if ignore_labels && not
(is_optional l
) then begin
1625 (* In classic mode, omitted = [] *)
1626 match sargs, more_sargs
with
1627 (l'
, sarg0
) :: _, _ ->
1628 raise
(Error
(sarg0
.pexp_loc
, Apply_wrong_label
(l'
, ty_old
)))
1629 | _, (l'
, sarg0
) :: more_sargs
->
1630 if l
<> l'
&& l'
<> "" then
1631 raise
(Error
(sarg0
.pexp_loc
, Apply_wrong_label
(l'
, ty_fun'
)))
1633 ([], more_sargs
, Some
(fun () -> type_argument
env sarg0
ty))
1637 let (l'
, sarg0
, sargs, more_sargs
) =
1639 let (l'
, sarg0
, sargs1
, sargs2
) = extract_label
name sargs in
1640 if sargs1
<> [] then
1641 may_warn sarg0
.pexp_loc
1642 (Warnings.Not_principal
"commuting this argument");
1643 (l'
, sarg0
, sargs1
@ sargs2
, more_sargs
)
1645 let (l'
, sarg0
, sargs1
, sargs2
) =
1646 extract_label
name more_sargs
in
1647 if sargs1
<> [] || sargs <> [] then
1648 may_warn sarg0
.pexp_loc
1649 (Warnings.Not_principal
"commuting this argument");
1650 (l'
, sarg0
, sargs @ sargs1
, sargs2
)
1653 if optional = Required
|| is_optional l'
then
1654 Some
(fun () -> type_argument
env sarg0
ty)
1656 may_warn sarg0
.pexp_loc
1657 (Warnings.Not_principal
"using an optional argument here");
1658 Some
(fun () -> option_some (type_argument
env sarg0
1659 (extract_option_type env ty)))
1663 if optional = Optional
&&
1664 (List.mem_assoc
"" sargs || List.mem_assoc
"" more_sargs
)
1666 may_warn funct.exp_loc
1667 (Warnings.Without_principality
"eliminated optional argument");
1668 ignored := (l
,ty,lv
) :: !ignored;
1669 Some
(fun () -> option_none (instance
ty) Location.none
)
1671 may_warn funct.exp_loc
1672 (Warnings.Without_principality
"commuted an argument");
1677 if arg = None
then (l
,ty,lv
) :: omitted else omitted in
1678 let ty_old = if sargs = [] then ty_fun else ty_old in
1679 type_args ((arg,optional)::args) omitted ty_fun ty_old sargs more_sargs
1682 (l
, sarg0
) :: _ when ignore_labels ->
1683 raise
(Error
(sarg0
.pexp_loc
, Apply_wrong_label
(l
, ty_old)))
1685 type_unknown_args args omitted (instance
ty_fun)
1686 (sargs @ more_sargs
)
1688 match funct.exp_desc
, sargs with
1689 (* Special case for ignore: avoid discarding warning *)
1690 Texp_ident
(_, {val_kind
=Val_prim
{Primitive.prim_name
="%ignore"}}),
1692 let ty_arg, ty_res = filter_arrow
env (instance
funct.exp_type
) "" in
1693 let exp = type_expect
env sarg
ty_arg in
1694 begin match (expand_head
env exp.exp_type
).desc with
1696 Location.prerr_warning
exp.exp_loc
Warnings.Partial_application
1698 add_delayed_check (fun () -> check_application_result env false exp)
1701 ([Some
exp, Required
], ty_res)
1703 let ty = funct.exp_type
in
1704 if ignore_labels then
1705 type_args [] [] ty ty [] sargs
1707 type_args [] [] ty ty sargs []
1709 and type_construct
env loc lid sarg explicit_arity
ty_expected =
1712 Env.lookup_constructor lid
env
1714 raise
(Error
(loc
, Unbound_constructor lid
)) in
1718 | Some
{pexp_desc
= Pexp_tuple sel
} when explicit_arity
-> sel
1719 | Some
{pexp_desc
= Pexp_tuple sel
} when constr.cstr_arity
> 1 -> sel
1720 | Some se
-> [se
] in
1721 if List.length
sargs <> constr.cstr_arity
then
1722 raise
(Error
(loc
, Constructor_arity_mismatch
1723 (lid
, constr.cstr_arity
, List.length
sargs)));
1724 if !Clflags.principal
then begin_def
();
1725 let (ty_args, ty_res) = instance_constructor
constr in
1726 if !Clflags.principal
then begin
1728 List.iter generalize_structure
ty_args;
1729 generalize_structure
ty_res
1733 exp_desc
= Texp_construct
(constr, []);
1735 exp_type
= instance
ty_res;
1737 unify_exp env texp ty_expected;
1738 let args = List.map2
(type_argument
env) sargs ty_args in
1739 if constr.cstr_private
= Private
then
1740 raise
(Error
(loc
, Private_type
ty_res));
1741 { texp with exp_desc
= Texp_construct
(constr, args) }
1743 (* Typing of an expression with an expected type.
1744 Some constructs are treated specially to provide better error messages. *)
1746 and type_expect ?in_function
env sexp
ty_expected =
1747 match sexp
.pexp_desc
with
1748 Pexp_constant
(Const_string s
as cst
) ->
1751 exp_desc
= Texp_constant cst
;
1752 exp_loc
= sexp
.pexp_loc
;
1754 (* Terrible hack for format strings *)
1755 begin match (repr
(expand_head
env ty_expected)).desc with
1756 Tconstr
(path, _, _) when Path.same
path Predef.path_format6
->
1757 type_format sexp
.pexp_loc s
1758 | _ -> instance
Predef.type_string
1761 unify_exp env exp ty_expected;
1763 | Pexp_construct
(lid
, sarg
, explicit_arity
) ->
1764 type_construct
env sexp
.pexp_loc lid sarg explicit_arity
ty_expected
1765 | Pexp_let
(rec_flag
, spat_sexp_list
, sbody
) ->
1766 let (pat_exp_list
, new_env) = type_let
env rec_flag spat_sexp_list
in
1767 let body = type_expect
new_env sbody
ty_expected in
1769 exp_desc
= Texp_let
(rec_flag
, pat_exp_list
, body);
1770 exp_loc
= sexp
.pexp_loc
;
1771 exp_type
= body.exp_type
;
1773 | Pexp_sequence
(sexp1
, sexp2
) ->
1774 let exp1 = type_statement
env sexp1
in
1775 let exp2 = type_expect
env sexp2
ty_expected in
1777 exp_desc
= Texp_sequence
(exp1, exp2);
1778 exp_loc
= sexp
.pexp_loc
;
1779 exp_type
= exp2.exp_type
;
1781 | Pexp_function
(l
, Some default
, [spat, sbody
]) ->
1782 let loc = default
.pexp_loc
in
1784 [{ppat_loc
= loc; ppat_desc
=
1785 Ppat_construct
(Longident.Lident
"Some",
1786 Some
{ppat_loc
= loc; ppat_desc
= Ppat_var
"*sth*"},
1788 {pexp_loc
= loc; pexp_desc
= Pexp_ident
(Longident.Lident
"*sth*")};
1789 {ppat_loc
= loc; ppat_desc
=
1790 Ppat_construct
(Longident.Lident
"None", None
, false)},
1793 {pexp_loc
= loc; pexp_desc
=
1794 Pexp_match
({pexp_loc
= loc; pexp_desc
=
1795 Pexp_ident
(Longident.Lident
"*opt*")},
1798 {pexp_loc
= sexp
.pexp_loc
; pexp_desc
=
1799 Pexp_function
(l
, None
,[{ppat_loc
= loc; ppat_desc
= Ppat_var
"*opt*"},
1800 {pexp_loc
= sexp
.pexp_loc
; pexp_desc
=
1801 Pexp_let
(Default
, [spat, smatch], sbody
)}])}
1803 type_expect ?in_function
env sfun ty_expected
1804 | Pexp_function
(l
, _, caselist
) ->
1806 match in_function
with Some
p -> p
1807 | None
-> (sexp
.pexp_loc
, ty_expected)
1809 let (ty_arg, ty_res) =
1810 try filter_arrow
env ty_expected l
1812 match expand_head
env ty_expected with
1813 {desc = Tarrow
_} as ty ->
1814 raise
(Error
(sexp
.pexp_loc
, Abstract_wrong_label
(l
, ty)))
1817 Too_many_arguments
(in_function
<> None
, ty_fun)))
1820 if is_optional l
then
1821 let tv = newvar
() in
1823 try unify
env ty_arg (type_option tv)
1824 with Unify
_ -> assert false
1829 let cases, partial
=
1830 type_cases ~in_function
:(loc,ty_fun) env ty_arg ty_res
1831 (Some sexp
.pexp_loc
) caselist
in
1832 let not_function ty =
1833 let ls, tvar
= list_labels env ty in
1836 if is_optional l
&& not_function ty_res then
1837 Location.prerr_warning
(fst
(List.hd
cases)).pat_loc
1838 Warnings.Unerasable_optional_argument
;
1840 exp_desc
= Texp_function
(cases, partial
);
1841 exp_loc
= sexp
.pexp_loc
;
1842 exp_type
= newty
(Tarrow
(l
, ty_arg, ty_res, Cok
));
1844 | Pexp_when
(scond
, sbody
) ->
1845 let cond = type_expect
env scond
(instance
Predef.type_bool
) in
1846 let body = type_expect
env sbody
ty_expected in
1848 exp_desc
= Texp_when
(cond, body);
1849 exp_loc
= sexp
.pexp_loc
;
1850 exp_type
= body.exp_type
;
1852 | Pexp_poly
(sbody
, sty
) ->
1854 match sty
with None
-> repr
ty_expected
1856 let ty = Typetexp.transl_simple_type
env false sty
in
1861 { exp_desc
= Texp_tuple
[]; exp_loc
= sexp
.pexp_loc
;
1862 exp_type
= ty; exp_env
= env } ty_expected in
1866 if sty
<> None
then set_type ty;
1867 let exp = type_expect
env sbody
ty'
in
1868 re { exp with exp_type
= ty }
1869 | Tpoly
(ty'
, tl
) ->
1870 if sty
<> None
then set_type ty;
1871 (* One more level to generalize locally *)
1873 let vars, ty''
= instance_poly
true tl
ty'
in
1874 let exp = type_expect
env sbody
ty''
in
1876 check_univars env "method" exp ty_expected vars;
1877 re { exp with exp_type
= ty }
1881 let exp = type_exp env sexp
in
1882 unify_exp env exp ty_expected;
1885 (* Typing of statements (expressions whose values are discarded) *)
1887 and type_statement
env sexp
=
1889 let exp = type_exp env sexp
in
1891 let ty = expand_head
env exp.exp_type
and tv = newvar
() in
1892 begin match ty.desc with
1894 Location.prerr_warning sexp
.pexp_loc
Warnings.Partial_application
1895 | Tconstr
(p, _, _) when Path.same
p Predef.path_unit
-> ()
1896 | Tvar
when ty.level
> tv.level
->
1897 Location.prerr_warning sexp
.pexp_loc
Warnings.Nonreturning_statement
1899 add_delayed_check (fun () -> check_application_result env true exp)
1901 Location.prerr_warning sexp
.pexp_loc
Warnings.Statement_type
1903 unify_var
env tv ty;
1906 (* Typing of match cases *)
1908 and type_cases ?in_function
env ty_arg ty_res partial_loc caselist
=
1909 let ty_arg'
= newvar
() in
1910 let pattern_force = ref [] in
1913 (fun (spat, sexp
) ->
1914 if !Clflags.principal
then begin_def
();
1915 let (pat, ext_env
, force) = type_pattern env spat in
1916 pattern_force := force @ !pattern_force;
1918 if !Clflags.principal
then begin
1920 iter_pattern (fun {pat_type
=t} -> generalize_structure
t) pat;
1921 { pat with pat_type
= instance
pat.pat_type
}
1924 unify_pat env pat ty_arg'
;
1927 (* Check for polymorphic variants to close *)
1928 let patl = List.map fst
pat_env_list in
1929 if List.exists
has_variants patl then begin
1930 Parmatch.pressure_variants
env patl;
1931 List.iter
(iter_pattern finalize_variant) patl
1933 (* `Contaminating' unifications start here *)
1934 List.iter
(fun f
-> f
()) !pattern_force;
1935 begin match pat_env_list with [] -> ()
1936 | (pat, _) :: _ -> unify_pat env pat ty_arg
1938 let in_function = if List.length caselist
= 1 then in_function else None
in
1941 (fun (pat, ext_env
) (spat, sexp
) ->
1942 let exp = type_expect ?
in_function ext_env sexp
ty_res in
1944 pat_env_list caselist
1947 match partial_loc
with None
-> Partial
1948 | Some
loc -> Parmatch.check_partial
loc cases
1950 add_delayed_check (fun () -> Parmatch.check_unused
env cases);
1953 (* Typing of let bindings *)
1955 and type_let
env rec_flag spat_sexp_list
=
1957 if !Clflags.principal
then begin_def
();
1958 let (pat_list
, new_env, force) =
1959 type_pattern_list env (List.map
(fun (spat, sexp
) -> spat) spat_sexp_list
)
1961 if rec_flag
= Recursive
then
1963 (fun pat (_, sexp
) -> unify_pat env pat (type_approx env sexp
))
1964 pat_list spat_sexp_list
;
1966 if !Clflags.principal
then begin
1970 iter_pattern (fun pat -> generalize_structure
pat.pat_type
) pat;
1971 {pat with pat_type
= instance
pat.pat_type
})
1973 end else pat_list in
1974 (* Polymoprhic variant processing *)
1977 if has_variants pat then begin
1978 Parmatch.pressure_variants
env [pat];
1979 iter_pattern finalize_variant pat
1982 (* Only bind pattern variables after generalizing *)
1983 List.iter
(fun f
-> f
()) force;
1985 match rec_flag
with Nonrecursive
| Default
-> env | Recursive
-> new_env in
1988 (fun (spat, sexp
) pat -> type_expect
exp_env sexp
pat.pat_type
)
1989 spat_sexp_list
pat_list in
1991 (fun pat exp -> ignore
(Parmatch.check_partial
pat.pat_loc
[pat, exp]))
1996 if not
(is_nonexpansive exp) then
1997 iter_pattern (fun pat -> generalize_expansive
env pat.pat_type
) pat)
2000 (fun pat -> iter_pattern (fun pat -> generalize
pat.pat_type
) pat)
2002 (List.combine
pat_list exp_list, new_env)
2004 (* Typing of toplevel bindings *)
2006 let type_binding env rec_flag spat_sexp_list
=
2007 Typetexp.reset_type_variables
();
2008 type_let
env rec_flag spat_sexp_list
2010 (* Typing of toplevel expressions *)
2012 let type_expression env sexp
=
2013 Typetexp.reset_type_variables
();
2015 let exp = type_exp env sexp
in
2017 if is_nonexpansive exp then generalize
exp.exp_type
2018 else generalize_expansive
env exp.exp_type
;
2026 let report_error ppf
= function
2027 | Unbound_value lid
->
2028 fprintf ppf
"Unbound value %a" longident lid
2029 | Unbound_constructor lid
->
2030 fprintf ppf
"Unbound constructor %a" longident lid
2031 | Unbound_label lid
->
2032 fprintf ppf
"Unbound record field label %a" longident lid
2033 | Polymorphic_label lid
->
2034 fprintf ppf
"@[The record field label %a is polymorphic.@ %s@]"
2035 longident lid
"You cannot instantiate it in a pattern."
2036 | Constructor_arity_mismatch
(lid
, expected
, provided
) ->
2038 "@[The constructor %a@ expects %i argument(s),@ \
2039 but is here applied to %i argument(s)@]"
2040 longident lid expected provided
2041 | Label_mismatch
(lid
, trace
) ->
2042 report_unification_error ppf trace
2044 fprintf ppf
"The record field label %a@ belongs to the type"
2047 fprintf ppf
"but is here mixed with labels of type")
2048 | Pattern_type_clash trace
->
2049 report_unification_error ppf trace
2051 fprintf ppf
"This pattern matches values of type")
2053 fprintf ppf
"but is here used to match values of type")
2054 | Multiply_bound_variable
name ->
2055 fprintf ppf
"Variable %s is bound several times in this matching" name
2057 fprintf ppf
"Variable %s must occur on both sides of this | pattern"
2059 | Expr_type_clash trace
->
2060 report_unification_error ppf trace
2062 fprintf ppf
"This expression has type")
2064 fprintf ppf
"but is here used with type")
2065 | Apply_non_function
typ ->
2066 begin match (repr
typ).desc with
2068 fprintf ppf
"This function is applied to too many arguments,@ ";
2069 fprintf ppf
"maybe you forgot a `;'"
2072 "This expression is not a function, it cannot be applied"
2074 | Apply_wrong_label
(l
, ty) ->
2075 let print_label ppf
= function
2076 | "" -> fprintf ppf
"without label"
2078 fprintf ppf
"with label %s%s" (if is_optional l
then "" else "~") l
2080 reset_and_mark_loops
ty;
2082 "@[<v>@[<2>Expecting function has type@ %a@]@.\
2083 This argument cannot be applied %a@]"
2084 type_expr
ty print_label l
2085 | Label_multiply_defined lid
->
2086 fprintf ppf
"The record field label %a is defined several times"
2088 | Label_missing
labels ->
2089 let print_labels ppf
= List.iter
(fun lbl -> fprintf ppf
"@ %s" lbl) in
2090 fprintf ppf
"@[<hov>Some record field labels are undefined:%a@]"
2092 | Label_not_mutable lid
->
2093 fprintf ppf
"The record field label %a is not mutable" longident lid
2094 | Incomplete_format s
->
2095 fprintf ppf
"Premature end of format string ``%S''" s
2096 | Bad_conversion
(fmt
, i
, c
) ->
2098 "Bad conversion %%%c, at char number %d \
2099 in format string ``%s''" c i fmt
2100 | Undefined_method
(ty, me
) ->
2101 reset_and_mark_loops
ty;
2103 "@[<v>@[This expression has type@;<1 2>%a@]@,\
2104 It has no method %s@]" type_expr
ty me
2105 | Undefined_inherited_method me
->
2106 fprintf ppf
"This expression has no method %s" me
2107 | Unbound_class cl
->
2108 fprintf ppf
"Unbound class %a" longident cl
2109 | Virtual_class cl
->
2110 fprintf ppf
"One cannot create instances of the virtual class %a"
2112 | Unbound_instance_variable
v ->
2113 fprintf ppf
"Unbound instance variable %s" v
2114 | Instance_variable_not_mutable
v ->
2115 fprintf ppf
"The instance variable %s is not mutable" v
2116 | Not_subtype
(tr1
, tr2
) ->
2117 report_subtyping_error ppf tr1
"is not a subtype of type" tr2
2119 fprintf ppf
"This object duplication occurs outside a method definition"
2120 | Value_multiply_overridden
v ->
2121 fprintf ppf
"The instance variable %s is overridden several times" v
2122 | Coercion_failure
(ty, ty'
, trace
, b
) ->
2123 report_unification_error ppf trace
2125 let ty, ty'
= prepare_expansion
(ty, ty'
) in
2127 "This expression cannot be coerced to type@;<1 2>%a;@ it has type"
2128 (type_expansion
ty) ty'
)
2130 fprintf ppf
"but is here used with type");
2132 fprintf ppf
".@.@[<hov>%s@ %s@]"
2133 "This simple coercion was not fully general."
2134 "Consider using a double coercion."
2135 | Too_many_arguments
(in_function, ty) ->
2136 reset_and_mark_loops
ty;
2137 if in_function then begin
2138 fprintf ppf
"This function expects too many arguments,@ ";
2139 fprintf ppf
"it should have type@ %a"
2142 fprintf ppf
"This expression should not be a function,@ ";
2143 fprintf ppf
"the expected type is@ %a"
2146 | Abstract_wrong_label
(l
, ty) ->
2147 let label_mark = function
2148 | "" -> "but its first argument is not labeled"
2149 | l
-> sprintf
"but its first argument is labeled ~%s" l
in
2150 reset_and_mark_loops
ty;
2151 fprintf ppf
"@[<v>@[<2>This function should have type@ %a@]@,%s@]"
2152 type_expr
ty (label_mark l
)
2153 | Scoping_let_module
(id, ty) ->
2154 reset_and_mark_loops
ty;
2156 "This `let module' expression has type@ %a@ " type_expr
ty;
2158 "In this type, the locally bound module name %s escapes its scope" id
2159 | Masked_instance_variable lid
->
2161 "The instance variable %a@ \
2162 cannot be accessed from the definition of another instance variable"
2164 | Private_type
ty ->
2165 fprintf ppf
"Cannot create values of the private type %a" type_expr
ty
2166 | Private_label
(lid
, ty) ->
2167 fprintf ppf
"Cannot assign field %a of the private type %a"
2168 longident lid type_expr
ty
2169 | Not_a_variant_type lid
->
2170 fprintf ppf
"The type %a@ is not a variant type" longident lid
2171 | Incoherent_label_order
->
2172 fprintf ppf
"This function is applied to arguments@ ";
2173 fprintf ppf
"in an order different from other calls.@ ";
2174 fprintf ppf
"This is only allowed when the real type is known."
2175 | Less_general
(kind
, trace
) ->
2176 report_unification_error ppf trace
2177 (fun ppf
-> fprintf ppf
"This %s has type" kind
)
2178 (fun ppf
-> fprintf ppf
"which is less general than")