Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

PR#7031, Change file + Tests + error message

master
Luc Maranget 2015-12-04 17:55:29 +01:00
parent 74356166ac
commit c54df509c0
4 changed files with 287 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Changes
View File

@ -93,6 +93,8 @@ Compilers:
review by Xavier Leroy)
- PR#7026, GPR#288: remove write barrier for polymorphic variants without arguments
(Simon Cruanes)
- PR#7031: new warning, ambiguous guarded or-patterns (Luc Maranget,
Gabriel Scherer, report by Martin Clochard and Claude Marché).
- PR#7067: Performance regression in the native compiler for long
nested structures (Alain Frisch, report by Daniel Bünzli, review
by Jacques Garrigue)

177
testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml Normal file
View File

@ -0,0 +1,177 @@
let () = print_endline "\n\
<----------------------------------------------------------------------\n\
To check the result file for this test, it suffices to look for \"val\"\n\
lines corresponding to toplevel answers. If they start with\n\
\n\
\ val ambiguous_...\n\
\n\
then just above there should be the warning text for Warning 57\n\
(we try to avoid all other warnings). If they start with\n\
\n\
\ val not_ambiguous_...\n\
\n\
then just above there should be *no* warning text.\n\
---------------------------------------------------------------------->\n\
";;
type expr = Val of int | Rest;;
let ambiguous_typical_example = function
| ((Val x, _) | (_, Val x)) when x < 0 -> ()
| (_, Rest) -> ()
| (_, Val x) ->
(* the reader might expect *)
assert (x >= 0);
(* to hold here, but it is wrong! *)
()
;;
let () = print_endline "Note that an Assert_failure is expected just below.";;
let fails = ambiguous_typical_example (Val 2, Val (-1))
;;
let not_ambiguous__no_orpat = function
| Some x when x > 0 -> ()
| Some _ -> ()
| None -> ()
;;
let not_ambiguous__no_guard = function
| `A -> ()
| (`B | `C) -> ()
;;
let not_ambiguous__no_patvar_in_guard b = function
| (`B x | `C x) when b -> ignore x
| _ -> ()
;;
let not_ambiguous__disjoint_cases = function
| (`B x | `C x) when x -> ()
| _ -> ()
;;
(* the curious (..., _, Some _) | (..., Some _, _) device used in
those tests serves to avoid warning 12 (this sub-pattern
is unused), by making sure that, even if the two sides of the
disjunction overlap, none is fully included in the other. *)
let not_ambiguous__prefix_variables = function
| (`B (x, _, Some y) | `B (x, Some y, _)) when x -> ignore y
| _ -> ()
;;
let ambiguous__y = function
| (`B (x, _, Some y) | `B (x, Some y, _)) when y -> ignore x
| _ -> ()
;;
(* it should be understood that the ambiguity warning only protects
(p | q) when guard -> ...
it will never warn on
(p | q) -> if guard ...
This is not a limitation. The point is that people have an
intuitive understanding of [(p | q) when guard -> ...] that differs
from the reality, while there is no such issue with
[(p | q) -> if guard ...].
*)
let not_ambiguous__rhs_not_protected = function
| (`B (x, _, Some y) | `B (x, Some y, _)) -> if y then ignore x else ()
| _ -> ()
;;
let ambiguous__x_y = function
| (`B (x, _, Some y) | `B (x, Some y, _)) when x < y -> ()
| _ -> ()
;;
let ambiguous__x_y_z = function
| (`B (x, z, Some y) | `B (x, Some y, z)) when x < y || Some x = z -> ()
| _ -> ()
;;
let not_ambiguous__disjoint_in_depth = function
| `A (`B x | `C x) when x -> ()
| _ -> ()
;;
let not_ambiguous__prefix_variables_in_depth = function
| `A (`B (x, `C1) | `B (x, `C2)) when x -> ()
| _ -> ()
;;
let ambiguous__in_depth = function
| `A (`B (Some x, _) | `B (_, Some x)) when x -> ()
| _ -> ()
;;
let not_ambiguous__several_orpats = function
| `A ((`B (x, Some _, _) | `B (x, _, Some _)),
(`C (y, Some _, _) | `C (y, _, Some _)),
(`D1 (_, z, Some _, _) | `D2 (_, z, _, Some _))) when x < y && x < z -> ()
| _ -> ()
;;
let ambiguous__first_orpat = function
| `A ((`B (Some x, _) | `B (_, Some x)),
(`C (Some y, Some _, _) | `C (Some y, _, Some _))) when x < y -> ()
| _ -> ()
;;
let ambiguous__second_orpat = function
| `A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)),
(`C (Some y, _) | `C (_, Some y))) when x < y -> ()
| _ -> ()
;;
(* check that common prefixes work as expected *)
let not_ambiguous__pairs = function
| (x, Some _, _) | (x, _, Some _) when x -> ()
| _ -> ()
;;
let not_ambiguous__vars =
begin[@warning "-12"] function
| (x | x) when x -> ()
| _ -> ()
end
;;
let not_ambiguous__as p = function
| (([], _) as x | ((_, []) as x)) when p x -> ()
| _ -> ()
;;
let not_ambiguous__as_var p = function
| (([], _) as x | x) when p x -> ()
| _ -> ()
;;
let not_ambiguous__var_as p = function
| (x, Some _, _) | (([], _) as x, _, Some _) when p x -> ()
| _ -> ()
;;
let not_ambiguous__lazy = function
| (([], _), lazy x) | ((_, []), lazy x) when x -> ()
| _ -> ()
;;
type t = A of int * int option * int option | B;;
let not_ambiguous__constructor = function
| A (x, Some _, _) | A (x, _, Some _) when x > 0 -> ()
| A _ | B -> ()
;;
type tt = Z of int | Y of int * int | X of tt * tt
;;
let ambiguous a = match a with
| X (Z x,Y (y,0))
| X (Z y,Y (x,_))
when x+y > 0 -> 0
| X _|Y _|Z _ -> 1
;;

102
testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference Normal file
View File

@ -0,0 +1,102 @@
#
<----------------------------------------------------------------------
To check the result file for this test, it suffices to look for "val"
lines corresponding to toplevel answers. If they start with
val ambiguous_...
then just above there should be the warning text for Warning 57
(we try to avoid all other warnings). If they start with
val not_ambiguous_...
then just above there should be *no* warning text.
---------------------------------------------------------------------->
# type expr = Val of int | Rest
# Characters 46-71:
| ((Val x, _) | (_, Val x)) when x < 0 -> ()
^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 57: Ambiguous guarded pattern, variable x may match different or-pattern arguments
val ambiguous_typical_example : expr * expr -> unit = <fun>
# Note that an Assert_failure is expected just below.
# Exception: Assert_failure ("//toplevel//", 23, 6).
# val not_ambiguous__no_orpat : int option -> unit = <fun>
# val not_ambiguous__no_guard : [< `A | `B | `C ] -> unit = <fun>
# val not_ambiguous__no_patvar_in_guard :
bool -> [> `B of 'a | `C of 'a ] -> unit = <fun>
# val not_ambiguous__disjoint_cases : [> `B of bool | `C of bool ] -> unit =
<fun>
# * * * val not_ambiguous__prefix_variables :
[> `B of bool * 'a option * 'a option ] -> unit = <fun>
# Characters 33-72:
| (`B (x, _, Some y) | `B (x, Some y, _)) when y -> ignore x
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 57: Ambiguous guarded pattern, variable y may match different or-pattern arguments
val ambiguous__y : [> `B of 'a * bool option * bool option ] -> unit = <fun>
# * * * * * * * * val not_ambiguous__rhs_not_protected :
[> `B of 'a * bool option * bool option ] -> unit = <fun>
# Characters 35-74:
| (`B (x, _, Some y) | `B (x, Some y, _)) when x < y -> ()
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 57: Ambiguous guarded pattern, variable y may match different or-pattern arguments
val ambiguous__x_y : [> `B of 'a * 'a option * 'a option ] -> unit = <fun>
# Characters 37-76:
| (`B (x, z, Some y) | `B (x, Some y, z)) when x < y || Some x = z -> ()
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 57: Ambiguous guarded pattern, variables y,z may match different or-pattern arguments
val ambiguous__x_y_z : [> `B of 'a * 'a option * 'a option ] -> unit = <fun>
# val not_ambiguous__disjoint_in_depth :
[> `A of [> `B of bool | `C of bool ] ] -> unit = <fun>
# val not_ambiguous__prefix_variables_in_depth :
[> `A of [> `B of bool * [> `C1 | `C2 ] ] ] -> unit = <fun>
# Characters 40-76:
| `A (`B (Some x, _) | `B (_, Some x)) when x -> ()
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 57: Ambiguous guarded pattern, variable x may match different or-pattern arguments
val ambiguous__in_depth :
[> `A of [> `B of bool option * bool option ] ] -> unit = <fun>
# val not_ambiguous__several_orpats :
[> `A of
[> `B of 'a * 'b option * 'c option ] *
[> `C of 'a * 'd option * 'e option ] *
[> `D1 of 'f * 'a * 'g option * 'h | `D2 of 'i * 'a * 'j * 'k option ] ] ->
unit = <fun>
# Characters 43-140:
....`A ((`B (Some x, _) | `B (_, Some x)),
(`C (Some y, Some _, _) | `C (Some y, _, Some _))).................
Warning 57: Ambiguous guarded pattern, variable x may match different or-pattern arguments
val ambiguous__first_orpat :
[> `A of
[> `B of 'a option * 'a option ] *
[> `C of 'a option * 'b option * 'c option ] ] ->
unit = <fun>
# Characters 44-141:
....`A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)),
(`C (Some y, _) | `C (_, Some y))).................
Warning 57: Ambiguous guarded pattern, variable y may match different or-pattern arguments
val ambiguous__second_orpat :
[> `A of
[> `B of 'a option * 'b option * 'c option ] *
[> `C of 'a option * 'a option ] ] ->
unit = <fun>
# val not_ambiguous__pairs : bool * 'a option * 'b option -> unit = <fun>
# val not_ambiguous__vars : bool -> unit = <fun>
# val not_ambiguous__as :
('a list * 'b list -> bool) -> 'a list * 'b list -> unit = <fun>
# val not_ambiguous__as_var : ('a list * 'b -> bool) -> 'a list * 'b -> unit =
<fun>
# val not_ambiguous__var_as :
('a list * 'b -> bool) -> ('a list * 'b) * 'c option * 'd option -> unit =
<fun>
# val not_ambiguous__lazy : ('a list * 'b list) * bool lazy_t -> unit = <fun>
# type t = A of int * int option * int option | B
# val not_ambiguous__constructor : t -> unit = <fun>
# type tt = Z of int | Y of int * int | X of tt * tt
# Characters 34-67:
..X (Z x,Y (y,0))
| X (Z y,Y (x,_))
Warning 57: Ambiguous guarded pattern, variables x,y may match different or-pattern arguments
val ambiguous : tt -> int = <fun>
#

11
utils/warnings.ml
View File

@ -431,13 +431,14 @@ let message = function
Printf.sprintf "Inlining impossible in this context: %s" reason
| Ambiguous_pattern vars ->
let msg =
let vars,last = Misc.split_last (List.sort String.compare vars) in
let vars = List.sort String.compare vars in
match vars with
| [] -> "variable " ^ last
| [] -> assert false
| [x] -> "variable " ^ x
| _::_ ->
"variables" ^
String.concat "," vars ^ " and " ^ last in
Printf.sprintf "Ambiguous bindings by pattern on %s" msg
"variables " ^ String.concat "," vars in
Printf.sprintf
"Ambiguous guarded pattern, %s may match different or-pattern arguments" msg
;;
let nerrors = ref 0;;