Fix PR#6371

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

testsuite/tests/typing-signatures/pr6371.ml

@@ -0,0 +1,7 @@
+module M = struct
+  type t = int * (< m : 'a > as 'a)
+end;;
+
+module type S =
+    sig module M : sig type t end end with module M = M
+;;

testsuite/tests/typing-signatures/pr6371.ml.reference

@@ -0,0 +1,4 @@
+
+#     module M : sig type t = int * (< m : 'a > as 'a) end
+#       module type S = sig module M : sig type t = int * (< m : 'a > as 'a) end end
+# 

typing/btype.ml

@@ -249,6 +249,7 @@ type type_iterators =
     it_module_type: type_iterators -> module_type -> unit;
     it_class_type: type_iterators -> class_type -> unit;
     it_type_kind: type_iterators -> type_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
     it_type_expr: type_iterators -> type_expr -> unit;
     it_path: Path.t -> unit; }
 
@@ -314,7 +315,7 @@ let type_iterators =
           List.iter (it.it_type_expr it) cd.cd_args;
           may (it.it_type_expr it) cd.cd_res)
           cl
-  and it_type_expr it ty =
+  and it_do_type_expr it ty =
     iter_type_expr (it.it_type_expr it) ty;
     match ty.desc with
       Tconstr (p, _, _)
@@ -326,7 +327,8 @@ let type_iterators =
     | _ -> ()
   and it_path p = ()
   in
-  { it_path; it_type_expr; it_type_kind; it_class_type; it_module_type;
+  { it_path; it_type_expr = it_do_type_expr; it_do_type_expr;
+    it_type_kind; it_class_type; it_module_type;
     it_signature; it_class_type_declaration; it_class_declaration;
     it_modtype_declaration; it_module_declaration; it_exception_declaration;
     it_type_declaration; it_value_description; it_signature_item; }
@@ -430,6 +432,17 @@ let mark_type_node ty =
 let mark_type_params ty =
   iter_type_expr mark_type ty
 
+let type_iterators =
+  let it_type_expr it ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      mark_type_node ty;
+      it.it_do_type_expr it ty;
+    end
+  in
+  {type_iterators with it_type_expr}
+
+
 (* Remove marks from a type. *)
 let rec unmark_type ty =
   let ty = repr ty in
@@ -438,36 +451,19 @@ let rec unmark_type ty =
     iter_type_expr unmark_type ty
   end
 
+let unmark_iterators =
+  let it_type_expr it ty = unmark_type ty in
+  {type_iterators with it_type_expr}
+
 let unmark_type_decl decl =
-  List.iter unmark_type decl.type_params;
-  begin match decl.type_kind with
-    Type_abstract -> ()
-  | Type_variant cstrs ->
-      List.iter
-        (fun d ->
-          List.iter unmark_type d.cd_args;
-          Misc.may unmark_type d.cd_res)
-        cstrs
-  | Type_record(lbls, rep) ->
-      List.iter (fun d -> unmark_type d.ld_type) lbls
-  end;
-  begin match decl.type_manifest with
-    None    -> ()
-  | Some ty -> unmark_type ty
-  end
+  unmark_iterators.it_type_declaration unmark_iterators decl
 
 let unmark_class_signature sign =
   unmark_type sign.csig_self;
   Vars.iter (fun l (m, v, t) -> unmark_type t) sign.csig_vars
 
-let rec unmark_class_type =
-  function
-    Cty_constr (p, tyl, cty) ->
-      List.iter unmark_type tyl; unmark_class_type cty
-  | Cty_signature sign ->
-      unmark_class_signature sign
-  | Cty_arrow (_, ty, cty) ->
-      unmark_type ty; unmark_class_type cty
+let unmark_class_type cty =
+  unmark_iterators.it_class_type unmark_iterators cty
 
 
                   (*******************************************)

typing/btype.mli

@@ -103,10 +103,14 @@ type type_iterators =
     it_module_type: type_iterators -> module_type -> unit;
     it_class_type: type_iterators -> class_type -> unit;
     it_type_kind: type_iterators -> type_kind -> unit;
+    it_do_type_expr: type_iterators -> type_expr -> unit;
     it_type_expr: type_iterators -> type_expr -> unit;
     it_path: Path.t -> unit; }
-val type_iterators : type_iterators
-        (* Iteration on arbitrary type information *)
+val type_iterators: type_iterators
+        (* Iteration on arbitrary type information.
+           [it_type_expr] calls [mark_type_node] to avoid loops. *)
+val unmark_iterators: type_iterators
+        (* Unmark any structure containing types. See [unmark_type] below. *)
 
 val copy_type_desc:
     ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc

typing/mtype.ml

@@ -342,6 +342,7 @@ let collect_arg_paths mty =
   in
   let it = {type_iterators with it_path; it_signature_item} in
   it.it_module_type it mty;
+  it.it_module_type unmark_iterators mty;
   PathSet.fold (fun p -> IdentSet.union (collect_ids !subst !bindings p))
     !paths IdentSet.empty