testsuite: update

testsuite/tests/backtrace/Makefile

@@ -18,7 +18,8 @@ EXECNAME=program$(EXE)
 
 ABCDFILES=backtrace.ml
 OTHERFILES=backtrace2.ml backtrace3.ml raw_backtrace.ml \
-           backtrace_deprecated.ml backtrace_slots.ml
+           backtrace_deprecated.ml backtrace_slots.ml \
+	   backtrace_or_exception.ml
 INLININGFILES=inline_test.ml inline_traversal_test.ml
 OTHERFILESNOINLINING=pr6920_why_at.ml pr6920_why_swallow.ml
 OTHERFILESNOINLINING_NATIVE=backtraces_and_finalizers.ml

testsuite/tests/backtrace/backtrace_or_exception.byte.reference

@@ -0,0 +1,14 @@
+exception Backtrace_or_exception.Exn
+Raised at file "backtrace_or_exception.ml", line 13, characters 4-13
+Called from file "backtrace_or_exception.ml", line 33, characters 6-10
+---------------------------
+exception Backtrace_or_exception.Exn
+Raised at file "backtrace_or_exception.ml", line 5, characters 10-13
+Called from file "backtrace_or_exception.ml", line 17, characters 8-44
+Re-raised at file "backtrace_or_exception.ml", line 20, characters 4-13
+Called from file "backtrace_or_exception.ml", line 33, characters 6-10
+---------------------------
+exception Backtrace_or_exception.Exn
+Raised at file "backtrace_or_exception.ml", line 29, characters 6-15
+Called from file "backtrace_or_exception.ml", line 33, characters 6-10
+---------------------------

testsuite/tests/backtrace/backtrace_or_exception.ml

@@ -0,0 +1,43 @@
+exception Exn
+
+let return_exn ?(raise_it_instead=false) () =
+  if raise_it_instead then
+    raise Exn
+  else
+    Exn
+
+let without_reraise () =
+  match return_exn () with
+  | Exn as exn
+  | exception (Exn as exn) ->
+    raise exn
+  | _ -> assert false
+
+let with_reraise () =
+  match return_exn ~raise_it_instead:true () with
+  | Exn as exn
+  | exception (Exn as exn) ->
+    raise exn
+  | _ -> assert false
+
+let trickier () =
+  try raise Not_found
+  with e ->
+    match return_exn () with
+    | Exn as exn
+    | exception (Exn as exn) ->
+      raise exn
+    | _ -> assert false
+
+let run f =
+  try f ()
+  with exn ->
+    Printf.printf "exception %s\n" (Printexc.to_string exn);
+    Printexc.print_backtrace stdout;
+    Printf.printf "---------------------------\n%!"
+
+let _ =
+  Printexc.record_backtrace true;
+  run without_reraise;
+  run with_reraise;
+  run trickier

testsuite/tests/backtrace/backtrace_or_exception.native.reference

@@ -0,0 +1,14 @@
+exception Backtrace_or_exception.Exn
+Raised at file "backtrace_or_exception.ml", line 13, characters 4-13
+Called from file "backtrace_or_exception.ml", line 33, characters 6-10
+---------------------------
+exception Backtrace_or_exception.Exn
+Raised at file "backtrace_or_exception.ml", line 5, characters 4-13
+Called from file "backtrace_or_exception.ml", line 17, characters 8-44
+Re-raised at file "backtrace_or_exception.ml", line 20, characters 4-13
+Called from file "backtrace_or_exception.ml", line 33, characters 6-10
+---------------------------
+exception Backtrace_or_exception.Exn
+Raised at file "backtrace_or_exception.ml", line 29, characters 6-15
+Called from file "backtrace_or_exception.ml", line 33, characters 6-10
+---------------------------

testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml

@@ -35,10 +35,14 @@ let test_match_exhaustiveness_nest1 () =
 ;;
 
 [%%expect{|
-Line _, characters 13-24:
+Line _, characters 4-73:
+  ....match None with
+      | Some false -> ()
       | None | exception _ -> ()
-               ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some true
+val test_match_exhaustiveness_nest1 : unit -> unit = <fun>
 |}]
 ;;
 
@@ -49,10 +53,14 @@ let test_match_exhaustiveness_nest2 () =
 ;;
 
 [%%expect{|
-Line _, characters 19-30:
+Line _, characters 4-73:
+  ....match None with
       | Some false | exception _ -> ()
-                     ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+      | None -> ()
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some true
+val test_match_exhaustiveness_nest2 : unit -> unit = <fun>
 |}]
 ;;
 
@@ -64,9 +72,22 @@ let test_match_exhaustiveness_full () =
 ;;
 
 [%%expect{|
-Line _, characters 19-30:
+Line _, characters 4-111:
+  ....match None with
+      | exception e -> ()
       | Some false | exception _ -> ()
-                     ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+      | None | exception _ -> ()
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Some true
+Line _, characters 29-30:
+      | Some false | exception _ -> ()
+                               ^
+Warning 11: this match case is unused.
+Line _, characters 23-24:
+      | None | exception _ -> ()
+                         ^
+Warning 11: this match case is unused.
+val test_match_exhaustiveness_full : unit -> unit = <fun>
 |}]
 ;;

testsuite/tests/match-exception-warnings/no_mixing_under_guard.ml

@@ -14,8 +14,8 @@ let guarded f =
 [%%expect{|
 exception Exit
 val r : string ref = {contents = ""}
-Line _, characters 11-25:
+Line _, characters 4-25:
     | true | exception Exit when r := "hello"; true -> !r
-             ^^^^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+      ^^^^^^^^^^^^^^^^^^^^^
+Error: Mixing value and exception patterns under when-guards is not supported.
 |}]

testsuite/tests/match-exception-warnings/placement.ml

@@ -25,10 +25,7 @@ let f x =
 ;;
 
 [%%expect{|
-Line _, characters 8-19:
-    | _ | exception _ -> ()
-          ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+val f : (unit -> 'a) -> unit = <fun>
 |}]
 ;;
 
@@ -43,7 +40,7 @@ let f x =
 Line _, characters 7-18:
     with exception _ -> ()
          ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Error: Exception patterns are not allowed in this position.
 |}]
 ;;
 
@@ -57,7 +54,7 @@ let f x =
 Line _, characters 4-17:
     | (exception _) as _pat -> ()
       ^^^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Error: Exception patterns are not allowed in this position.
 |}]
 ;;
 
@@ -70,7 +67,7 @@ let f x =
 Line _, characters 8-19:
     | (_, exception _, _) -> ()
           ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Error: Exception patterns are not allowed in this position.
 |}]
 ;;
 
@@ -84,7 +81,7 @@ let f x =
 Line _, characters 9-22:
     | lazy (exception _) -> ()
            ^^^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Error: Exception patterns are not allowed in this position.
 |}]
 ;;
 
@@ -97,7 +94,7 @@ let f x =
 Line _, characters 17-28:
     | { contents = exception _ } -> ()
                    ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Error: Exception patterns are not allowed in this position.
 |}]
 ;;
 
@@ -110,7 +107,7 @@ let f x =
 Line _, characters 7-18:
     | [| exception _ |] -> ()
          ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Error: Exception patterns are not allowed in this position.
 |}]
 ;;
 
@@ -123,7 +120,7 @@ let f x =
 Line _, characters 9-22:
     | Some (exception _) -> ()
            ^^^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Error: Exception patterns are not allowed in this position.
 |}]
 ;;
 
@@ -136,5 +133,5 @@ let f = function
 Line _, characters 4-15:
     | exception _ -> ()
       ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+Error: Exception patterns are not allowed in this position.
 |}]

testsuite/tests/match-exception-warnings/pr7083.ml

@@ -0,0 +1,13 @@
+(* TEST
+   * expect
+*)
+
+let f x =
+  match x with
+  | `A -> ()
+  | exception Not_found -> ()
+;;
+
+[%%expect{|
+val f : [< `A ] -> unit = <fun>
+|}]

testsuite/tests/match-exception-warnings/reachability.ml

@@ -24,10 +24,11 @@ let f x =
 ;;
 
 [%%expect{|
-Line _, characters 11-22:
+Line _, characters 21-22:
     | None | exception _ -> .
-             ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+                       ^
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: _
 |}]
 ;;
 
@@ -40,10 +41,11 @@ let f x =
 
 
 [%%expect{|
-Line _, characters 4-23:
+Line _, characters 14-23:
     | exception Not_found | None -> .
-      ^^^^^^^^^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+                ^^^^^^^^^
+Error: This match case could not be refuted.
+       Here is an example of a value that would reach it: Not_found
 |}]
 ;;
 
@@ -54,9 +56,6 @@ let f x =
 ;;
 
 [%%expect{|
-Line _, characters 8-19:
-    | _ | exception _ -> ()
-          ^^^^^^^^^^^
-Error: Exception patterns must be at the top level of a match case.
+val f : 'a -> unit = <fun>
 |}]
 ;;

testsuite/tests/match-exception/identifier_sharing.ml

@@ -0,0 +1,9 @@
+(* TEST
+*)
+
+exception String of string
+
+let _ =
+  match "foo" with
+  | str | exception (String str) -> print_endline str
+  | exception _ -> print_endline "unexpected exception!"

testsuite/tests/match-exception/identifier_sharing.reference

@@ -0,0 +1 @@
+foo

testsuite/tests/match-exception/ocamltests

@@ -1,5 +1,6 @@
 allocation.ml
 exception_propagation.ml
+identifier_sharing.ml
 match_failure.ml
 nested_handlers.ml
 raise_from_success_continuation.ml