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

fixed bug in exhaustiveness check 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/gadts@10747 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Le Normand 2010-10-27 09:52:38 +00:00
parent 4c86d56280
commit fad8e4de6f
2 changed files with 28 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
typing/ctype.ml
View File

@ -1314,33 +1314,6 @@ let rec non_recursive_abbrev visited env ty0 ty =
let non_recursive_abbrev = non_recursive_abbrev (ref [])
(* GAH: same as above, but for local constraints
ask garrigue about this *)
let rec local_non_recursive_abbrev visited env p ty =
let ty = repr ty in
if not (List.memq ty !visited) then begin
visited := ty :: !visited;
match ty.desc with
Tconstr(p', args, abbrev) ->
if Path.same p p' then raise Recursive_abbrev;
begin try
local_non_recursive_abbrev visited env p (try_expand_once_opt env ty)
with Cannot_expand ->
if !Clflags.recursive_types then () else
iter_type_expr (local_non_recursive_abbrev visited env p) ty
end
| Tobject _ | Tvariant _ ->
()
| _ ->
if !Clflags.recursive_types then () else
iter_type_expr (local_non_recursive_abbrev visited env p) ty
end
let local_non_recursive_abbrev = local_non_recursive_abbrev (ref [])
let correct_abbrev env path params ty =
check_abbrev_env env;
let ty0 = newgenvar () in
@ -1399,6 +1372,31 @@ let occur env ty0 ty =
raise (match exn with Occur -> Unify [] | _ -> exn)
let rec local_non_recursive_abbrev visited env p ty =
let ty = repr ty in
if not (List.memq ty !visited) then begin
visited := ty :: !visited;
match ty.desc with
Tconstr(p', args, abbrev) ->
if Path.same p p' then raise Recursive_abbrev;
begin try
local_non_recursive_abbrev visited env p (try_expand_once_opt env ty)
with Cannot_expand ->
if !Clflags.recursive_types then () else
iter_type_expr (local_non_recursive_abbrev visited env p) ty
end
| Tobject _ | Tvariant _ ->
()
| _ ->
if !Clflags.recursive_types then () else
iter_type_expr (local_non_recursive_abbrev visited env p) ty
end
let local_non_recursive_abbrev = local_non_recursive_abbrev (ref [])
(*****************************)
(* Polymorphic Unification *)
(*****************************)

7
typing/parmatch.ml
View File

@ -1810,7 +1810,7 @@ let generate_all (env:Env.t) : pattern -> pattern list =
| Tconstr (path,_,_) -> Env.find_type path tenv
| _ -> fatal_error "Parmatch.get_type_descr"
in
let mem pred elt =
(* let mem pred elt =
let rec loop =
function
| [] -> false
@ -1819,7 +1819,6 @@ let generate_all (env:Env.t) : pattern -> pattern list =
in
loop
in
let uniquefy pred =
let rec loop sofar =
function
@ -1831,7 +1830,7 @@ let generate_all (env:Env.t) : pattern -> pattern list =
in
let type_equivalence (_,t) (_,t') =
Ctype.equal Env.empty true [t] [t']
in
in*)
let rec loop p =
match p.ppat_desc with
| Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ ->
@ -1858,7 +1857,7 @@ let generate_all (env:Env.t) : pattern -> pattern list =
assert false
in
let constrs = filter_map (make_constr ty_res lid_of_tyres lid) constr_list in
let constrs = uniquefy type_equivalence constrs in
(* let constrs = uniquefy type_equivalence constrs in *)
List.map fst constrs
| _ -> [] end
in