Fix stack overflow by checking cycles for all types before regularity

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

3 files changed, 27 insertions, 18 deletions

diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml
index 885257448..5408ca2c1 100644
--- a/testsuite/tests/typing-misc/constraints.ml
+++ b/testsuite/tests/typing-misc/constraints.ml
@@ -8,10 +8,7 @@ type 'a t = [`A of 'a t] constraint 'a = 'a t;;
 
 type 'a t = [`A of 'a] as 'a;;
 
-(* XXX Todo : Fix stack overflow *)
-(*
-type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;;
-*)
+type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
 
 type 'a t = 'a;;
 let f (x : 'a t as 'a) = ();; (* fails *)
diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference
index 1bc23a77e..fe5204400 100644
--- a/testsuite/tests/typing-misc/constraints.ml.reference
+++ b/testsuite/tests/typing-misc/constraints.ml.reference
@@ -14,7 +14,11 @@ Error: In the definition of t, type 'a t t should be 'a t
 #   type 'a t = [ `A of 'a t t ] constraint 'a = 'a t
 #   type 'a t = [ `A of 'a t ] constraint 'a = 'a t
 #   type 'a t = 'a constraint 'a = [ `A of 'a ]
-#     * *     type 'a t = 'a
+#   Characters 47-52:
+  type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *)
+                                                ^^^^^
+Error: The type abbreviation t is cyclic
+#   type 'a t = 'a
 # Characters 11-21:
   let f (x : 'a t as 'a) = ();; (* fails *)
              ^^^^^^^^^^
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 6268c5672..b51170fe3 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -402,12 +402,25 @@ let check_abbrev env (_, sdecl) (id, decl) =
       end
   | _ -> ()
 
+(* Check that recursion is well-founded *)
+
+let check_well_founded env loc path decl =
+  Misc.may
+    (fun body ->
+      try Ctype.correct_abbrev env path decl.type_params body with
+      | Ctype.Recursive_abbrev ->
+          raise(Error(loc, Recursive_abbrev (Path.name path)))
+      | Ctype.Unify trace -> raise(Error(loc, Type_clash trace)))
+    decl.type_manifest
+
 (* Check for ill-defined abbrevs *)
 
 let check_recursion env loc path decl to_check =
   (* to_check is true for potentially mutually recursive paths.
      (path, decl) is the type declaration to be checked. *)
 
+  if decl.type_params = [] then () else
+
   let visited = ref [] in
 
   let rec check_regular cpath args prev_exp ty =
@@ -450,22 +463,13 @@ let check_recursion env loc path decl to_check =
           Btype.iter_type_expr (check_regular cpath args prev_exp) ty
     end in
 
-  match decl.type_manifest with
-  | None -> ()
-  | Some body ->
-      (* Check that recursion is well-founded *)
-      begin try
-        Ctype.correct_abbrev env path decl.type_params body
-      with Ctype.Recursive_abbrev ->
-        raise(Error(loc, Recursive_abbrev (Path.name path)))
-      | Ctype.Unify trace -> raise(Error(loc, Type_clash trace))
-      end;
-      (* Check that recursion is regular *)
-      if decl.type_params = [] then () else
+  Misc.may
+    (fun body ->
       let (args, body) =
         Ctype.instance_parameterized_type
           ~keep_names:true decl.type_params body in
-      check_regular path args [] body
+      check_regular path args [] body)
+    decl.type_manifest
 
 let check_abbrev_recursion env id_loc_list (id, _, tdecl) =
   let decl = tdecl.typ_type in
@@ -830,6 +834,9 @@ let transl_type_decl env name_sdecl_list =
     List.map2 (fun id (_,sdecl) -> (id, sdecl.ptype_loc))
       id_list name_sdecl_list
   in
+  List.iter (fun (id, decl) ->
+    check_well_founded newenv (List.assoc id id_loc_list) (Path.Pident id) decl)
+    decls;
   List.iter (check_abbrev_recursion newenv id_loc_list) tdecls;
   (* Check that all type variable are closed *)
   List.iter2
@@ -1019,6 +1026,7 @@ let approx_type_decl env name_sdecl_list =
 let check_recmod_typedecl env loc recmod_ids path decl =
   (* recmod_ids is the list of recursively-defined module idents.
      (path, decl) is the type declaration to be checked. *)
+  check_well_founded env loc path decl;
   check_recursion env loc path decl
     (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids)