Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

fix PR#5673

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13164 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
commit f1dfec5ae54323a95535ca326ea757784ab2691b 1 parent 2ab0172
garrigue authored
Showing with 30 additions and 22 deletions.
  1. +1 −0  Changes
  2. +29 −22 typing/ctype.ml
View
1  Changes
@@ -21,6 +21,7 @@ Bug fixes:
- PR#5552: try to use camlp4.opt if it's possible
- PR#5611: avoid clashes betwen .cmo files and output files during linking
- PR#5662: typo in md5.c
+- PR#5673: type equality in a polymorphic field
- PR#5695: remove warnings on sparc code emitter
- PR#5697: better location for warnings on statement expressions
- PR#5698: remove harcoded limit of 200000 labels in emitaux.ml
View
51 typing/ctype.ml
@@ -1354,6 +1354,11 @@ let expand_abbrev_gen kind find_type_expansion env ty =
let expand_abbrev ty =
expand_abbrev_gen Public (fun level -> Env.find_type_expansion ~level) ty
+(* Expand once the head of a type *)
+let expand_head_once env ty =
+ try expand_abbrev env (repr ty) with Cannot_expand -> assert false
+
+(* Check whether a type can be expanded *)
let safe_abbrev env ty =
let snap = Btype.snapshot () in
try ignore (expand_abbrev env ty); true
@@ -1361,21 +1366,27 @@ let safe_abbrev env ty =
Btype.backtrack snap;
false
+(* Expand the head of a type once.
+ Raise Cannot_expand if the type cannot be expanded.
+ May raise Unify, if a recursion was hidden in the type. *)
let try_expand_once env ty =
let ty = repr ty in
match ty.desc with
Tconstr (p, _, _) -> repr (expand_abbrev env ty)
| _ -> raise Cannot_expand
-let _ = forward_try_expand_once := try_expand_once
+(* This one only raises Cannot_expand *)
+let try_expand_safe env ty =
+ let snap = Btype.snapshot () in
+ try try_expand_once env ty
+ with Unify _ ->
+ Btype.backtrack snap; raise Cannot_expand
-(* Fully expand the head of a type.
- Raise Cannot_expand if the type cannot be expanded.
- May raise Unify, if a recursion was hidden in the type. *)
-let rec try_expand_head env ty =
- let ty' = try_expand_once env ty in
+(* Fully expand the head of a type. *)
+let rec try_expand_head try_once env ty =
+ let ty' = try_once env ty in
let ty'' =
- try try_expand_head env ty'
+ try try_expand_head try_once env ty'
with Cannot_expand -> ty'
in
if Env.has_local_constraints env then begin
@@ -1385,20 +1396,16 @@ let rec try_expand_head env ty =
end;
ty''
-(* Expand once the head of a type *)
-let expand_head_once env ty =
- try expand_abbrev env (repr ty) with Cannot_expand -> assert false
-
-(* Fully expand the head of a type. *)
+(* Unsafe full expansion, may raise Unify. *)
let expand_head_unif env ty =
- try try_expand_head env ty with Cannot_expand -> repr ty
+ try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty
+(* Safe version of expand_head, never fails *)
let expand_head env ty =
- let snap = Btype.snapshot () in
- try try_expand_head env ty
- with Cannot_expand | Unify _ -> (* expand_head shall never fail *)
- Btype.backtrack snap;
- repr ty
+ try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty
+
+let _ = forward_try_expand_once := try_expand_safe
+
(* Expand until we find a non-abstract type declaration *)
@@ -1542,7 +1549,7 @@ let rec occur_rec env visited ty0 ty =
if List.memq ty visited || !Clflags.recursive_types then raise Occur;
iter_type_expr (occur_rec env (ty::visited) ty0) ty
with Occur -> try
- let ty' = try_expand_head env ty in
+ let ty' = try_expand_head try_expand_once env ty in
(* Maybe we could simply make a recursive call here,
but it seems it could make the occur check loop
(see change in rev. 1.58) *)
@@ -2666,8 +2673,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
| (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
()
| _ ->
- let t1' = expand_head_unif env t1 in
- let t2' = expand_head_unif env t2 in
+ let t1' = expand_head env t1 in
+ let t2' = expand_head env t2 in
(* Expansion may have changed the representative of the types... *)
let t1' = repr t1' and t2' = repr t2' in
if t1' == t2' then () else
@@ -2905,7 +2912,7 @@ let rec get_object_row ty =
let expand_head_rigid env ty =
let old = !rigid_variants in
rigid_variants := true;
- let ty' = expand_head_unif env ty in
+ let ty' = expand_head env ty in
rigid_variants := old; ty'
let normalize_subst subst =
Please sign in to comment.
Something went wrong with that request. Please try again.