diff --git a/Changes b/Changes index 8eb21be09..da58b2c97 100644 --- a/Changes +++ b/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() diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml index 2456780f7..906d84f53 100644 --- a/testsuite/tests/typing-poly/poly.ml +++ b/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 >;; diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference index b5b4518ff..f7dc11e26 100644 --- a/testsuite/tests/typing-poly/poly.ml.principal.reference +++ b/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 # diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference index 50b4117d6..0f0448e67 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/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 # diff --git a/typing/btype.ml b/typing/btype.ml index ebe13d471..474789e59 100644 --- a/typing/btype.ml +++ b/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) diff --git a/typing/btype.mli b/typing/btype.mli index 014f954eb..32e0886f2 100644 --- a/typing/btype.mli +++ b/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) -> diff --git a/typing/ctype.ml b/typing/ctype.ml index f2bc9ebec..f81f2691d 100644 --- a/typing/ctype.ml +++ b/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) diff --git a/typing/ctype.mli b/typing/ctype.mli index f984e567c..a5c0e83c8 100644 --- a/typing/ctype.mli +++ b/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 -> diff --git a/typing/typedecl.ml b/typing/typedecl.ml index f53b893d1..d1e0be5ea 100644 --- a/typing/typedecl.ml +++ b/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) =