Fix PR#5224

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

Changes

@@ -97,6 +97,7 @@ Bug Fixes:
   segmentation faults due to stack overflow in C code
 - PR#5211: updated Genlex documentation to state that camlp4 is mandatory for
   'parser' keyword and associated notation
+- PR#5224: confusing error message in non-regular type definition
 - PR#5238, PR#5277: Sys_error when getting error location
 - PR#5291: undetected loop in class initialization
 - PR#5295: OS threads: problem with caml_c_thread_unregister()

testsuite/tests/typing-poly/poly.ml

@@ -651,3 +651,7 @@ type t = { foo : int }
 let {foo} = (raise Exit : t);;
 type s = A of int
 let (A x) = (raise Exit : s);;
+
+(* PR#5224 *)
+
+type 'x t = < f : 'y. 'y t >;;

testsuite/tests/typing-poly/poly.ml.principal.reference

@@ -635,4 +635,8 @@ Error: This field value has type unit -> unit which is less general than
 #       Exception: Pervasives.Exit.
 #   Exception: Pervasives.Exit.
 #   Exception: Pervasives.Exit.
+#       Characters 20-44:
+  type 'x t = < f : 'y. 'y t >;;
+      ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In the definition of t, type 'y t should be 'x t
 # 

testsuite/tests/typing-poly/poly.ml.reference

@@ -593,4 +593,8 @@ Error: This field value has type unit -> unit which is less general than
 #       Exception: Pervasives.Exit.
 #   Exception: Pervasives.Exit.
 #   Exception: Pervasives.Exit.
+#       Characters 20-44:
+  type 'x t = < f : 'y. 'y t >;;
+      ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In the definition of t, type 'y t should be 'x t
 # 

typing/btype.ml

@@ -257,8 +257,8 @@ let rec norm_univar ty =
   | Ttuple (ty :: _)   -> norm_univar ty
   | _                  -> assert false
 
-let rec copy_type_desc f = function
-    Tvar _              -> Tvar None (* forget the name *)
+let rec copy_type_desc ?(keep_names=false) f = function
+    Tvar _ as ty        -> if keep_names then ty else Tvar None
   | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
   | Ttuple l            -> Ttuple (List.map f l)
   | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
@@ -271,7 +271,7 @@ let rec copy_type_desc f = function
   | Tnil                -> Tnil
   | Tlink ty            -> copy_type_desc f ty.desc
   | Tsubst ty           -> assert false
-  | Tunivar _ as ty     -> ty (* keep the name *)
+  | Tunivar _ as ty     -> ty (* always keep the name *)
   | Tpoly (ty, tyl)     ->
       let tyl = List.map (fun x -> norm_univar (f x)) tyl in
       Tpoly (f ty, tyl)

typing/btype.mli

@@ -86,7 +86,8 @@ val iter_row: (type_expr -> unit) -> row_desc -> unit
 val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit
         (* Iteration on types in an abbreviation list *)
 
-val copy_type_desc: (type_expr -> type_expr) -> type_desc -> type_desc
+val copy_type_desc:
+    ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc
         (* Copy on types *)
 val copy_row:
     (type_expr -> type_expr) ->

typing/ctype.ml

@@ -906,8 +906,8 @@ let abbreviations = ref (ref Mnil)
 
 (* partial: we may not wish to copy the non generic types
    before we call type_pat *)
-let rec copy ?env ?partial ty =
-  let copy = copy ?env ?partial in
+let rec copy ?env ?partial ?keep_names ty =
+  let copy = copy ?env ?partial ?keep_names in
   let ty = repr ty in
   match ty.desc with
     Tsubst ty -> ty
@@ -998,7 +998,7 @@ let rec copy ?env ?partial ty =
           end
       | Tobject (ty1, _) when partial <> None ->
           Tobject (copy ty1, ref None)
-      | _ -> copy_type_desc copy desc
+      | _ -> copy_type_desc ?keep_names copy desc
       end;
     t
 
@@ -1079,8 +1079,8 @@ let instance_constructor ?in_pattern cstr =
   cleanup_types ();
   (ty_args, ty_res)
 
-let instance_parameterized_type sch_args sch =
-  let ty_args = List.map copy sch_args in
+let instance_parameterized_type ?keep_names sch_args sch =
+  let ty_args = List.map (copy ?keep_names) sch_args in
   let ty = copy sch in
   cleanup_types ();
   (ty_args, ty)

typing/ctype.mli

@@ -119,6 +119,7 @@ val instance_constructor:
         constructor_description -> type_expr list * type_expr
         (* Same, for a constructor *)
 val instance_parameterized_type:
+        ?keep_names:bool ->
         type_expr list -> type_expr -> type_expr list * type_expr
 val instance_parameterized_type_2:
         type_expr list -> type_expr list -> type_expr ->

typing/typedecl.ml

@@ -444,7 +444,7 @@ let check_recursion env loc path decl to_check =
           end;
           List.iter (check_regular cpath args prev_exp) args'
       | Tpoly (ty, tl) ->
-          let (_, ty) = Ctype.instance_poly false tl ty in
+          let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in
           check_regular cpath args prev_exp ty
       | _ ->
           Btype.iter_type_expr (check_regular cpath args prev_exp) ty
@@ -463,7 +463,8 @@ let check_recursion env loc path decl to_check =
       (* Check that recursion is regular *)
       if decl.type_params = [] then () else
       let (args, body) =
-        Ctype.instance_parameterized_type decl.type_params body in
+        Ctype.instance_parameterized_type
+          ~keep_names:true decl.type_params body in
       check_regular path args [] body
 
 let check_abbrev_recursion env id_loc_list (id, _, tdecl) =