Avoid duplicated mark_loops
parent
86248f1162
commit
816a5088e0
4
Changes
4
Changes
|
@ -369,6 +369,10 @@ Working version
|
||||||
ocamldep link not created)
|
ocamldep link not created)
|
||||||
(David Allsopp, report by Thomas Leonard)
|
(David Allsopp, report by Thomas Leonard)
|
||||||
|
|
||||||
|
- #8856, #8860: avoid stackoverflow when printing cyclic type expressions
|
||||||
|
in some error submessages.
|
||||||
|
(Florian Angeletti, report by Mekhrubon Turaev, review by Leo White)
|
||||||
|
|
||||||
- #8875: fix missing newlines in the output from MSVC invocation.
|
- #8875: fix missing newlines in the output from MSVC invocation.
|
||||||
(Nicolás Ojeda Bär, review by Gabriel Scherer)
|
(Nicolás Ojeda Bär, review by Gabriel Scherer)
|
||||||
|
|
||||||
|
|
|
@ -187,7 +187,6 @@ let report_error ppf = function
|
||||||
| Unknown_name n ->
|
| Unknown_name n ->
|
||||||
fprintf ppf "@[Unknown value name $%i@]@." n
|
fprintf ppf "@[Unknown value name $%i@]@." n
|
||||||
| Tuple_index(ty, len, pos) ->
|
| Tuple_index(ty, len, pos) ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[Cannot extract field number %i from a %i-tuple of type@ %a@]@."
|
"@[Cannot extract field number %i from a %i-tuple of type@ %a@]@."
|
||||||
pos len Printtyp.type_expr ty
|
pos len Printtyp.type_expr ty
|
||||||
|
|
|
@ -99,7 +99,6 @@ let print_named_value max_depth exp env obj ppf ty =
|
||||||
| _ ->
|
| _ ->
|
||||||
let n = name_value obj ty in
|
let n = name_value obj ty in
|
||||||
fprintf ppf "$%i" n in
|
fprintf ppf "$%i" n in
|
||||||
Printtyp.reset_and_mark_loops ty;
|
|
||||||
fprintf ppf "@[<2>%a:@ %a@ =@ %a@]@."
|
fprintf ppf "@[<2>%a:@ %a@ =@ %a@]@."
|
||||||
print_value_name exp
|
print_value_name exp
|
||||||
Printtyp.type_expr ty
|
Printtyp.type_expr ty
|
||||||
|
|
|
@ -55,6 +55,20 @@ type (' a', ' a'b, 'cd') t = ' a'b -> ' a' * 'cd'
|
||||||
|
|
||||||
(* #8856: cycles in types expressions could trigger stack overflows
|
(* #8856: cycles in types expressions could trigger stack overflows
|
||||||
when printing subpart of error messages *)
|
when printing subpart of error messages *)
|
||||||
|
|
||||||
|
type 'a t = private X of 'a
|
||||||
|
let zeros = object(self) method next = 0, self end
|
||||||
|
let x = X zeros;;
|
||||||
|
[%%expect {|
|
||||||
|
type 'a t = private X of 'a
|
||||||
|
val zeros : < next : int * 'a > as 'a = <obj>
|
||||||
|
Line 3, characters 8-15:
|
||||||
|
3 | let x = X zeros;;
|
||||||
|
^^^^^^^
|
||||||
|
Error: Cannot create values of the private type (< next : int * 'a > as 'a) t
|
||||||
|
|}]
|
||||||
|
|
||||||
|
|
||||||
type ('a,'b) eq = Refl: ('a,'a) eq
|
type ('a,'b) eq = Refl: ('a,'a) eq
|
||||||
type t = <m : int * 't> as 't
|
type t = <m : int * 't> as 't
|
||||||
let f (x:t) (type a) (y:a) (witness:(a,t) eq) = match witness with
|
let f (x:t) (type a) (y:a) (witness:(a,t) eq) = match witness with
|
||||||
|
@ -82,6 +96,6 @@ Line 3, characters 22-23:
|
||||||
^
|
^
|
||||||
Error: This expression has type t1 but an expression was expected of type t2
|
Error: This expression has type t1 but an expression was expected of type t2
|
||||||
The method m has type 'c. 'c * ('a * < m : 'c. 'b >) as 'b,
|
The method m has type 'c. 'c * ('a * < m : 'c. 'b >) as 'b,
|
||||||
but the expected method type was 'a. 'a * ('a * < m : 'a. 'd >) as 'd
|
but the expected method type was 'a. 'a * ('a * < m : 'a. 'b >) as 'b
|
||||||
The universal variable 'a would escape its scope
|
The universal variable 'a would escape its scope
|
||||||
|}]
|
|}]
|
||||||
|
|
|
@ -38,8 +38,8 @@ Line 4, characters 49-50:
|
||||||
^
|
^
|
||||||
Error: This expression has type < a : 'a; b : 'a >
|
Error: This expression has type < a : 'a; b : 'a >
|
||||||
but an expression was expected of type < a : 'a; b : 'a0. 'a0 >
|
but an expression was expected of type < a : 'a; b : 'a0. 'a0 >
|
||||||
The method b has type 'a, but the expected method type was 'a0. 'a0
|
The method b has type 'a, but the expected method type was 'a. 'a
|
||||||
The universal variable 'a0 would escape its scope
|
The universal variable 'a would escape its scope
|
||||||
|}]
|
|}]
|
||||||
|
|
||||||
|
|
||||||
|
@ -61,8 +61,8 @@ Lines 5-7, characters 10-5:
|
||||||
Error: This expression has type < f : 'a -> int >
|
Error: This expression has type < f : 'a -> int >
|
||||||
but an expression was expected of type t_a
|
but an expression was expected of type t_a
|
||||||
The method f has type 'a -> int, but the expected method type was
|
The method f has type 'a -> int, but the expected method type was
|
||||||
'a0. 'a0 -> int
|
'a. 'a -> int
|
||||||
The universal variable 'a0 would escape its scope
|
The universal variable 'a would escape its scope
|
||||||
|}
|
|}
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -80,8 +80,8 @@ Line 4, characters 11-49:
|
||||||
Error: This expression has type 'a v but an expression was expected of type
|
Error: This expression has type 'a v but an expression was expected of type
|
||||||
uv
|
uv
|
||||||
The method f has type 'a -> int, but the expected method type was
|
The method f has type 'a -> int, but the expected method type was
|
||||||
'a0. 'a0 -> int
|
'a. 'a -> int
|
||||||
The universal variable 'a0 would escape its scope
|
The universal variable 'a would escape its scope
|
||||||
|}]
|
|}]
|
||||||
|
|
||||||
(* Issue #8702: row types unified with universally quantified types*)
|
(* Issue #8702: row types unified with universally quantified types*)
|
||||||
|
|
|
@ -1109,8 +1109,10 @@ Line 2, characters 3-4:
|
||||||
Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
|
Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
|
||||||
but an expression was expected of type
|
but an expression was expected of type
|
||||||
< m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
|
< m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
|
||||||
The method m has type 'a. 'a * 'd, but the expected method type was
|
The method m has type
|
||||||
'c. 'c * 'd as 'e
|
'a. 'a * (< m : 'a * < m : 'c. 'c * 'b > > as 'b),
|
||||||
|
but the expected method type was
|
||||||
|
'c. 'c * < m : 'a * < m : 'c. 'b > > as 'b
|
||||||
The universal variable 'a would escape its scope
|
The universal variable 'a would escape its scope
|
||||||
|}];;
|
|}];;
|
||||||
|
|
||||||
|
|
|
@ -1097,12 +1097,13 @@ and tree_of_typfields sch rest = function
|
||||||
let typexp sch ppf ty =
|
let typexp sch ppf ty =
|
||||||
!Oprint.out_type ppf (tree_of_typexp sch ty)
|
!Oprint.out_type ppf (tree_of_typexp sch ty)
|
||||||
|
|
||||||
|
let marked_type_expr ppf ty = typexp false ppf ty
|
||||||
|
|
||||||
let type_expr ppf ty =
|
let type_expr ppf ty =
|
||||||
(* [type_expr] is used directly by error message printers ,
|
(* [type_expr] is used directly by error message printers,
|
||||||
we mark eventual loops ourself to avoid any misuse and stackoverflow *)
|
we mark eventual loops ourself to avoid any misuse and stack overflow *)
|
||||||
reset_loop_marks ();
|
reset_and_mark_loops ty;
|
||||||
mark_loops ty;
|
marked_type_expr ppf ty
|
||||||
typexp false ppf ty
|
|
||||||
|
|
||||||
and type_sch ppf ty = typexp true ppf ty
|
and type_sch ppf ty = typexp true ppf ty
|
||||||
|
|
||||||
|
@ -2017,8 +2018,9 @@ let explanation intro prev env = function
|
||||||
| Trace.Variant v -> explain_variant v
|
| Trace.Variant v -> explain_variant v
|
||||||
| Trace.Obj o -> explain_object o
|
| Trace.Obj o -> explain_object o
|
||||||
| Trace.Rec_occur(x,y) ->
|
| Trace.Rec_occur(x,y) ->
|
||||||
|
reset_and_mark_loops y;
|
||||||
Some(dprintf "@,@[<hov>The type variable %a occurs inside@ %a@]"
|
Some(dprintf "@,@[<hov>The type variable %a occurs inside@ %a@]"
|
||||||
type_expr x type_expr y)
|
marked_type_expr x marked_type_expr y)
|
||||||
|
|
||||||
let mismatch intro env trace =
|
let mismatch intro env trace =
|
||||||
Trace.explain trace (fun ~prev h -> explanation intro prev env h)
|
Trace.explain trace (fun ~prev h -> explanation intro prev env h)
|
||||||
|
|
|
@ -93,7 +93,18 @@ val reset: unit -> unit
|
||||||
val mark_loops: type_expr -> unit
|
val mark_loops: type_expr -> unit
|
||||||
val reset_and_mark_loops: type_expr -> unit
|
val reset_and_mark_loops: type_expr -> unit
|
||||||
val reset_and_mark_loops_list: type_expr list -> unit
|
val reset_and_mark_loops_list: type_expr list -> unit
|
||||||
|
|
||||||
val type_expr: formatter -> type_expr -> unit
|
val type_expr: formatter -> type_expr -> unit
|
||||||
|
val marked_type_expr: formatter -> type_expr -> unit
|
||||||
|
(** The function [type_expr] is the safe version of the pair
|
||||||
|
[(typed_expr, marked_type_expr)]:
|
||||||
|
it takes care of marking loops in the type expression and resetting
|
||||||
|
type variable names before printing.
|
||||||
|
Contrarily, the function [marked_type_expr] should only be called on
|
||||||
|
type expressions whose loops have been marked or it may stackoverflow
|
||||||
|
(see #8860 for examples).
|
||||||
|
*)
|
||||||
|
|
||||||
val constructor_arguments: formatter -> constructor_arguments -> unit
|
val constructor_arguments: formatter -> constructor_arguments -> unit
|
||||||
val tree_of_type_scheme: type_expr -> out_type
|
val tree_of_type_scheme: type_expr -> out_type
|
||||||
val type_sch : formatter -> type_expr -> unit
|
val type_sch : formatter -> type_expr -> unit
|
||||||
|
|
|
@ -1888,7 +1888,6 @@ let report_error env ppf = function
|
||||||
| Pattern_type_clash ty ->
|
| Pattern_type_clash ty ->
|
||||||
(* XXX Trace *)
|
(* XXX Trace *)
|
||||||
(* XXX Revoir message d'erreur | Improve error message *)
|
(* XXX Revoir message d'erreur | Improve error message *)
|
||||||
Printtyp.reset_and_mark_loops ty;
|
|
||||||
fprintf ppf "@[%s@ %a@]"
|
fprintf ppf "@[%s@ %a@]"
|
||||||
"This pattern cannot match self: it only matches values of type"
|
"This pattern cannot match self: it only matches values of type"
|
||||||
Printtyp.type_expr ty
|
Printtyp.type_expr ty
|
||||||
|
|
|
@ -4801,7 +4801,6 @@ let report_error ~loc env = function
|
||||||
fprintf ppf "but an expression was expected of type");
|
fprintf ppf "but an expression was expected of type");
|
||||||
) ()
|
) ()
|
||||||
| Apply_non_function typ ->
|
| Apply_non_function typ ->
|
||||||
reset_and_mark_loops typ;
|
|
||||||
begin match (repr typ).desc with
|
begin match (repr typ).desc with
|
||||||
Tarrow _ ->
|
Tarrow _ ->
|
||||||
Location.errorf ~loc
|
Location.errorf ~loc
|
||||||
|
@ -4818,7 +4817,6 @@ let report_error ~loc env = function
|
||||||
| Nolabel -> fprintf ppf "without label"
|
| Nolabel -> fprintf ppf "without label"
|
||||||
| l -> fprintf ppf "with label %s" (prefixed_label_name l)
|
| l -> fprintf ppf "with label %s" (prefixed_label_name l)
|
||||||
in
|
in
|
||||||
reset_and_mark_loops ty;
|
|
||||||
Location.errorf ~loc
|
Location.errorf ~loc
|
||||||
"@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
|
"@[<v>@[<2>The function applied to this argument has type@ %a@]@.\
|
||||||
This argument cannot be applied %a@]"
|
This argument cannot be applied %a@]"
|
||||||
|
@ -4836,7 +4834,6 @@ let report_error ~loc env = function
|
||||||
| Wrong_name (eorp, ty_expected, kind, p, name, valid_names) ->
|
| Wrong_name (eorp, ty_expected, kind, p, name, valid_names) ->
|
||||||
Location.error_of_printer ~loc (fun ppf () ->
|
Location.error_of_printer ~loc (fun ppf () ->
|
||||||
let { ty; explanation } = ty_expected in
|
let { ty; explanation } = ty_expected in
|
||||||
reset_and_mark_loops ty;
|
|
||||||
if Path.is_constructor_typath p then begin
|
if Path.is_constructor_typath p then begin
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[The field %s is not part of the record \
|
"@[The field %s is not part of the record \
|
||||||
|
@ -4871,7 +4868,6 @@ let report_error ~loc env = function
|
||||||
| Invalid_format msg ->
|
| Invalid_format msg ->
|
||||||
Location.errorf ~loc "%s" msg
|
Location.errorf ~loc "%s" msg
|
||||||
| Undefined_method (ty, me, valid_methods) ->
|
| Undefined_method (ty, me, valid_methods) ->
|
||||||
reset_and_mark_loops ty;
|
|
||||||
Location.error_of_printer ~loc (fun ppf () ->
|
Location.error_of_printer ~loc (fun ppf () ->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<v>@[This expression has type@;<1 2>%a@]@,\
|
"@[<v>@[This expression has type@;<1 2>%a@]@,\
|
||||||
|
@ -4924,7 +4920,6 @@ let report_error ~loc env = function
|
||||||
"of the form: `(foo : ty1 :> ty2)'."
|
"of the form: `(foo : ty1 :> ty2)'."
|
||||||
) ()
|
) ()
|
||||||
| Too_many_arguments (in_function, ty, explanation) ->
|
| Too_many_arguments (in_function, ty, explanation) ->
|
||||||
reset_and_mark_loops ty;
|
|
||||||
if in_function then begin
|
if in_function then begin
|
||||||
Location.errorf ~loc
|
Location.errorf ~loc
|
||||||
"This function expects too many arguments,@ \
|
"This function expects too many arguments,@ \
|
||||||
|
@ -4943,14 +4938,12 @@ let report_error ~loc env = function
|
||||||
| Nolabel -> "but its first argument is not labelled"
|
| Nolabel -> "but its first argument is not labelled"
|
||||||
| l -> sprintf "but its first argument is labelled %s"
|
| l -> sprintf "but its first argument is labelled %s"
|
||||||
(prefixed_label_name l) in
|
(prefixed_label_name l) in
|
||||||
reset_and_mark_loops ty;
|
|
||||||
Location.errorf ~loc
|
Location.errorf ~loc
|
||||||
"@[<v>@[<2>This function should have type@ %a%t@]@,%s@]"
|
"@[<v>@[<2>This function should have type@ %a%t@]@,%s@]"
|
||||||
type_expr ty
|
type_expr ty
|
||||||
(report_type_expected_explanation_opt explanation)
|
(report_type_expected_explanation_opt explanation)
|
||||||
(label_mark l)
|
(label_mark l)
|
||||||
| Scoping_let_module(id, ty) ->
|
| Scoping_let_module(id, ty) ->
|
||||||
reset_and_mark_loops ty;
|
|
||||||
Location.errorf ~loc
|
Location.errorf ~loc
|
||||||
"This `let module' expression has type@ %a@ \
|
"This `let module' expression has type@ %a@ \
|
||||||
In this type, the locally bound module name %s escapes its scope"
|
In this type, the locally bound module name %s escapes its scope"
|
||||||
|
|
|
@ -1587,12 +1587,14 @@ let explain_unbound_gen ppf tv tl typ kwd pr =
|
||||||
Printtyp.reset_and_mark_loops_list [typ ti; ty0];
|
Printtyp.reset_and_mark_loops_list [typ ti; ty0];
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]"
|
".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]"
|
||||||
kwd pr ti Printtyp.type_expr tv
|
kwd pr ti Printtyp.marked_type_expr tv
|
||||||
with Not_found -> ()
|
with Not_found -> ()
|
||||||
|
|
||||||
let explain_unbound ppf tv tl typ kwd lab =
|
let explain_unbound ppf tv tl typ kwd lab =
|
||||||
explain_unbound_gen ppf tv tl typ kwd
|
explain_unbound_gen ppf tv tl typ kwd
|
||||||
(fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti))
|
(fun ppf ti ->
|
||||||
|
fprintf ppf "%s%a" (lab ti) Printtyp.marked_type_expr (typ ti)
|
||||||
|
)
|
||||||
|
|
||||||
let explain_unbound_single ppf tv ty =
|
let explain_unbound_single ppf tv ty =
|
||||||
let trivial ty =
|
let trivial ty =
|
||||||
|
@ -1634,16 +1636,13 @@ let report_error ppf = function
|
||||||
| Recursive_abbrev s ->
|
| Recursive_abbrev s ->
|
||||||
fprintf ppf "The type abbreviation %s is cyclic" s
|
fprintf ppf "The type abbreviation %s is cyclic" s
|
||||||
| Cycle_in_def (s, ty) ->
|
| Cycle_in_def (s, ty) ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
|
||||||
fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]"
|
fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]"
|
||||||
s Printtyp.type_expr ty
|
s Printtyp.type_expr ty
|
||||||
| Definition_mismatch (ty, None) ->
|
| Definition_mismatch (ty, None) ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
|
||||||
fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]@]"
|
fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]@]"
|
||||||
"This variant or record definition" "does not match that of type"
|
"This variant or record definition" "does not match that of type"
|
||||||
Printtyp.type_expr ty
|
Printtyp.type_expr ty
|
||||||
| Definition_mismatch (ty, Some err) ->
|
| Definition_mismatch (ty, Some err) ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
|
||||||
fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
|
fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]"
|
||||||
"This variant or record definition" "does not match that of type"
|
"This variant or record definition" "does not match that of type"
|
||||||
Printtyp.type_expr ty
|
Printtyp.type_expr ty
|
||||||
|
|
|
@ -757,7 +757,6 @@ let report_error env ppf = function
|
||||||
"which should be"
|
"which should be"
|
||||||
!Oprint.out_type (tree_of_typexp false ty'))
|
!Oprint.out_type (tree_of_typexp false ty'))
|
||||||
| Not_a_variant ty ->
|
| Not_a_variant ty ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[The type %a@ does not expand to a polymorphic variant type@]"
|
"@[The type %a@ does not expand to a polymorphic variant type@]"
|
||||||
Printtyp.type_expr ty;
|
Printtyp.type_expr ty;
|
||||||
|
@ -788,7 +787,6 @@ let report_error env ppf = function
|
||||||
fprintf ppf "Multiple constraints for type %a" longident s
|
fprintf ppf "Multiple constraints for type %a" longident s
|
||||||
| Method_mismatch (l, ty, ty') ->
|
| Method_mismatch (l, ty, ty') ->
|
||||||
wrap_printing_env ~error:true env (fun () ->
|
wrap_printing_env ~error:true env (fun () ->
|
||||||
Printtyp.reset_and_mark_loops_list [ty; ty'];
|
|
||||||
fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
|
fprintf ppf "@[<hov>Method '%s' has type %a,@ which should be %a@]"
|
||||||
l Printtyp.type_expr ty Printtyp.type_expr ty')
|
l Printtyp.type_expr ty Printtyp.type_expr ty')
|
||||||
| Opened_object nm ->
|
| Opened_object nm ->
|
||||||
|
@ -798,7 +796,6 @@ let report_error env ppf = function
|
||||||
Some p -> fprintf ppf "@ %a" path p
|
Some p -> fprintf ppf "@ %a" path p
|
||||||
| None -> fprintf ppf "") nm
|
| None -> fprintf ppf "") nm
|
||||||
| Not_an_object ty ->
|
| Not_an_object ty ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
|
||||||
fprintf ppf "@[The type %a@ is not an object type@]"
|
fprintf ppf "@[The type %a@ is not an object type@]"
|
||||||
Printtyp.type_expr ty
|
Printtyp.type_expr ty
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue