PR#7031, Change file + Tests + error message

Changes

@@ -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)

testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml

@@ -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
+;;

testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml.reference

@@ -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>
+# 

utils/warnings.ml

@@ -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" ^
+            "variables " ^ String.concat "," vars in
-            String.concat "," vars ^ " and " ^ last in
+      Printf.sprintf
-      Printf.sprintf "Ambiguous bindings by pattern on %s" msg
+        "Ambiguous guarded pattern, %s may match different or-pattern arguments" msg
 ;;
 
 let nerrors = ref 0;;