Fix PR#6980 and remove unused Ctype.iterative_generalization
parent
9d7ea1a9f2
commit
9229b15aaa
1
Changes
1
Changes
|
@ -293,6 +293,7 @@ Bug fixes:
|
||||||
- PR#6954: Infinite loop in type checker with module aliases
|
- PR#6954: Infinite loop in type checker with module aliases
|
||||||
- PR#6972, GPR#276: 4.02.3 regression on documentation comments in .cmt files
|
- PR#6972, GPR#276: 4.02.3 regression on documentation comments in .cmt files
|
||||||
(Leo White, report by Olivier Andrieu)
|
(Leo White, report by Olivier Andrieu)
|
||||||
|
- PR#6980: Assert failure from polymorphic variants and existentials
|
||||||
- PR#6982: unexpected type error when packing a module alias
|
- PR#6982: unexpected type error when packing a module alias
|
||||||
- PR#6985: `module type of struct include Bar end exposes
|
- PR#6985: `module type of struct include Bar end exposes
|
||||||
%s#row when Bar contains private row types
|
%s#row when Bar contains private row types
|
||||||
|
|
|
@ -0,0 +1,11 @@
|
||||||
|
type 'a t = [< `Foo | `Bar] as 'a;;
|
||||||
|
type 'a s = [< `Foo | `Bar | `Baz > `Bar] as 'a;;
|
||||||
|
|
||||||
|
type 'a first = First : 'a second -> ('b t as 'a) first
|
||||||
|
and 'a second = Second : ('b s as 'a) second;;
|
||||||
|
|
||||||
|
type aux = Aux : 'a t second * ('a -> int) -> aux;;
|
||||||
|
|
||||||
|
let it : 'a. [< `Bar | `Foo > `Bar ] as 'a = `Bar;;
|
||||||
|
|
||||||
|
let g (Aux(Second, f)) = f it;;
|
|
@ -0,0 +1,14 @@
|
||||||
|
|
||||||
|
# type 'a t = 'a constraint 'a = [< `Bar | `Foo ]
|
||||||
|
# type 'a s = 'a constraint 'a = [< `Bar | `Baz | `Foo > `Bar ]
|
||||||
|
# type 'a first = First : 'b t second -> ([< `Bar | `Foo ] as 'b) t first
|
||||||
|
and 'a second = Second : [< `Bar | `Baz | `Foo > `Bar ] s second
|
||||||
|
# type aux = Aux : ([< `Bar | `Foo ] as 'a) t second * ('a -> int) -> aux
|
||||||
|
# val it : [< `Bar | `Foo > `Bar ] = `Bar
|
||||||
|
# Characters 28-30:
|
||||||
|
let g (Aux(Second, f)) = f it;;
|
||||||
|
^^
|
||||||
|
Error: This expression has type [< `Bar | `Foo > `Bar ]
|
||||||
|
but an expression was expected of type [< `Bar | `Foo ]
|
||||||
|
Types for tag `Bar are incompatible
|
||||||
|
#
|
|
@ -593,32 +593,17 @@ let duplicate_class_type ty =
|
||||||
[expand_abbrev] (via [subst]) requires these expansions to be
|
[expand_abbrev] (via [subst]) requires these expansions to be
|
||||||
preserved. Does it worth duplicating this code ?
|
preserved. Does it worth duplicating this code ?
|
||||||
*)
|
*)
|
||||||
let rec iter_generalize tyl ty =
|
let rec generalize ty =
|
||||||
let ty = repr ty in
|
let ty = repr ty in
|
||||||
if (ty.level > !current_level) && (ty.level <> generic_level) then begin
|
if (ty.level > !current_level) && (ty.level <> generic_level) then begin
|
||||||
set_level ty generic_level;
|
set_level ty generic_level;
|
||||||
begin match ty.desc with
|
begin match ty.desc with
|
||||||
Tconstr (_, _, abbrev) ->
|
Tconstr (_, _, abbrev) ->
|
||||||
iter_abbrev (iter_generalize tyl) !abbrev
|
iter_abbrev generalize !abbrev
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
end;
|
end;
|
||||||
iter_type_expr (iter_generalize tyl) ty
|
iter_type_expr generalize ty
|
||||||
end else
|
end
|
||||||
tyl := ty :: !tyl
|
|
||||||
|
|
||||||
let iter_generalize tyl ty =
|
|
||||||
simple_abbrevs := Mnil;
|
|
||||||
iter_generalize tyl ty
|
|
||||||
|
|
||||||
let generalize ty =
|
|
||||||
iter_generalize (ref []) ty
|
|
||||||
|
|
||||||
(* Efficient repeated generalisation of the same type *)
|
|
||||||
let iterative_generalization min_level tyl =
|
|
||||||
let tyl' = ref [] in
|
|
||||||
List.iter (iter_generalize tyl') tyl;
|
|
||||||
List.fold_right (fun ty l -> if ty.level <= min_level then l else ty::l)
|
|
||||||
!tyl' []
|
|
||||||
|
|
||||||
(* Generalize the structure and lower the variables *)
|
(* Generalize the structure and lower the variables *)
|
||||||
|
|
||||||
|
@ -3291,19 +3276,23 @@ and eqtype_row rename type_pairs subst env row1 row2 =
|
||||||
| _ -> raise (Unify []))
|
| _ -> raise (Unify []))
|
||||||
pairs
|
pairs
|
||||||
|
|
||||||
|
(* Must empty univar_pairs first *)
|
||||||
|
let eqtype_list rename type_pairs subst env tl1 tl2 =
|
||||||
|
univar_pairs := [];
|
||||||
|
let snap = Btype.snapshot () in
|
||||||
|
try eqtype_list rename type_pairs subst env tl1 tl2; backtrack snap
|
||||||
|
with exn -> backtrack snap; raise exn
|
||||||
|
|
||||||
|
let eqtype rename type_pairs subst env t1 t2 =
|
||||||
|
eqtype_list rename type_pairs subst env [t1] [t2]
|
||||||
|
|
||||||
(* Two modes: with or without renaming of variables *)
|
(* Two modes: with or without renaming of variables *)
|
||||||
let equal env rename tyl1 tyl2 =
|
let equal env rename tyl1 tyl2 =
|
||||||
try
|
try
|
||||||
univar_pairs := [];
|
|
||||||
eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true
|
eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true
|
||||||
with
|
with
|
||||||
Unify _ -> false
|
Unify _ -> false
|
||||||
|
|
||||||
(* Must empty univar_pairs first *)
|
|
||||||
let eqtype rename type_pairs subst env t1 t2 =
|
|
||||||
univar_pairs := [];
|
|
||||||
eqtype rename type_pairs subst env t1 t2
|
|
||||||
|
|
||||||
|
|
||||||
(*************************)
|
(*************************)
|
||||||
(* Class type matching *)
|
(* Class type matching *)
|
||||||
|
|
|
@ -90,8 +90,6 @@ val filter_row_fields:
|
||||||
|
|
||||||
val generalize: type_expr -> unit
|
val generalize: type_expr -> unit
|
||||||
(* Generalize in-place the given type *)
|
(* Generalize in-place the given type *)
|
||||||
val iterative_generalization: int -> type_expr list -> type_expr list
|
|
||||||
(* Efficient repeated generalization of a type *)
|
|
||||||
val generalize_expansive: Env.t -> type_expr -> unit
|
val generalize_expansive: Env.t -> type_expr -> unit
|
||||||
(* Generalize the covariant part of a type, making
|
(* Generalize the covariant part of a type, making
|
||||||
contravariant branches non-generalizable *)
|
contravariant branches non-generalizable *)
|
||||||
|
|
Loading…
Reference in New Issue