Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix PR#6303 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14415 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2014-01-23 01:58:37 +00:00
parent c5b1594bb3
commit eaa8a78f94
4 changed files with 53 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
testsuite/tests/typing-misc-bugs/Makefile Normal file
View File

@ -0,0 +1,14 @@
#########################################################################
# #
# OCaml #
# #
# Xavier Clerc, SED, INRIA Rocquencourt #
# #
# Copyright 2010 Institut National de Recherche en Informatique et #
# en Automatique. All rights reserved. This file is distributed #
# under the terms of the Q Public License version 1.0. #
# #
#########################################################################
include ../../makefiles/Makefile.okbad
include ../../makefiles/Makefile.common

3
testsuite/tests/typing-misc-bugs/pr6303_bad.ml Normal file
View File

@ -0,0 +1,3 @@
type 'a foo = {x: 'a; y: int}
let r = {{x = 0; y = 0} with x = 0}
let r' : string foo = r

1
testsuite/typing
View File

@ -3,6 +3,7 @@ tests/typing-gadts
tests/typing-implicit_unpack tests/typing-implicit_unpack
tests/typing-labels tests/typing-labels
tests/typing-misc tests/typing-misc
tests/typing-misc-bugs
tests/typing-modules tests/typing-modules
tests/typing-modules-bugs tests/typing-modules-bugs
tests/typing-objects tests/typing-objects

53
typing/typecore.ml
View File

@ -537,8 +537,10 @@ let build_or_pat env loc lid =
let gloc = {loc with Location.loc_ghost=true} in let gloc = {loc with Location.loc_ghost=true} in
let row' = ref {row with row_more=newvar()} in let row' = ref {row with row_more=newvar()} in
let pats = let pats =
List.map (fun (l,p) -> {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; List.map
pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]}) (fun (l,p) ->
{pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc;
pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]})
pats pats
in in
match pats with match pats with
@ -546,8 +548,9 @@ let build_or_pat env loc lid =
| pat :: pats -> | pat :: pats ->
let r = let r =
List.fold_left List.fold_left
(fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; (fun pat pat0 ->
pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]}) {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[];
pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]})
pat pats in pat pats in
(path, rp { r with pat_loc = loc },ty) (path, rp { r with pat_loc = loc },ty)
@ -981,7 +984,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
in in
let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in
let p = {p with ppat_loc=loc} in let p = {p with ppat_loc=loc} in
type_pat p expected_ty (* TODO: record 'extra' to remember about interval *) type_pat p expected_ty
(* TODO: record 'extra' to remember about interval *)
| Ppat_interval _ -> | Ppat_interval _ ->
raise (Error (loc, !env, Invalid_interval)) raise (Error (loc, !env, Invalid_interval))
| Ppat_tuple spl -> | Ppat_tuple spl ->
@ -1180,7 +1184,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
match p.pat_desc with match p.pat_desc with
Tpat_var (id,s) -> Tpat_var (id,s) ->
{p with pat_type = ty; {p with pat_type = ty;
pat_desc = Tpat_alias ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); pat_desc = Tpat_alias
({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
pat_extra = [extra]; pat_extra = [extra];
} }
| _ -> {p with pat_type = ty; | _ -> {p with pat_type = ty;
@ -1189,7 +1194,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
| Ppat_type lid -> | Ppat_type lid ->
let (path, p,ty) = build_or_pat !env loc lid.txt in let (path, p,ty) = build_or_pat !env loc lid.txt in
unify_pat_types loc !env ty expected_ty; unify_pat_types loc !env ty expected_ty;
{ p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } { p with pat_extra =
(Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
| Ppat_extension (s, _arg) -> | Ppat_extension (s, _arg) ->
raise (Error (s.loc, !env, Extension s.txt)) raise (Error (s.loc, !env, Extension s.txt))
@ -1978,10 +1984,13 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_type = type_constant cst; exp_type = type_constant cst;
exp_attributes = sexp.pexp_attributes; exp_attributes = sexp.pexp_attributes;
exp_env = env } exp_env = env }
| Pexp_let(Nonrecursive, [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody) when contains_gadt env spat -> | Pexp_let(Nonrecursive,
[{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
when contains_gadt env spat ->
(* TODO: allow non-empty attributes? *) (* TODO: allow non-empty attributes? *)
type_expect ?in_function env type_expect ?in_function env
{sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} {sexp with
pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
ty_expected ty_expected
| Pexp_let(rec_flag, spat_sexp_list, sbody) -> | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let scp = let scp =
@ -2026,7 +2035,8 @@ and type_expect_ ?in_function env sexp ty_expected =
Exp.fun_ ~loc Exp.fun_ ~loc
l None l None
(Pat.var ~loc (mknoloc "*opt*")) (Pat.var ~loc (mknoloc "*opt*"))
(Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []] [Vb.mk spat smatch] sexp) (Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []]
[Vb.mk spat smatch] sexp)
in in
type_expect ?in_function env sfun ty_expected type_expect ?in_function env sfun ty_expected
(* TODO: keep attributes, call type_function directly *) (* TODO: keep attributes, call type_function directly *)
@ -2175,7 +2185,7 @@ and type_expect_ ?in_function env sexp ty_expected =
let ty = let ty =
newconstr p' (instance_list env decl.type_params) in newconstr p' (instance_list env decl.type_params) in
end_def (); end_def ();
generalize ty; generalize_structure ty;
ty, op ty, op
end end
| op -> ty_expected, op | op -> ty_expected, op
@ -2362,7 +2372,8 @@ and type_expect_ ?in_function env sexp ty_expected =
exp_type = ty'; exp_type = ty';
exp_attributes = arg.exp_attributes; exp_attributes = arg.exp_attributes;
exp_env = env; exp_env = env;
exp_extra = (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra; exp_extra =
(Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra;
} }
| Pexp_coerce(sarg, sty, sty') -> | Pexp_coerce(sarg, sty, sty') ->
let separate = true (* always separate, 1% slowdown for lablgtk *) let separate = true (* always separate, 1% slowdown for lablgtk *)
@ -2729,7 +2740,8 @@ and type_expect_ ?in_function env sexp ty_expected =
exp exp
| _ -> assert false | _ -> assert false
in in
re { exp with exp_extra = (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } re { exp with exp_extra =
(Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
| Pexp_newtype(name, sbody) -> | Pexp_newtype(name, sbody) ->
let ty = newvar () in let ty = newvar () in
(* remember original level *) (* remember original level *)
@ -2775,7 +2787,8 @@ and type_expect_ ?in_function env sexp ty_expected =
(* non-expansive if the body is non-expansive, so we don't introduce (* non-expansive if the body is non-expansive, so we don't introduce
any new extra node in the typed AST. *) any new extra node in the typed AST. *)
rue { body with exp_loc = loc; exp_type = ety; rue { body with exp_loc = loc; exp_type = ety;
exp_extra = (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra } exp_extra =
(Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra }
| Pexp_pack m -> | Pexp_pack m ->
let (p, nl, tl) = let (p, nl, tl) =
match Ctype.expand_head env (instance env ty_expected) with match Ctype.expand_head env (instance env ty_expected) with
@ -3005,7 +3018,9 @@ and type_argument env sarg ty_expected' ty_expected =
(* let-expand to have side effects *) (* let-expand to have side effects *)
let let_pat, let_var = var_pair "arg" texp.exp_type in let let_pat, let_var = var_pair "arg" texp.exp_type in
re { texp with exp_type = ty_fun; exp_desc = re { texp with exp_type = ty_fun; exp_desc =
Texp_let (Nonrecursive, [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]}], func let_var) } Texp_let (Nonrecursive,
[{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]}],
func let_var) }
end end
| _ -> | _ ->
let texp = type_expect env sarg ty_expected' in let texp = type_expect env sarg ty_expected' in
@ -3284,7 +3299,7 @@ and type_statement env sexp =
(* Typing of match cases *) (* Typing of match cases *)
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist : Typedtree.case list * _ = and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
(* ty_arg is _fully_ generalized *) (* ty_arg is _fully_ generalized *)
let patterns = List.map (fun {pc_lhs=p} -> p) caselist in let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
let erase_either = let erase_either =
@ -3593,7 +3608,8 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
let l = List.combine pat_list exp_list in let l = List.combine pat_list exp_list in
let l = let l =
List.map2 List.map2
(fun (p, e) pvb -> {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes}) (fun (p, e) pvb ->
{vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes})
l spat_sexp_list l spat_sexp_list
in in
(l, new_env, unpacks) (l, new_env, unpacks)
@ -3834,7 +3850,8 @@ let report_error env ppf = function
| Invalid_interval -> | Invalid_interval ->
fprintf ppf "@[Only character intervals are supported in patterns.@]" fprintf ppf "@[Only character intervals are supported in patterns.@]"
| Invalid_for_loop_index -> | Invalid_for_loop_index ->
fprintf ppf "@[Invalid for-loop index: only variables and _ are allowed.@]" fprintf ppf
"@[Invalid for-loop index: only variables and _ are allowed.@]"
| Extension s -> | Extension s ->
fprintf ppf "Uninterpreted extension '%s'." s fprintf ppf "Uninterpreted extension '%s'." s