Fix PR#7016: occur check must handle existing recursive types

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@16508 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Changes

@@ -201,6 +201,7 @@ Bug fixes:
 - PR#6992: Segfault from bug in GADT/module typing
 - PR#6993: Segfault from recursive modules violating exhaustiveness assumptions
 - PR#7012: Variable name forgotten when it starts with a capital letter
+- PR#7016: Stack overflow in GADT typing
 - GPR#205: Clear caml_backtrace_last_exn before registering as root (report
   and fix by Frederic Bour)
 - GPR#220: minor -dsource error on recursive modules

testsuite/tests/typing-gadts/pr7016.ml

@@ -0,0 +1,9 @@
+type (_, _) t =
+  | Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t;;
+
+let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+
+let get1' = function
+  | (Cons (x, _) : (_ * 'a, 'a) t) -> x
+  | Nil -> assert false ;; (* ok *)

testsuite/tests/typing-gadts/pr7016.ml.reference

@@ -0,0 +1,13 @@
+
+#     type (_, _) t =
+    Nil : ('tl, 'tl) t
+  | Cons : 'a * ('b, 'tl) t -> ('a * 'b, 'tl) t
+#   Characters 10-44:
+  let get1 (Cons (x, _) : (_ * 'a, 'a) t) = x ;; (* warn, cf PR#6993 *)
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+Nil
+val get1 : ('b * 'a, 'a) t -> 'b = <fun>
+#       val get1' : ('b * 'a as 'a, 'a) t -> 'b = <fun>
+# 

typing/ctype.ml

@@ -1637,22 +1637,17 @@ let rec occur_rec env visited ty0 ty =
         iter_type_expr (occur_rec env (ty::visited) ty0) ty
       with Occur -> try
         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) *)
-        if ty' == ty0 || List.memq ty' visited then raise Occur;
-        match ty'.desc with
-          Tobject _ | Tvariant _ -> ()
-        | _ ->
-            if allow_recursive env ty' then () else
-            iter_type_expr (occur_rec env (ty'::visited) ty0) ty'
+        (* 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 visited ty0 ty'
       with Cannot_expand ->
         raise Occur
       end
   | Tobject _ | Tvariant _ ->
       ()
   | _ ->
-      iter_type_expr (occur_rec env visited ty0) ty
+      if List.memq ty visited then () else
+      iter_type_expr (occur_rec env (ty::visited) ty0) ty
 
 let type_changed = ref false (* trace possible changes to the studied type *)