Skip to content

Commit cfeda89

Browse files
gaschegasche
committed
Merge pull request #305 from trefis/or-exception
Support "exception" under or-patterns (PR#6422)
2 parents 77cf36c + 3363a7a commit cfeda89

26 files changed

Lines changed: 493 additions & 96 deletions

‎Changes‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -55,6 +55,9 @@ Language features:
5555
- GPR#273: allow to get the extension slot of an extension constructor
5656
by writing [%extension_constructor <path>]
5757
(Jérémie Dimino)
58+
- PR#6422, GPR#305: Support "exception" under or-patterns
59+
(Thomas Refis, with help and review from Alain Frisch, Luc Maranget, Gabriel
60+
Scherer, Leo White and Jeremy Yallop)
5861

5962
Compilers:
6063
- PR#4800: better compilation of tuple assignment (Gabriel Scherer and

‎bytecomp/matching.ml‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -548,6 +548,7 @@ let rec exc_inside p = match p.pat_desc with
548548
-> exc_insides ps
549549
| Tpat_variant (_, Some q,_)
550550
| Tpat_alias (q,_,_)
551+
| Tpat_exception q
551552
| Tpat_lazy q
552553
-> exc_inside q
553554
| Tpat_record (lps,_) ->
@@ -704,6 +705,7 @@ let rec extract_vars r p = match p.pat_desc with
704705
| Tpat_array pats ->
705706
List.fold_left extract_vars r pats
706707
| Tpat_variant (_,Some p, _) -> extract_vars r p
708+
| Tpat_exception p
707709
| Tpat_lazy p -> extract_vars r p
708710
| Tpat_or (p,_,_) -> extract_vars r p
709711
| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r
@@ -2802,7 +2804,8 @@ let find_in_pat pred =
28022804
let rec find_rec p =
28032805
pred p.pat_desc ||
28042806
begin match p.pat_desc with
2805-
| Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p ->
2807+
| Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p
2808+
| Tpat_exception p ->
28062809
find_rec p
28072810
| Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps ->
28082811
List.exists find_rec ps
@@ -2822,6 +2825,7 @@ let is_lazy_pat = function
28222825
| Tpat_alias _ | Tpat_variant _ | Tpat_record _
28232826
| Tpat_tuple _|Tpat_construct _ | Tpat_array _
28242827
| Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any
2828+
| Tpat_exception _
28252829
-> false
28262830

28272831
let is_lazy p = find_in_pat is_lazy_pat p
@@ -2837,7 +2841,7 @@ let have_mutable_field p = match p with
28372841
| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _
28382842
| Tpat_tuple _|Tpat_construct _ | Tpat_array _
28392843
| Tpat_or _
2840-
| Tpat_constant _ | Tpat_var _ | Tpat_any
2844+
| Tpat_constant _ | Tpat_var _ | Tpat_any | Tpat_exception _
28412845
-> false
28422846

28432847
let is_mutable p = find_in_pat have_mutable_field p

‎bytecomp/translcore.ml‎

Lines changed: 68 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -512,6 +512,15 @@ let extract_float = function
512512

513513
(* To find reasonable names for let-bound and lambda-bound idents *)
514514

515+
(* I'm a bit sad about this duplication. *)
516+
let rec name_pattern' default = function
517+
[] -> Ident.create default
518+
| (p, _) :: rem ->
519+
match p.pat_desc with
520+
Tpat_var (id, _) -> id
521+
| Tpat_alias(p, id, _) -> id
522+
| _ -> name_pattern' default rem
523+
515524
let rec name_pattern default = function
516525
[] -> Ident.create default
517526
| {c_lhs=p; _} :: rem ->
@@ -572,7 +581,7 @@ let rec push_defaults loc bindings cases partial =
572581
val_attributes = [];
573582
Types.val_loc = Location.none;
574583
})},
575-
cases, [], partial) }
584+
cases, partial) }
576585
in
577586
push_defaults loc bindings
578587
[{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)};
@@ -769,8 +778,8 @@ and transl_exp0 e =
769778
let e = { e with exp_desc = Texp_apply(funct, oargs) } in
770779
event_after e (transl_apply ~should_be_tailcall ~inlined
771780
(transl_exp funct) oargs e.exp_loc)
772-
| Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) ->
773-
transl_match e arg pat_expr_list exn_pat_expr_list partial
781+
| Texp_match(arg, pat_expr_list, partial) ->
782+
transl_match e arg pat_expr_list partial
774783
| Texp_try(body, pat_expr_list) ->
775784
let id = name_pattern "exn" pat_expr_list in
776785
Ltrywith(transl_exp body, id,
@@ -1232,11 +1241,41 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr =
12321241
end
12331242
end
12341243

1235-
and transl_match e arg pat_expr_list exn_pat_expr_list partial =
1236-
let id = name_pattern "exn" exn_pat_expr_list
1237-
and cases = transl_cases pat_expr_list
1238-
and exn_cases = transl_cases exn_pat_expr_list in
1244+
and transl_match e arg pat_expr_list partial =
1245+
let rewrite_case (val_cases, exn_cases, static_handlers as acc)
1246+
({ c_lhs; c_guard; c_rhs } as case) =
1247+
if c_rhs.exp_desc = Texp_unreachable then acc else
1248+
let val_pat, exn_pat = split_pattern c_lhs in
1249+
match val_pat, exn_pat with
1250+
| None, None -> assert false
1251+
| Some pv, None ->
1252+
assert (Typedtree.pat_equiv pv c_lhs);
1253+
let val_case = transl_case { case with c_lhs = pv } in
1254+
val_case :: val_cases, exn_cases, static_handlers
1255+
| None, Some pe ->
1256+
let exn_case = transl_case { case with c_lhs = pe } in
1257+
val_cases, exn_case :: exn_cases, static_handlers
1258+
| Some pv, Some pe ->
1259+
assert (c_guard = None);
1260+
let lbl = next_negative_raise_count () in
1261+
let static_raise ids =
1262+
Lstaticraise (lbl, List.map (fun id -> Lvar id) ids)
1263+
in
1264+
(* Simplif doesn't like it if binders are not uniq, so we make sure to
1265+
use different names in the value and the exception branches. *)
1266+
let ids = Typedtree.pat_bound_idents pv in
1267+
let eids = List.map Ident.rename ids in
1268+
let pe = alpha_pat (List.combine ids eids) pe in
1269+
(pv, static_raise ids) :: val_cases,
1270+
(pe, static_raise eids) :: exn_cases,
1271+
(lbl, ids, transl_exp c_rhs) :: static_handlers
1272+
in
1273+
let val_cases, exn_cases, static_handlers =
1274+
let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in
1275+
List.rev x, List.rev y, List.rev z
1276+
in
12391277
let static_catch body val_ids handler =
1278+
let id = name_pattern' "exn" exn_cases in
12401279
let static_exception_id = next_negative_raise_count () in
12411280
Lstaticcatch
12421281
(Ltrywith (Lstaticraise (static_exception_id, body), id,
@@ -1246,19 +1285,31 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial =
12461285
in
12471286
match arg, exn_cases with
12481287
| {exp_desc = Texp_tuple argl}, [] ->
1249-
Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial
1288+
assert (static_handlers = []);
1289+
Matching.for_multiple_match e.exp_loc (transl_list argl) val_cases partial
12501290
| {exp_desc = Texp_tuple argl}, _ :: _ ->
1251-
let val_ids = List.map (fun _ -> name_pattern "val" []) argl in
1252-
let lvars = List.map (fun id -> Lvar id) val_ids in
1253-
static_catch (transl_list argl) val_ids
1254-
(Matching.for_multiple_match e.exp_loc lvars cases partial)
1291+
let val_ids = List.map (fun _ -> name_pattern "val" []) argl in
1292+
let lvars = List.map (fun id -> Lvar id) val_ids in
1293+
let classic =
1294+
static_catch (transl_list argl) val_ids
1295+
(Matching.for_multiple_match e.exp_loc lvars val_cases partial)
1296+
in
1297+
List.fold_left (fun body (static_exception_id, val_ids, handler) ->
1298+
Lstaticcatch (body, (static_exception_id, val_ids), handler)
1299+
) classic static_handlers
12551300
| arg, [] ->
1256-
Matching.for_function e.exp_loc None (transl_exp arg) cases partial
1257-
| arg, _ :: _ ->
1258-
let val_id = name_pattern "val" pat_expr_list in
1259-
static_catch [transl_exp arg] [val_id]
1260-
(Matching.for_function e.exp_loc None (Lvar val_id) cases partial)
1301+
assert (static_handlers = []);
1302+
Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial
12611303

1304+
| arg, _ :: _ ->
1305+
let val_id = name_pattern "val" pat_expr_list in
1306+
let classic =
1307+
static_catch [transl_exp arg] [val_id]
1308+
(Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial)
1309+
in
1310+
List.fold_left (fun body (static_exception_id, val_ids, handler) ->
1311+
Lstaticcatch (body, (static_exception_id, val_ids), handler)
1312+
) classic static_handlers
12621313

12631314
(* Wrapper for class compilation *)
12641315

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

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -10,3 +10,22 @@ let test_match_exhaustiveness () =
1010
| Some false -> ()
1111
| None -> ()
1212
;;
13+
14+
let test_match_exhaustiveness_nest1 () =
15+
match None with
16+
| Some false -> ()
17+
| None | exception _ -> ()
18+
;;
19+
20+
let test_match_exhaustiveness_nest2 () =
21+
match None with
22+
| Some false | exception _ -> ()
23+
| None -> ()
24+
;;
25+
26+
let test_match_exhaustiveness_full () =
27+
match None with
28+
| exception e -> ()
29+
| Some false | exception _ -> ()
30+
| None | exception _ -> ()
31+
;;

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

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,4 +8,37 @@ Warning 8: this pattern-matching is not exhaustive.
88
Here is an example of a value that is not matched:
99
Some true
1010
val test_match_exhaustiveness : unit -> unit = <fun>
11+
# Characters 44-109:
12+
..match None with
13+
| Some false -> ()
14+
| None | exception _ -> ()
15+
Warning 8: this pattern-matching is not exhaustive.
16+
Here is an example of a value that is not matched:
17+
Some true
18+
val test_match_exhaustiveness_nest1 : unit -> unit = <fun>
19+
# Characters 44-109:
20+
..match None with
21+
| Some false | exception _ -> ()
22+
| None -> ()
23+
Warning 8: this pattern-matching is not exhaustive.
24+
Here is an example of a value that is not matched:
25+
Some true
26+
val test_match_exhaustiveness_nest2 : unit -> unit = <fun>
27+
# Characters 43-144:
28+
..match None with
29+
| exception e -> ()
30+
| Some false | exception _ -> ()
31+
| None | exception _ -> ()
32+
Warning 8: this pattern-matching is not exhaustive.
33+
Here is an example of a value that is not matched:
34+
Some true
35+
Characters 108-109:
36+
| Some false | exception _ -> ()
37+
^
38+
Warning 11: this match case is unused.
39+
Characters 137-138:
40+
| None | exception _ -> ()
41+
^
42+
Warning 11: this match case is unused.
43+
val test_match_exhaustiveness_full : unit -> unit = <fun>
1144
#

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

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
exception Exit
2+
3+
let r = ref ""
4+
5+
let guarded f =
6+
match f () with
7+
| true | exception Exit when r := "hello"; true -> !r
8+
| _ -> "other"
9+
;;

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

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
2+
# Characters 70-91:
3+
| true | exception Exit when r := "hello"; true -> !r
4+
^^^^^^^^^^^^^^^^^^^^^
5+
Error: Mixing return and exception cases under when-guards is not supported.
6+
#

‎testsuite/tests/match-exception-warnings/no_value_clauses.ml‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
let test f =
2+
match f () with exception Not_found -> ()
3+
;;

‎testsuite/tests/match-exception-warnings/no_value_clauses.ml.reference‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
2+
# Characters 15-56:
3+
match f () with exception Not_found -> ()
4+
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
5+
Error: None of the patterns in this 'match' expression match values.
6+
#

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

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,60 @@
1+
(*****************************************************)
2+
(* Restrict where "exception P" patterns can appear. *)
3+
(*****************************************************)
4+
5+
(* should be accepted *)
6+
7+
let f x =
8+
match x () with
9+
| _ -> ()
10+
| exception _ -> ()
11+
;;
12+
13+
let f x =
14+
match x () with
15+
| _ | exception _ -> ()
16+
;;
17+
18+
(* should be rejected *)
19+
20+
let f x =
21+
try x (); ()
22+
with exception _ -> ()
23+
;;
24+
25+
let f x =
26+
match x () with
27+
| (exception _) as _pat -> ()
28+
| _ -> ()
29+
;;
30+
31+
let f x =
32+
match x () with
33+
| (_, exception _, _) -> ()
34+
;;
35+
36+
let f x =
37+
match x () with
38+
| lazy (exception _) -> ()
39+
| _ -> ()
40+
;;
41+
42+
let f x =
43+
match x () with
44+
| { contents = exception _ } -> ()
45+
;;
46+
47+
let f x =
48+
match x () with
49+
| [| exception _ |] -> ()
50+
;;
51+
52+
let f x =
53+
match x () with
54+
| Some (exception _) -> ()
55+
;;
56+
57+
let f = function
58+
| exception _ -> ()
59+
| _ -> ()
60+
;;

0 commit comments

Comments
 (0)