diff --git a/Changes b/Changes index 268446515cdc..076ff3829778 100644 --- a/Changes +++ b/Changes @@ -2429,6 +2429,10 @@ OCaml 4.14 maintenance version - #12878: fix incorrect treatment of injectivity for private recursive types. (Jeremy Yallop, review by Gabriel Scherer and Jacques Garrigue) +- #12971, #12974: fix an uncaught Ctype.Escape exception on some + invalid programs forming recursive types. + (Gabriel Scherer, review by Florian Angeletti, report by Neven Villani) + - #12264, #12289: Fix compact_allocate to avoid a pathological case that causes very slow compaction. (Damien Doligez, report by Arseniy Alekseyev, review by Sadiq Jaffer) diff --git a/testsuite/tests/typing-misc-bugs/pr12971.compilers.reference b/testsuite/tests/typing-misc-bugs/pr12971.compilers.reference new file mode 100644 index 000000000000..f3c41439332b --- /dev/null +++ b/testsuite/tests/typing-misc-bugs/pr12971.compilers.reference @@ -0,0 +1,9 @@ +module Seq : + sig + type 'a t = unit -> 'a node + and 'a node + val empty : 'a t + val cons : 'a -> 'a t -> 'a t + end +type 'a t = T of 'a +val wrong_to_seq : ('a Seq.t as 'a) Seq.t t -> 'a Seq.t Seq.t diff --git a/testsuite/tests/typing-misc-bugs/pr12971.ml b/testsuite/tests/typing-misc-bugs/pr12971.ml new file mode 100644 index 000000000000..11ef58f5384d --- /dev/null +++ b/testsuite/tests/typing-misc-bugs/pr12971.ml @@ -0,0 +1,32 @@ +(* TEST_BELOW *) + +module Seq : sig + type 'a t = unit -> 'a node + and 'a node + + val empty : 'a t + val cons : 'a -> 'a t -> 'a t +end = struct + type 'a t = unit -> 'a node + and 'a node = unit + + let empty () = () + let cons x xs () = () +end + +type 'a t = T of 'a + +(* Note: the current behavior of this function is believed to be + a bug, in the sense that it creates an equi-recursive type even in + absence of the -rectypes flag. On the other hand, it does not fail + with the Ctype.Escape exception, as it did from 4.13 to 5.1. *) +let wrong_to_seq (xt : 'a t) : 'a Seq.t = + let T x = xt in + Seq.cons Seq.empty x + +(* TEST + ocamlc_flags = "-i"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + check-ocamlc.byte-output; +*) diff --git a/testsuite/tests/typing-misc-bugs/pr12971_bis.compilers.reference b/testsuite/tests/typing-misc-bugs/pr12971_bis.compilers.reference new file mode 100644 index 000000000000..cd26e6b34b46 --- /dev/null +++ b/testsuite/tests/typing-misc-bugs/pr12971_bis.compilers.reference @@ -0,0 +1,6 @@ +File "pr12971_bis.ml", line 17, characters 12-48: +17 | let strange x = Seq.[cons x empty; cons empty x] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type "('a Seq.t as 'a) Seq.t -> 'a Seq.t Seq.t list" + but an expression was expected of type + "('a Seq.t as 'a) Seq.t -> 'a Seq.t Seq.t list" diff --git a/testsuite/tests/typing-misc-bugs/pr12971_bis.ml b/testsuite/tests/typing-misc-bugs/pr12971_bis.ml new file mode 100644 index 000000000000..081a890ae565 --- /dev/null +++ b/testsuite/tests/typing-misc-bugs/pr12971_bis.ml @@ -0,0 +1,25 @@ +(* TEST_BELOW *) + +module Seq : sig + type 'a t = unit -> 'a node + and 'a node + + val empty : 'a t + val cons : 'a -> 'a t -> 'a t +end = struct + type 'a t = unit -> 'a node + and 'a node = unit + + let empty () = () + let cons x xs () = () +end + +let strange x = Seq.[cons x empty; cons empty x] + +(* TEST + ocamlc_byte_exit_status = "2"; + ocamlc_flags = "-i"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + check-ocamlc.byte-output; +*) diff --git a/typing/ctype.ml b/typing/ctype.ml index 6202e8e65fe7..8e7c35bb39af 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1841,7 +1841,7 @@ let rec occur_rec env allow_recursive visited ty0 ty = let visited = TypeSet.add ty visited in iter_type_expr (occur_rec env allow_recursive visited ty0) ty with Occur -> try - let ty' = try_expand_head try_expand_once env ty in + let ty' = try_expand_head try_expand_safe env ty in (* This call used to be inlined, but there seems no reason for it. Message was referring to change in rev. 1.58 of the CVS repo. *) occur_rec env allow_recursive visited ty0 ty'