Skip to content

Commit

Permalink
Fix ocaml#11101 by making occur ty ty succeed
Browse files Browse the repository at this point in the history
  • Loading branch information
garrigue committed Mar 13, 2022
1 parent db17a8e commit 99ace92
Show file tree
Hide file tree
Showing 3 changed files with 39 additions and 2 deletions.
34 changes: 34 additions & 0 deletions testsuite/tests/typing-misc/constraints.ml
Expand Up @@ -295,3 +295,37 @@ Error: The class constraints are not consistent.
Type int * int is not compatible with type float * float
Type int is not compatible with type float
|}]

(* #11101 *)
type ('node,'self) extension = < node: 'node; self: 'self > as 'self
type 'ext node = < > constraint 'ext = ('ext node, 'self) extension;;
[%%expect{|
type ('node, 'a) extension = 'a constraint 'a = < node : 'node; self : 'a >
type 'a node = < >
constraint 'a = ('a node, < node : 'a node; self : 'b > as 'b) extension
|}, Principal{|
type ('node, 'a) extension = < node : 'node; self : 'b > as 'b
constraint 'a = < node : 'node; self : 'a >
type 'a node = < >
constraint 'a = ('a node, < node : 'a node; self : 'b > as 'b) extension
|}]

class type ['node] extension =
object ('self)
method clone : 'self
method node : 'node
end
type 'ext node = < >
constraint 'ext = 'ext node #extension ;;
[%%expect{|
class type ['node] extension =
object ('a) method clone : 'a method node : 'node end
type 'a node = < > constraint 'a = < clone : 'a; node : 'a node; .. >
|}]

module Raise: sig val default_extension: 'a node extension as 'a end = struct
let default_extension = assert false
end;;
[%%expect{|
Exception: Assert_failure ("", 2, 26).
|}]
5 changes: 3 additions & 2 deletions typing/ctype.ml
Expand Up @@ -1772,7 +1772,8 @@ let occur env ty0 ty =
try
while
type_changed := false;
occur_rec env allow_recursive TypeSet.empty ty0 ty;
if not (eq_type ty0 ty) then
occur_rec env allow_recursive TypeSet.empty ty0 ty;
!type_changed
do () (* prerr_endline "changed" *) done;
merge type_changed old
Expand Down Expand Up @@ -2702,7 +2703,7 @@ and unify3 env t1 t1' t2 t2' =
| _ ->
begin match !umode with
| Expression ->
occur_for Unify !env t1' t2';
occur_for Unify !env t1' t2;
link_type t1' t2
| Pattern ->
add_type_equality t1' t2'
Expand Down
2 changes: 2 additions & 0 deletions typing/types.ml
Expand Up @@ -720,6 +720,7 @@ let log_type ty =
let link_type ty ty' =
let ty = repr ty in
let ty' = repr ty' in
if ty == ty' then () else begin
log_type ty;
let desc = ty.desc in
Transient_expr.set_desc ty (Tlink ty');
Expand All @@ -736,6 +737,7 @@ let link_type ty ty' =
| None, None -> ()
end
| _ -> ()
end
(* ; assert (check_memorized_abbrevs ()) *)
(* ; check_expans [] ty' *)
(* TODO: consider eliminating set_type_desc, replacing it with link types *)
Expand Down

0 comments on commit 99ace92

Please sign in to comment.