From 5bc3a41c94bab57b199a4edd87c333ca7f879c8b Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Wed, 26 Jul 2023 12:37:52 -0400 Subject: [PATCH 01/15] multiway typechecking and translation --- ocaml/lambda/translcore.ml | 205 +++++++++++-------- ocaml/ocamldoc/odoc_ast.ml | 107 +++++----- ocaml/testsuite/tests/pattern-guards/test.ml | 100 +++------ ocaml/typing/cmt2annot.ml | 19 +- ocaml/typing/parmatch.ml | 58 +++--- ocaml/typing/printtyped.ml | 28 +-- ocaml/typing/rec_check.ml | 15 +- ocaml/typing/tast_iterator.ml | 27 +-- ocaml/typing/tast_iterator.mli | 2 +- ocaml/typing/tast_mapper.ml | 30 +-- ocaml/typing/tast_mapper.mli | 2 +- ocaml/typing/typeclass.ml | 2 +- ocaml/typing/typecore.ml | 140 +++++++------ ocaml/typing/typedtree.ml | 50 +++-- ocaml/typing/typedtree.mli | 57 ++++-- ocaml/typing/untypeast.ml | 40 ++-- 16 files changed, 461 insertions(+), 421 deletions(-) diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 85b27f838e3..812a7ebe2db 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -58,6 +58,12 @@ let sort_must_not_be_void loc ty sort = let layout_exp sort e = layout e.exp_env e.exp_loc sort e.exp_type +let layout_rhs sort = function + | Simple_rhs rhs | Boolean_guarded_rhs { bg_rhs = rhs; _ } -> + layout_exp sort rhs + | Pattern_guarded_rhs { pg_env; pg_loc; pg_type; _ } -> + layout pg_env pg_loc sort pg_type + (* Forward declaration -- to be filled in by Translmod.transl_module *) let transl_module = ref((fun ~scopes:_ _cc _rootpath _modl -> assert false) : @@ -216,32 +222,40 @@ let rec trivial_pat pat = let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases partial warnings = match cases with - [{c_lhs=pat; c_guard=None; - c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; - region; curry; warnings; arg_mode; - arg_sort; ret_sort; alloc_mode } } - as exp}] when bindings = [] || trivial_pat pat -> + [{c_lhs=pat; + c_rhs= + Simple_rhs + ( { exp_desc = Texp_function { arg_label; param; cases; partial; + region; curry; warnings; arg_mode; + arg_sort; ret_sort; alloc_mode } } as exp + )}] + when bindings = [] || trivial_pat pat -> let cases = push_defaults exp.exp_loc bindings false arg_mode arg_sort cases partial warnings in - [{c_lhs=pat; c_guard=None; - c_rhs={exp with exp_desc = - Texp_function { arg_label; param; cases; partial; - region; curry; warnings; arg_mode; - arg_sort; ret_sort; alloc_mode }}}] - | [{c_lhs=pat; c_guard=None; - c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}]; - exp_desc = Texp_let - (Nonrecursive, binds, - ({exp_desc = Texp_function _} as e2))}}] -> + [{c_lhs=pat; + c_rhs=Simple_rhs {exp with exp_desc = + Texp_function { arg_label; param; cases; partial; + region; curry; warnings; arg_mode; + arg_sort; ret_sort; alloc_mode }}}] + | [{c_lhs=pat; + c_rhs= + Simple_rhs + { exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}] + ; exp_desc = + Texp_let + (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}} + ] -> push_defaults loc (binds :: bindings) true - arg_mode arg_sort [{c_lhs=pat;c_guard=None;c_rhs=e2}] + arg_mode arg_sort [{c_lhs=pat;c_rhs=Simple_rhs e2}] partial warnings - | [{c_lhs=pat; c_guard=None; c_rhs=exp} as case] + | [{c_lhs=pat; c_rhs=Simple_rhs exp} as case] when use_lhs || trivial_pat pat && exp.exp_desc <> Texp_unreachable -> - [{case with c_rhs = wrap_bindings bindings exp}] - | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] -> + [{case with c_rhs = Simple_rhs (wrap_bindings bindings exp)}] + | {c_lhs=pat; c_rhs=rhs } :: _ + when bindings <> [] -> + let exp = exp_of_rhs rhs in let mode = Value_mode.of_alloc arg_mode in let param = Typecore.name_cases "param" cases in let desc = @@ -266,7 +280,7 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases cases, partial) } in [{c_lhs = {pat with pat_desc = Tpat_var (param, mknoloc name, mode)}; - c_guard = None; c_rhs= wrap_bindings bindings exp}] + c_rhs = Simple_rhs (wrap_bindings bindings exp)}] | _ -> cases @@ -280,18 +294,28 @@ let event_before ~scopes exp lam = let event_after ~scopes exp lam = Translprim.event_after (of_location ~scopes exp.exp_loc) exp lam -let event_function ~scopes exp lam = +let event_function_impl ~scopes loc env lam = if !Clflags.debug && not !Clflags.native_code then let repr = Some (ref 0) in let (info, body) = lam repr in (info, - Levent(body, {lev_loc = of_location ~scopes exp.exp_loc; + Levent(body, {lev_loc = of_location ~scopes loc; lev_kind = Lev_function; lev_repr = repr; - lev_env = exp.exp_env})) + lev_env = env})) else lam None +let event_function ~scopes exp lam = + event_function_impl ~scopes exp.exp_loc exp.exp_env lam + +let event_function_rhs ~scopes rhs lam = + match rhs with + | Simple_rhs rhs_exp | Boolean_guarded_rhs { bg_rhs = rhs_exp; _ } -> + event_function ~scopes rhs_exp lam + | Pattern_guarded_rhs { pg_loc; pg_env; _ } -> + event_function_impl ~scopes pg_loc pg_env lam + (* Assertions *) let assert_failed ~scopes exp = @@ -350,6 +374,10 @@ let can_apply_primitive p pmode pos args = end end +let is_rhs_unreachable = function + | Simple_rhs { exp_desc = Texp_unreachable; _ } -> true + | _ -> false + let rec transl_exp ~scopes sort e = transl_exp1 ~scopes ~in_new_scope:false sort e @@ -1009,39 +1037,30 @@ and transl_list_with_shape ~scopes expr_list = in List.split (List.map transl_with_shape expr_list) -and transl_guard ~scopes guard rhs_sort rhs = - let layout = layout_exp rhs_sort rhs in - match guard with - | None -> - Matching.mk_unguarded_rhs - (event_before ~scopes rhs (transl_exp ~scopes rhs_sort rhs)) - | Some (Predicate cond) -> - let translated_cond = transl_exp ~scopes Sort.for_predef_value cond in - let translated_rhs = - event_before ~scopes rhs (transl_exp ~scopes rhs_sort rhs) - in - let patch_guarded ~patch = - event_before ~scopes cond - (Lifthenelse (translated_cond, translated_rhs, patch, layout)) - in - let free_variables = - Ident.Set.union - (free_variables translated_cond) - (free_variables translated_rhs) - in - Matching.mk_boolean_guarded_rhs ~patch_guarded ~free_variables - | Some (Pattern { pg_scrutinee; pg_scrutinee_sort; pg_pattern; pg_partial; - pg_loc; pg_env }) -> - let guard_case : _ case = - { c_lhs = pg_pattern - ; c_guard = None - ; c_rhs = rhs } +and transl_rhs ~scopes rhs_sort rhs = + let layout = layout_rhs rhs_sort rhs in + let transl_unguarded rhs = + event_before ~scopes rhs (transl_exp ~scopes rhs_sort rhs) + in + match rhs with + | Simple_rhs rhs -> Matching.mk_unguarded_rhs (transl_unguarded rhs) + | Boolean_guarded_rhs { bg_guard; bg_rhs } -> + let guard = transl_exp ~scopes Sort.for_predef_value bg_guard in + let rhs = event_before ~scopes bg_rhs (transl_unguarded bg_rhs) in + let patch_guarded ~patch = + event_before ~scopes bg_guard (Lifthenelse (guard, rhs, patch, layout)) + in + let free_variables = + Ident.Set.union (free_variables guard) (free_variables rhs) in + Matching.mk_boolean_guarded_rhs ~patch_guarded ~free_variables + | Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort; pg_cases; pg_partial; + pg_loc; pg_env; pg_type } -> match pg_partial with - | Partial -> - (* Partial pattern guards may fail to match, so we must construct a - guarded rhs from a continuation that patches in the code to execute - on match failure. + | Partial -> + (* Partial pattern guards may fail to match, so we must construct a + guarded rhs from a continuation that later "patches" in the code to + execute on match failure. *) let patch_guarded ~patch = let any_pat : pattern = @@ -1049,55 +1068,55 @@ and transl_guard ~scopes guard rhs_sort rhs = ; pat_loc = Location.none ; pat_extra = [] ; pat_type = pg_scrutinee.exp_type - ; pat_env = Env.empty + ; pat_env = pg_env ; pat_attributes = [] } in let extra_cases = [ any_pat, Matching.mk_unguarded_rhs patch ] in event_before ~scopes pg_scrutinee (transl_match ~scopes ~arg_sort:pg_scrutinee_sort - ~return_sort:rhs_sort ~return_type:rhs.exp_type ~loc:pg_loc - ~env:pg_env ~extra_cases pg_scrutinee [ guard_case ] - pg_partial) + ~return_sort:rhs_sort ~return_type:pg_type ~loc:pg_loc + ~env:pg_env ~extra_cases pg_scrutinee pg_cases pg_partial) in Matching.mk_pattern_guarded_rhs ~patch_guarded | Total -> (* Total pattern guards are equivalent to nested matches. *) let nested_match = transl_match ~scopes ~arg_sort:pg_scrutinee_sort - ~return_sort:rhs_sort ~return_type:rhs.exp_type ~loc:pg_loc - ~env:pg_env ~extra_cases:[] pg_scrutinee [ guard_case ] pg_partial + ~return_sort:rhs_sort ~return_type:pg_type ~loc:pg_loc + ~env:pg_env ~extra_cases:[] pg_scrutinee pg_cases pg_partial in Matching.mk_unguarded_rhs (event_before ~scopes pg_scrutinee nested_match) -and transl_case ~scopes rhs_sort {c_lhs; c_guard; c_rhs} = - c_lhs, transl_guard ~scopes c_guard rhs_sort c_rhs +and transl_case ~scopes rhs_sort {c_lhs; c_rhs} = + c_lhs, transl_rhs ~scopes rhs_sort c_rhs and transl_cases ~scopes rhs_sort cases = let cases = - List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in + List.filter (fun case -> not (is_rhs_unreachable case.c_rhs)) cases + in List.map (transl_case ~scopes rhs_sort) cases -and transl_case_try ~scopes rhs_sort {c_lhs; c_guard; c_rhs} = +and transl_case_try ~scopes rhs_sort {c_lhs; c_rhs} = iter_exn_names Translprim.add_exception_ident c_lhs; Misc.try_finally - (fun () -> c_lhs, transl_guard ~scopes c_guard rhs_sort c_rhs) + (fun () -> c_lhs, transl_rhs ~scopes rhs_sort c_rhs) ~always:(fun () -> iter_exn_names Translprim.remove_exception_ident c_lhs) and transl_cases_try ~scopes rhs_sort cases = let cases = - List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in + List.filter (fun case -> not (is_rhs_unreachable case.c_rhs)) cases + in List.map (transl_case_try ~scopes rhs_sort) cases and transl_tupled_cases ~scopes rhs_sort patl_expr_list = let patl_expr_list = - List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable) - patl_expr_list in + List.filter (fun (_, rhs) -> not (is_rhs_unreachable rhs)) patl_expr_list + in List.map - (fun (patl, guard, expr) -> - (patl, transl_guard ~scopes guard rhs_sort expr)) + (fun (patl, rhs) -> (patl, transl_rhs ~scopes rhs_sort rhs)) patl_expr_list and transl_apply ~scopes @@ -1221,14 +1240,15 @@ and transl_curried_function ~arity ~region ~curry partial warnings (param:Ident.t) cases = match curry, cases with More_args {partial_mode}, - [{c_lhs=pat; c_guard=None; - c_rhs={exp_desc = - Texp_function - { arg_label = _; param = param'; cases = cases'; - partial = partial'; region = region'; - curry = curry'; - warnings = warnings'; arg_sort; ret_sort }; - exp_env; exp_type; exp_loc }}] + [{c_lhs=pat; + c_rhs=Simple_rhs + {exp_desc = + Texp_function + { arg_label = _; param = param'; cases = cases'; + partial = partial'; region = region'; + curry = curry'; + warnings = warnings'; arg_sort; ret_sort }; + exp_env; exp_type; exp_loc }}] when arity < max_arity -> (* Lfunctions must have local returns after the first local arg/ret *) if Parmatch.inactive ~partial pat @@ -1297,8 +1317,8 @@ and transl_tupled_function let size = List.length pl in let pats_expr_list = List.map - (fun {c_lhs; c_guard; c_rhs} -> - (Matching.flatten_pattern size c_lhs, c_guard, c_rhs)) + (fun {c_lhs; c_rhs} -> + (Matching.flatten_pattern size c_lhs, c_rhs)) cases in let kinds = match arg_layout with @@ -1592,8 +1612,8 @@ and transl_match ~scopes ~arg_sort ~return_sort ~return_type ~loc ~env ~extra_cases arg pat_expr_list partial = let return_layout = layout env loc arg_sort return_type in let rewrite_case (val_cases, exn_cases, static_handlers as acc) - ({ c_lhs; c_guard; c_rhs } as case) = - if c_rhs.exp_desc = Texp_unreachable then acc else + ({ c_lhs; c_rhs } as case) = + if is_rhs_unreachable c_rhs then acc else let val_pat, exn_pat = split_pattern c_lhs in match val_pat, exn_pat with | None, None -> assert false @@ -1608,7 +1628,11 @@ and transl_match ~scopes ~arg_sort ~return_sort ~return_type ~loc ~env in val_cases, exn_case :: exn_cases, static_handlers | Some pv, Some pe -> - assert (c_guard = None); + let rhs_exp = + match c_rhs with + | Simple_rhs rhs -> rhs + | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> assert false + in let lbl = next_raise_count () in let static_raise ids = Lstaticraise (lbl, List.map (fun id -> Lvar id) ids) @@ -1628,8 +1652,8 @@ and transl_match ~scopes ~arg_sort ~return_sort ~return_type ~loc ~env iter_exn_names Translprim.add_exception_ident pe; let rhs = Misc.try_finally - (fun () -> event_before ~scopes c_rhs - (transl_exp ~scopes return_sort c_rhs)) + (fun () -> event_before ~scopes rhs_exp + (transl_exp ~scopes return_sort rhs_exp)) ~always:(fun () -> iter_exn_names Translprim.remove_exception_ident pe) in @@ -1764,17 +1788,18 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort "Translcore.transl_letop: letop should have at least two arguments" | Some (lhs, _) -> Typeopt.function_arg_layout env loc param_sort lhs in - let return_layout = layout_exp case_sort case.c_rhs in + let return_layout = layout_rhs case_sort case.c_rhs in let curry = More_args { partial_mode = Alloc_mode.global } in + let rhs_loc = loc_of_rhs case.c_rhs in let (kind, params, return, _region), body = - event_function ~scopes case.c_rhs + event_function_rhs ~scopes case.c_rhs (function repr -> transl_curried_function ~scopes ~arg_sort:param_sort ~arg_layout - ~return_sort:case_sort ~return_layout case.c_rhs.exp_loc repr - ~region:true ~curry partial warnings param [case]) + ~return_sort:case_sort ~return_layout rhs_loc repr ~region:true + ~curry partial warnings param [case]) in let attr = default_function_attribute in - let loc = of_location ~scopes case.c_rhs.exp_loc in + let loc = of_location ~scopes rhs_loc in let body = maybe_region_layout return body in lfunction ~kind ~params ~return ~body ~attr ~loc ~mode:alloc_heap ~region:true diff --git a/ocaml/ocamldoc/odoc_ast.ml b/ocaml/ocamldoc/odoc_ast.ml index 02018ede594..e36d37e4926 100644 --- a/ocaml/ocamldoc/odoc_ast.ml +++ b/ocaml/ocamldoc/odoc_ast.ml @@ -301,31 +301,36 @@ module Analyser = (* we look if the name of the parameter we just add is "*opt*", which means that there is a let param_name = ... in ... just right now *) let (p, next_exp) = - match parameter with - Simple_name { sn_name = "*opt*" } -> - ( - ( - match func_body.exp_desc with - Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; - vb_expr=exp} :: _, func_body2) -> - let name = Name.from_ident id in - let new_param = Simple_name - { sn_name = name ; - sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ; - sn_type = Odoc_env.subst_type env exp.exp_type - } - in - (new_param, func_body2) - | _ -> - (parameter, func_body) - ) - ) - | _ -> - (parameter, func_body) + match func_body with + | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> + parameter, func_body + | Simple_rhs func_body -> + match parameter with + Simple_name { sn_name = "*opt*" } -> + ( + ( + match func_body.exp_desc with + Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; + vb_expr=exp} :: _, func_body2) -> + let name = Name.from_ident id in + let new_param = Simple_name + { sn_name = name ; + sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ; + sn_type = Odoc_env.subst_type env exp.exp_type + } + in + (new_param, Simple_rhs func_body2) + | _ -> + (parameter, Simple_rhs func_body) + ) + ) + | _ -> + parameter, Simple_rhs func_body in (* continue if the body is still a function *) - match next_exp.exp_desc with - Texp_function { cases = pat_exp_list ; _ } -> + match next_exp with + Simple_rhs + { exp_desc = Texp_function { cases = pat_exp_list ; _ } } -> p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list) | _ -> (* something else ; no more parameter *) @@ -423,9 +428,8 @@ module Analyser = the first time ; in that case we must not keep the first parameter, which is "self-*", the object itself. *) - let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp = - match exp.Typedtree.exp_desc with - Typedtree.Texp_function { cases = pat_exp_list; _ } -> + let rec tt_analyse_method_expression env current_method_name comment_opt ~first = function + | Simple_rhs { exp_desc = Typedtree.Texp_function { cases = pat_exp_list; _ }; _ } -> ( match pat_exp_list with [] -> @@ -460,28 +464,32 @@ module Analyser = (* We look if the name of the parameter we just add is "*opt*", which means that there is a let param_name = ... in ... just right now. *) let (current_param, next_exp) = - match parameter with - Simple_name { sn_name = "*opt*"} -> - ( - ( - match body.exp_desc with - Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; - vb_expr=exp} :: _, body2) -> - let name = Name.from_ident id in - let new_param = Simple_name - { sn_name = name ; - sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ; - sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ; - } - in - (new_param, body2) - | _ -> - (parameter, body) - ) - ) - | _ -> - (* no *opt* parameter, we add the parameter then continue *) - (parameter, body) + match body with + | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> + parameter, body + | Simple_rhs body -> + match parameter with + Simple_name { sn_name = "*opt*"} -> + ( + ( + match body.exp_desc with + Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; + vb_expr=exp} :: _, body2) -> + let name = Name.from_ident id in + let new_param = Simple_name + { sn_name = name ; + sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ; + sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ; + } + in + (new_param, Simple_rhs body2) + | _ -> + (parameter, Simple_rhs body) + ) + ) + | _ -> + (* no *opt* parameter, we add the parameter then continue *) + (parameter, Simple_rhs body) in current_param :: (tt_analyse_method_expression env current_method_name comment_opt ~first: false next_exp) ) @@ -491,6 +499,9 @@ module Analyser = | _ -> (* no more parameter *) [] + + let tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp = + tt_analyse_method_expression env current_method_name comment_opt ~first (Simple_rhs exp) (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple (inherited classes, class elements). *) diff --git a/ocaml/testsuite/tests/pattern-guards/test.ml b/ocaml/testsuite/tests/pattern-guards/test.ml index 279a94e7426..e320e9d3db2 100644 --- a/ocaml/testsuite/tests/pattern-guards/test.ml +++ b/ocaml/testsuite/tests/pattern-guards/test.ml @@ -509,52 +509,36 @@ let collatz = function ;; [%%expect{| ->> Fatal error: typechecking for multicase pattern guards unimplemented -Uncaught exception: Misc.Fatal_error - +val nested_singleway : + ('a -> 'b option) -> + ('b -> 'c option) -> ('c -> 'd option) -> default:'d -> 'a option -> 'd = + +val collatz : int -> int option = |}];; nested_singleway collatz collatz collatz ~default:~-1 None;; [%%expect{| -Line 1, characters 0-16: -1 | nested_singleway collatz collatz collatz ~default:~-1 None;; - ^^^^^^^^^^^^^^^^ -Error: Unbound value nested_singleway +- : int = -1 |}];; nested_singleway collatz collatz collatz ~default:~-1 (Some 1);; [%%expect{| -Line 1, characters 0-16: -1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 1);; - ^^^^^^^^^^^^^^^^ -Error: Unbound value nested_singleway +- : int = -1 |}];; nested_singleway collatz collatz collatz ~default:~-1 (Some 2);; [%%expect{| -Line 1, characters 0-16: -1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 2);; - ^^^^^^^^^^^^^^^^ -Error: Unbound value nested_singleway +- : int = -1 |}];; nested_singleway collatz collatz collatz ~default:~-1 (Some 3);; [%%expect{| -Line 1, characters 0-16: -1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 3);; - ^^^^^^^^^^^^^^^^ -Error: Unbound value nested_singleway +- : int = 16 |}];; nested_singleway collatz collatz collatz ~default:~-1 (Some 4);; [%%expect{| -Line 1, characters 0-16: -1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 4);; - ^^^^^^^^^^^^^^^^ -Error: Unbound value nested_singleway +- : int = -1 |}];; nested_singleway collatz collatz collatz ~default:~-1 (Some 8);; [%%expect{| -Line 1, characters 0-16: -1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 8);; - ^^^^^^^^^^^^^^^^ -Error: Unbound value nested_singleway +- : int = 1 |}];; let find_multiway ~eq ~flag ~finish ~default = function @@ -565,9 +549,9 @@ let find_multiway ~eq ~flag ~finish ~default = function | _ -> default ;; [%%expect{| ->> Fatal error: typechecking for multicase pattern guards unimplemented -Uncaught exception: Misc.Fatal_error - +val find_multiway : + eq:('a -> 'a -> bool) -> + flag:'a -> finish:('a -> 'b) -> default:'b -> 'a list -> 'b = |}];; let eq n m = (n - m) mod 100 = 0;; @@ -583,31 +567,19 @@ val default : string = "No match found" find_multiway ~eq ~flag ~finish ~default [ 10; 20; 110; 100 ];; [%%expect{| -Line 1, characters 0-13: -1 | find_multiway ~eq ~flag ~finish ~default [ 10; 20; 110; 100 ];; - ^^^^^^^^^^^^^ -Error: Unbound value find_multiway +- : string = "110" |}];; find_multiway ~eq ~flag ~finish ~default [ 10; 20; 100; 110 ];; [%%expect{| -Line 1, characters 0-13: -1 | find_multiway ~eq ~flag ~finish ~default [ 10; 20; 100; 110 ];; - ^^^^^^^^^^^^^ -Error: Unbound value find_multiway +- : string = "0" |}];; find_multiway ~eq ~flag ~finish ~default [ 10; 20; 30; 40 ];; [%%expect{| -Line 1, characters 0-13: -1 | find_multiway ~eq ~flag ~finish ~default [ 10; 20; 30; 40 ];; - ^^^^^^^^^^^^^ -Error: Unbound value find_multiway +- : string = "No match found" |}];; find_multiway ~eq ~flag ~finish ~default [ 0; 100 ];; [%%expect{| -Line 1, characters 0-13: -1 | find_multiway ~eq ~flag ~finish ~default [ 0; 100 ];; - ^^^^^^^^^^^^^ -Error: Unbound value find_multiway +- : string = "0" |}];; let nested_multiway f g h = function @@ -621,9 +593,9 @@ let nested_multiway f g h = function | _ -> "not found" ;; [%%expect{| ->> Fatal error: typechecking for multicase pattern guards unimplemented -Uncaught exception: Misc.Fatal_error - +val nested_multiway : + ('a -> string) -> + ('a -> string list) -> ('a -> bool) -> 'a option -> string = |}];; let f = function @@ -647,45 +619,27 @@ val h : int -> bool = nested_multiway f g h None;; [%%expect{| -Line 1, characters 0-15: -1 | nested_multiway f g h None;; - ^^^^^^^^^^^^^^^ -Error: Unbound value nested_multiway +- : string = "not found" |}];; nested_multiway f g h (Some 0);; [%%expect{| -Line 1, characters 0-15: -1 | nested_multiway f g h (Some 0);; - ^^^^^^^^^^^^^^^ -Error: Unbound value nested_multiway +- : string = "not found" |}];; nested_multiway f g h (Some 1);; [%%expect{| -Line 1, characters 0-15: -1 | nested_multiway f g h (Some 1);; - ^^^^^^^^^^^^^^^ -Error: Unbound value nested_multiway +- : string = "foo1" |}];; nested_multiway f g h (Some 10);; [%%expect{| -Line 1, characters 0-15: -1 | nested_multiway f g h (Some 10);; - ^^^^^^^^^^^^^^^ -Error: Unbound value nested_multiway +- : string = "bar empty" |}];; nested_multiway f g h (Some 100);; [%%expect{| -Line 1, characters 0-15: -1 | nested_multiway f g h (Some 100);; - ^^^^^^^^^^^^^^^ -Error: Unbound value nested_multiway +- : string = "bar singleton one" |}];; nested_multiway f g h (Some 1000);; [%%expect{| -Line 1, characters 0-15: -1 | nested_multiway f g h (Some 1000);; - ^^^^^^^^^^^^^^^ -Error: Unbound value nested_multiway +- : string = "not found" |}];; (* Checks that optional arguments with defaults are correclty bound in the diff --git a/ocaml/typing/cmt2annot.ml b/ocaml/typing/cmt2annot.ml index ab55f128a4a..00048757067 100644 --- a/ocaml/typing/cmt2annot.ml +++ b/ocaml/typing/cmt2annot.ml @@ -43,20 +43,13 @@ let bind_bindings scope bindings = let bind_cases l = List.iter - (fun {c_lhs; c_guard; c_rhs} -> + (fun {c_lhs; c_rhs} -> let loc = - let open Location in - match c_guard with - | None -> c_rhs.exp_loc - | Some g -> - let gexp = - match g with - | Predicate pred -> pred - | Pattern { pg_scrutinee; pg_pattern; _ } -> - bind_variables c_rhs.exp_loc pg_pattern; - pg_scrutinee - in - {c_rhs.exp_loc with loc_start=gexp.exp_loc.loc_start} + match c_rhs with + | Simple_rhs rhs -> rhs.exp_loc + | Boolean_guarded_rhs { bg_guard; bg_rhs } -> + { bg_rhs.exp_loc with loc_start = bg_guard.exp_loc.loc_start } + | Pattern_guarded_rhs { pg_loc; _ } -> pg_loc in bind_variables loc c_lhs ) diff --git a/ocaml/typing/parmatch.ml b/ocaml/typing/parmatch.ml index 9edc4427914..a1347d8fdaa 100644 --- a/ocaml/typing/parmatch.ml +++ b/ocaml/typing/parmatch.ml @@ -1841,8 +1841,9 @@ let pressure_variants_in_computation_pattern tdefs patl = let rec initial_matrix = function [] -> [] - | {c_guard=Some _} :: rem -> initial_matrix rem - | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem + | { c_rhs = Simple_rhs _; c_lhs = p } :: rem -> [p] :: initial_matrix rem + | { c_rhs = Boolean_guarded_rhs _ | Pattern_guarded_rhs _; _ } :: rem -> + initial_matrix rem (* Build up a working pattern matrix by keeping @@ -1850,10 +1851,10 @@ let rec initial_matrix = function *) let rec initial_only_guarded = function | [] -> [] - | { c_guard = None; _} :: rem -> + | { c_rhs = Simple_rhs _; _ } :: rem -> initial_only_guarded rem - | { c_lhs = pat; _ } :: rem -> - [pat] :: initial_only_guarded rem + | { c_lhs = pat; c_rhs = Boolean_guarded_rhs _ | Pattern_guarded_rhs _ } + :: rem -> [pat] :: initial_only_guarded rem (************************) @@ -2101,11 +2102,15 @@ let do_check_fragile loc casel pss = (********************************) let check_unused pred casel = + let refute = function + | Simple_rhs { exp_desc = Texp_unreachable; _ } -> true + | Simple_rhs _ | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> false + in if Warnings.is_active Warnings.Redundant_case - || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then + || List.exists (fun case -> refute case.c_rhs) casel then let rec do_rec pref = function | [] -> () - | {c_lhs=q; c_guard; c_rhs} :: rem -> + | {c_lhs=q; c_rhs} :: rem -> let qs = [q] in begin try let pss = @@ -2116,7 +2121,7 @@ let check_unused pred casel = |> get_mins le_pats in (* First look for redundant or partially redundant patterns *) let r = every_satisfiables (make_rows pss) (make_row qs) in - let refute = (c_rhs.exp_desc = Texp_unreachable) in + let refute = refute c_rhs in (* Do not warn for unused [pat -> .] *) if r = Unused && refute then () else let r = @@ -2163,11 +2168,10 @@ let check_unused pred casel = with Empty | Not_found -> assert false end ; - if c_guard <> None then - do_rec pref rem - else - do_rec ([q]::pref) rem in - + match c_rhs with + | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> do_rec pref rem + | Simple_rhs _ -> do_rec ([q]::pref) rem + in do_rec [] casel (*********************************) @@ -2442,15 +2446,9 @@ let pattern_stable_vars ns p = (List.fold_left (fun m n -> Negative n :: m) [Positive {varsets = []; row = [p]}] ns) -(* All identifier paths that appear in an expression that occurs - as a clause right hand side or guard. -*) +(* All identifier paths that appear in a case rhs's guard. *) -let all_rhs_idents guard = - let exp = match guard with - | Predicate p -> p - | Pattern { pg_scrutinee; _ } -> pg_scrutinee - in +let all_guard_idents c_rhs = let ids = ref Ident.Set.empty in let open Tast_iterator in let expr_iter iter exp = @@ -2461,7 +2459,14 @@ let all_rhs_idents guard = | _ -> Tast_iterator.default_iterator.expr iter exp in let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in - iterator.expr iterator exp; + let rec rhs_iter = function + | Simple_rhs _ -> () + | Boolean_guarded_rhs { bg_guard; _ } -> iterator.expr iterator bg_guard + | Pattern_guarded_rhs { pg_scrutinee; pg_cases; _ } -> + iterator.expr iterator pg_scrutinee; + List.iter (fun case -> rhs_iter case.c_rhs) pg_cases + in + rhs_iter c_rhs; !ids let check_ambiguous_bindings = @@ -2470,10 +2475,13 @@ let check_ambiguous_bindings = fun cases -> if is_active warn0 then let check_case ns case = match case with - | { c_lhs = p; c_guard=None ; _} -> [p]::ns - | { c_lhs=p; c_guard=Some g; _} -> + | { c_lhs = p; c_rhs = Simple_rhs _ } -> [p]::ns + | { c_lhs = p + ; c_rhs = Boolean_guarded_rhs _ | Pattern_guarded_rhs _ as c_rhs + ; _ + } -> let all = - Ident.Set.inter (pattern_vars p) (all_rhs_idents g) in + Ident.Set.inter (pattern_vars p) (all_guard_idents c_rhs) in if not (Ident.Set.is_empty all) then begin match pattern_stable_vars ns p with | All -> () diff --git a/ocaml/typing/printtyped.ml b/ocaml/typing/printtyped.ml index b881f455993..dbdd1962157 100644 --- a/ocaml/typing/printtyped.ml +++ b/ocaml/typing/printtyped.ml @@ -1032,21 +1032,23 @@ and comprehension_iterator i ppf = function and case : type k . _ -> _ -> k case -> unit - = fun i ppf {c_lhs; c_guard; c_rhs} -> + = fun i ppf {c_lhs; c_rhs} -> line i ppf "\n"; pattern (i+1) ppf c_lhs; - begin match c_guard with - | None -> () - | Some g -> line (i+1) ppf "\n"; guard (i + 2) ppf g - end; - expression (i+1) ppf c_rhs; - -and guard i ppf = function - | Predicate p -> expression i ppf p - | Pattern { pg_scrutinee = e; pg_scrutinee_sort = s; pg_pattern = pat; _ } -> - expression i ppf e; - line i ppf "%a " Layouts.Sort.format s; - pattern i ppf pat + case_rhs (i+1) ppf c_rhs; + +and case_rhs i ppf = function + | Simple_rhs rhs -> expression i ppf rhs + | Boolean_guarded_rhs { bg_guard; bg_rhs } -> + line i ppf "\n"; + expression (i + 1) ppf bg_guard; + expression i ppf bg_rhs + | Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort; pg_cases } -> + line i ppf "\n"; + expression (i + 1) ppf pg_scrutinee; + line (i + 1) ppf "%a\n" Layouts.Sort.format pg_scrutinee_sort; + line i ppf "\n"; + list i case ppf pg_cases and value_binding i ppf x = line i ppf "\n"; diff --git a/ocaml/typing/rec_check.ml b/ocaml/typing/rec_check.ml index 93baec30351..7056ad65917 100644 --- a/ocaml/typing/rec_check.ml +++ b/ocaml/typing/rec_check.ml @@ -1189,22 +1189,22 @@ and value_bindings : rec_flag -> Typedtree.value_binding list -> bind_judg = *) and case : 'k . 'k Typedtree.case -> mode -> Env.t * mode - = fun { Typedtree.c_lhs; c_guard; c_rhs } -> - let judg = match c_guard with + = fun { Typedtree.c_lhs; c_rhs } -> + let judg = match c_rhs with (* p : mp -| G G |- e : m ---------------------------- G - p; m[mp] |- (p -> e) : m *) - | None -> expression c_rhs + | Simple_rhs rhs -> expression rhs (* Ge |- e : m Gg |- g : m[Dereference] G := Ge+Gg p : mp -| G --------------------------------------- G - p; m[mp] |- (p when g -> e) : m *) - | Some (Predicate p) -> - join [ expression p << Dereference; expression c_rhs ] + | Boolean_guarded_rhs { bg_guard; bg_rhs } -> + join [ expression bg_guard << Dereference; expression bg_rhs ] (* G |- (match e1 with p2 -> e2) : m p1 : mp -| G @@ -1214,9 +1214,8 @@ and case This judgement uses uses the one in [match_expression] as a "subroutine." *) - | Some (Pattern { pg_scrutinee = e; pg_pattern = pat; _ }) -> - let cases = [ { c_lhs = pat; c_guard = None; c_rhs } ] in - match_expression e cases + | Pattern_guarded_rhs { pg_scrutinee; pg_cases; _ } -> + match_expression pg_scrutinee pg_cases in (fun m -> let env = judg m in diff --git a/ocaml/typing/tast_iterator.ml b/ocaml/typing/tast_iterator.ml index 6baee71ad68..1b04a0e98c1 100644 --- a/ocaml/typing/tast_iterator.ml +++ b/ocaml/typing/tast_iterator.ml @@ -20,6 +20,7 @@ type iterator = { binding_op: iterator -> binding_op -> unit; case: 'k . iterator -> 'k case -> unit; + case_rhs: iterator -> case_rhs -> unit; class_declaration: iterator -> class_declaration -> unit; class_description: iterator -> class_description -> unit; class_expr: iterator -> class_expr -> unit; @@ -32,7 +33,6 @@ type iterator = env: iterator -> Env.t -> unit; expr: iterator -> expression -> unit; extension_constructor: iterator -> extension_constructor -> unit; - guard: iterator -> guard -> unit; module_binding: iterator -> module_binding -> unit; module_coercion: iterator -> module_coercion -> unit; module_declaration: iterator -> module_declaration -> unit; @@ -502,17 +502,20 @@ let class_field sub {cf_desc; _} = match cf_desc with let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list -let case sub {c_lhs; c_guard; c_rhs} = +let case sub {c_lhs; c_rhs} = sub.pat sub c_lhs; - Option.iter (sub.guard sub) c_guard; - sub.expr sub c_rhs - -let guard sub = function - | Predicate p -> sub.expr sub p - | Pattern { pg_scrutinee = e; pg_scrutinee_sort = _; pg_pattern = pat; - pg_partial = _; pg_env = _; pg_loc = _; } -> - sub.expr sub e; - sub.pat sub pat + sub.case_rhs sub c_rhs + +let case_rhs sub = function + | Simple_rhs e -> sub.expr sub e + | Boolean_guarded_rhs { bg_guard; bg_rhs } -> + sub.expr sub bg_guard; + sub.expr sub bg_rhs + | Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort=_; pg_cases; + pg_partial=_; pg_loc=_; pg_env } -> + sub.env sub pg_env; + sub.expr sub pg_scrutinee; + List.iter (sub.case sub) pg_cases let value_binding sub {vb_pat; vb_expr; _} = sub.pat sub vb_pat; @@ -524,6 +527,7 @@ let default_iterator = { binding_op; case; + case_rhs; class_declaration; class_description; class_expr; @@ -535,7 +539,6 @@ let default_iterator = class_type_field; env; expr; - guard; extension_constructor; module_binding; module_coercion; diff --git a/ocaml/typing/tast_iterator.mli b/ocaml/typing/tast_iterator.mli index 3a863521602..4b06be442fa 100644 --- a/ocaml/typing/tast_iterator.mli +++ b/ocaml/typing/tast_iterator.mli @@ -24,6 +24,7 @@ type iterator = { binding_op: iterator -> binding_op -> unit; case: 'k . iterator -> 'k case -> unit; + case_rhs: iterator -> case_rhs -> unit; class_declaration: iterator -> class_declaration -> unit; class_description: iterator -> class_description -> unit; class_expr: iterator -> class_expr -> unit; @@ -36,7 +37,6 @@ type iterator = env: iterator -> Env.t -> unit; expr: iterator -> expression -> unit; extension_constructor: iterator -> extension_constructor -> unit; - guard: iterator -> guard -> unit; module_binding: iterator -> module_binding -> unit; module_coercion: iterator -> module_coercion -> unit; module_declaration: iterator -> module_declaration -> unit; diff --git a/ocaml/typing/tast_mapper.ml b/ocaml/typing/tast_mapper.ml index b1adbcbba8c..e887414919e 100644 --- a/ocaml/typing/tast_mapper.ml +++ b/ocaml/typing/tast_mapper.ml @@ -23,6 +23,7 @@ type mapper = { binding_op: mapper -> binding_op -> binding_op; case: 'k . mapper -> 'k case -> 'k case; + case_rhs: mapper -> case_rhs -> case_rhs; class_declaration: mapper -> class_declaration -> class_declaration; class_description: mapper -> class_description -> class_description; class_expr: mapper -> class_expr -> class_expr; @@ -37,7 +38,6 @@ type mapper = expr: mapper -> expression -> expression; extension_constructor: mapper -> extension_constructor -> extension_constructor; - guard: mapper -> guard -> guard; module_binding: mapper -> module_binding -> module_binding; module_coercion: mapper -> module_coercion -> module_coercion; module_declaration: mapper -> module_declaration -> module_declaration; @@ -766,24 +766,28 @@ let value_bindings sub (rec_flag, list) = let case : type k . mapper -> k case -> k case - = fun sub {c_lhs; c_guard; c_rhs} -> + = fun sub {c_lhs; c_rhs} -> { c_lhs = sub.pat sub c_lhs; - c_guard = Option.map (sub.guard sub) c_guard; - c_rhs = sub.expr sub c_rhs; + c_rhs = sub.case_rhs sub c_rhs; } -let guard sub = function - | Predicate p -> Predicate (sub.expr sub p) - | Pattern { pg_scrutinee; pg_scrutinee_sort; pg_pattern; pg_partial; pg_env; - pg_loc; } -> - Pattern +let case_rhs sub = function + | Simple_rhs e -> Simple_rhs (sub.expr sub e) + | Boolean_guarded_rhs { bg_guard; bg_rhs } -> + Boolean_guarded_rhs + { bg_guard = sub.expr sub bg_guard; bg_rhs = sub.expr sub bg_rhs } + | Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort; pg_cases; pg_partial; + pg_loc; pg_env; pg_type } -> + Pattern_guarded_rhs { pg_scrutinee = sub.expr sub pg_scrutinee ; pg_scrutinee_sort - ; pg_pattern = sub.pat sub pg_pattern + ; pg_cases = List.map (sub.case sub) pg_cases ; pg_partial - ; pg_env - ; pg_loc } + ; pg_loc + ; pg_env = sub.env sub pg_env + ; pg_type + } let value_binding sub x = let vb_pat = sub.pat sub x.vb_pat in @@ -796,6 +800,7 @@ let default = { binding_op; case; + case_rhs; class_declaration; class_description; class_expr; @@ -807,7 +812,6 @@ let default = class_type_field; env; expr; - guard; extension_constructor; module_binding; module_coercion; diff --git a/ocaml/typing/tast_mapper.mli b/ocaml/typing/tast_mapper.mli index 41857c4f1bd..bc099b5ee24 100644 --- a/ocaml/typing/tast_mapper.mli +++ b/ocaml/typing/tast_mapper.mli @@ -22,6 +22,7 @@ type mapper = { binding_op: mapper -> binding_op -> binding_op; case: 'k . mapper -> 'k case -> 'k case; + case_rhs: mapper -> case_rhs -> case_rhs; class_declaration: mapper -> class_declaration -> class_declaration; class_description: mapper -> class_description -> class_description; class_expr: mapper -> class_expr -> class_expr; @@ -36,7 +37,6 @@ type mapper = expr: mapper -> expression -> expression; extension_constructor: mapper -> extension_constructor -> extension_constructor; - guard: mapper -> guard -> guard; module_binding: mapper -> module_binding -> module_binding; module_coercion: mapper -> module_coercion -> module_coercion; module_declaration: mapper -> module_declaration -> module_declaration; diff --git a/ocaml/typing/typeclass.ml b/ocaml/typing/typeclass.ml index e377b1b49d0..4965b4ca7ac 100644 --- a/ocaml/typing/typeclass.ml +++ b/ocaml/typing/typeclass.ml @@ -1225,7 +1225,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let partial = let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in Typecore.check_partial ~warn_if:Partial val_env pat.pat_type pat.pat_loc - [{c_lhs = pat; c_guard = None; c_rhs = dummy}] + [{c_lhs = pat; c_rhs = Simple_rhs dummy}] in let val_env' = Env.add_lock Alloc_mode.global val_env' in Ctype.raise_nongen_level (); diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 288b5ca0de2..f831844da8a 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -281,7 +281,7 @@ let check_probe_name name loc env = let mk_expected ?explanation ty = { ty; explanation; } let case lhs rhs = - {c_lhs = lhs; c_guard = None; c_rhs = rhs} + {c_lhs = lhs; c_rhs = Simple_rhs rhs} type position_in_function = FTail | FNontail @@ -1441,12 +1441,12 @@ let split_cases env cases = | None -> lst | Some c_lhs -> { case with c_lhs } :: lst in - List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) -> - match split_pattern c_lhs with - | Some _, Some _ when c_guard <> None -> + List.fold_right (fun ({ c_lhs; c_rhs } as case) (vals, exns) -> + match split_pattern c_lhs, c_rhs with + | (Some _, Some _), (Boolean_guarded_rhs _ | Pattern_guarded_rhs _) -> raise (Error (c_lhs.pat_loc, env, Mixed_value_and_exception_patterns_under_guard)) - | vp, ep -> add_case vals case vp, add_case exns case ep + | (vp, ep), _ -> add_case vals case vp, add_case exns case ep ) cases ([], []) (* When typing a for-loop index or similar, we need to restrict ourselves to the @@ -2998,12 +2998,19 @@ let rec final_subexpression exp = | Texp_sequence (_, _, e) | Texp_try (e, _) | Texp_ifthenelse (_, e, _) - | Texp_match (_, _, {c_rhs=e} :: _, _) | Texp_letmodule (_, _, _, _, e) | Texp_letexception (_, e) | Texp_open (_, e) -> final_subexpression e + | Texp_match (_, _, case::_, _) -> final_case case | _ -> exp +and final_case case = + match case.c_rhs with + | Simple_rhs e | Boolean_guarded_rhs { bg_rhs = e; _ } -> + final_subexpression e + | Pattern_guarded_rhs { pg_cases = case :: _; _ } -> final_case case + | Pattern_guarded_rhs { pg_cases = [] } -> + Misc.fatal_error "Typecore.final_case: empty cases in pattern guard" let is_prim ~name funct = match funct.exp_desc with @@ -3363,19 +3370,19 @@ let rec is_nonexpansive exp = | Tpat_exception _ -> true | _ -> false } pat in - is_nonexpansive e && - List.for_all - (fun {c_lhs; c_guard; c_rhs} -> - let is_guard_nonexpansive = match c_guard with - | None -> true - | Some (Typedtree.Predicate p) -> is_nonexpansive p - | Some (Typedtree.Pattern { pg_scrutinee; pg_pattern; _ }) -> - is_nonexpansive pg_scrutinee - && not (contains_exception_pat pg_pattern) - in - is_guard_nonexpansive && is_nonexpansive c_rhs - && not (contains_exception_pat c_lhs) - ) cases + let rec is_rhs_nonexpansive = function + | Simple_rhs rhs -> is_nonexpansive rhs + | Boolean_guarded_rhs { bg_guard; bg_rhs } -> + is_nonexpansive bg_guard && is_nonexpansive bg_rhs + | Pattern_guarded_rhs { pg_scrutinee; pg_cases } -> + is_nonexpansive pg_scrutinee && are_cases_nonexpansive pg_cases + and are_cases_nonexpansive cases = + List.for_all + (fun {c_lhs; c_rhs} -> + not (contains_exception_pat c_lhs) && is_rhs_nonexpansive c_rhs) + cases + in + is_nonexpansive e && are_cases_nonexpansive cases | Texp_probe {handler} -> is_nonexpansive handler | Texp_tuple (el, _) -> List.for_all is_nonexpansive el @@ -3936,10 +3943,9 @@ let check_partial_application ~statement exp = | Texp_probe _ | Texp_probe_is_enabled _ | Texp_function _ -> check_statement () - | Texp_match (_, _, cases, _) -> - List.iter (fun {c_rhs; _} -> check c_rhs) cases + | Texp_match (_, _, cases, _) -> check_cases cases | Texp_try (e, cases) -> - check e; List.iter (fun {c_rhs; _} -> check c_rhs) cases + check e; check_cases cases | Texp_ifthenelse (_, e1, Some e2) -> check e1; check e2 | Texp_let (_, _, e) | Texp_sequence (_, _, e) | Texp_open (_, e) @@ -3950,6 +3956,14 @@ let check_partial_application ~statement exp = Location.prerr_warning exp_loc Warnings.Ignored_partial_application end + and check_cases : 'k. 'k case list -> unit = fun cases -> + List.iter + (fun { c_rhs; _ } -> + match c_rhs with + | Simple_rhs rhs | Boolean_guarded_rhs { bg_rhs = rhs; _ } -> + check rhs + | Pattern_guarded_rhs { pg_cases; _ } -> check_cases pg_cases) + cases in check exp | _ -> @@ -6979,31 +6993,24 @@ and type_cases (* allow propagation from preceding branches *) correct_levels ty_res else ty_res in - let guard, exp = + let type_rhs rhs = + let rhs = + type_expect ?in_function ext_env emode rhs + (mk_expected ?explanation ty_res') + in + { rhs with exp_type = instance ty_res' } + in + let c_rhs = match pc_rhs with - | Psimple_rhs rhs | Pboolean_guarded_rhs { pbg_rhs = rhs; _ } -> - let guard = - match pc_rhs with - (* This case is unreachable, as [pc_rhs] cannot match the - outer pattern while also matching [Ppattern_guarded_rhs _] - *) - | Ppattern_guarded_rhs _ -> assert false - | Psimple_rhs _ -> None - | Pboolean_guarded_rhs { pbg_guard; _ } -> - let expected_bool = - mk_expected ~explanation:When_guard Predef.type_bool - in - let typed_guard = - type_expect ext_env mode_local pbg_guard expected_bool - in - Some (Predicate typed_guard) - in - let exp = - type_expect ?in_function ext_env emode rhs - (mk_expected ?explanation ty_res') - in - guard, exp - | Ppattern_guarded_rhs { ppg_scrutinee; ppg_cases; ppg_loc = loc } -> + | Psimple_rhs rhs -> Simple_rhs (type_rhs rhs) + | Pboolean_guarded_rhs { pbg_guard; pbg_rhs } -> + let guard = + type_expect ext_env mode_local pbg_guard + (mk_expected ~explanation:When_guard Predef.type_bool) + in + let rhs = type_rhs pbg_rhs in + Boolean_guarded_rhs { bg_guard = guard; bg_rhs = rhs } + | Ppattern_guarded_rhs { ppg_scrutinee; ppg_cases; ppg_loc } -> let { arg; sort; cases; partial; } = type_match (* Pattern guards containing no value cases will have an @@ -7011,37 +7018,36 @@ and type_cases case where no cases match, so we can successfully typecheck such guards. Accordingly, [require_value_case] is set to [false] below. *) - ~require_value_case:false ppg_scrutinee ppg_cases ext_env loc - Check_and_warn_if_total (mk_expected ?explanation ty_res') - emode + ~require_value_case:false ppg_scrutinee ppg_cases ext_env + ppg_loc Check_and_warn_if_total + (mk_expected ?explanation ty_res') emode in - match cases with - | [ { c_lhs = pat; c_guard = None; c_rhs = exp } ] -> - let pattern_guard : Typedtree.guard = - Pattern - { pg_scrutinee = arg - ; pg_scrutinee_sort = sort - ; pg_pattern = pat - ; pg_partial = partial - ; pg_loc = loc - ; pg_env = ext_env } - in - Some pattern_guard, exp - | _ -> - fatal_error - "typechecking for multicase pattern guards unimplemented" + Pattern_guarded_rhs + { pg_scrutinee = arg + ; pg_scrutinee_sort = sort + ; pg_cases = cases + ; pg_partial = partial + ; pg_loc = ppg_loc + ; pg_env = ext_env + ; pg_type = instance ty_res' + } in { c_lhs = pat; - c_guard = guard; - c_rhs = {exp with exp_type = instance ty_res'} + c_rhs } ) half_typed_cases in + let rec iter_rhs ~f = function + | Simple_rhs e | Boolean_guarded_rhs { bg_rhs = e; _ } -> f e + | Pattern_guarded_rhs { pg_cases } -> iter_cases ~f pg_cases + and iter_cases : 'k. f:(expression -> unit) -> 'k case list -> unit = + fun ~f -> List.iter (fun case -> iter_rhs ~f case.c_rhs) + in if !Clflags.principal || does_contain_gadt then begin let ty_res' = instance ty_res in - List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases + iter_cases ~f:(fun e -> unify_exp env e ty_res') cases end; let do_init = may_contain_gadts || needs_exhaust_check in let ty_arg_check = diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index 422592207b5..a0dfbe45aa8 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -217,24 +217,23 @@ and comprehension_iterator = ; sequence : expression } and 'k case = - { - c_lhs: 'k general_pattern; - c_guard: guard option; - c_rhs: expression; - } +{ + c_lhs: 'k general_pattern; + c_rhs: case_rhs; +} -and guard = - | Predicate of expression - | Pattern of pattern_guard - -and pattern_guard = - { pg_scrutinee : expression - ; pg_scrutinee_sort : Layouts.sort - ; pg_pattern : computation general_pattern - ; pg_partial : partial - ; pg_loc : Location.t - ; pg_env : Env.t - } +and case_rhs = + | Simple_rhs of expression + | Boolean_guarded_rhs of { bg_guard : expression; bg_rhs : expression } + | Pattern_guarded_rhs of + { pg_scrutinee : expression + ; pg_scrutinee_sort : Layouts.sort + ; pg_cases : computation case list + ; pg_partial : partial + ; pg_loc : Location.t + ; pg_env : Env.t + ; pg_type : Types.type_expr + } and record_label_definition = | Kept of Types.type_expr @@ -1021,3 +1020,20 @@ let split_pattern pat = combine_opts (into cpat) exns1 exns2 in split_pattern pat + +let exp_of_rhs = function + | Simple_rhs e | Boolean_guarded_rhs { bg_rhs = e; _ } -> e + | Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort; pg_cases; pg_partial; + pg_env; pg_loc; pg_type } -> + { exp_attributes = [] + ; exp_desc = + Texp_match (pg_scrutinee, pg_scrutinee_sort, pg_cases, pg_partial) + ; exp_env = pg_env + ; exp_extra = [] + ; exp_loc = pg_loc + ; exp_type = pg_type + } + +let loc_of_rhs = function + | Simple_rhs e | Boolean_guarded_rhs { bg_rhs = e; _ } -> e.exp_loc + | Pattern_guarded_rhs { pg_loc; _ } -> pg_loc diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index ba3ec75ab79..505ff55e12a 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -398,30 +398,40 @@ and comprehension_iterator = and 'k case = { c_lhs: 'k general_pattern; - c_guard: guard option; - c_rhs: expression; + c_rhs: case_rhs; } -(* CR-soon rgodse: Rename these constructors to [Guard_predicate] and - [Guard_pattern] *) -and guard = - | Predicate of expression - | Pattern of pattern_guard - (* [Pattern (scrutinee, sort, pattern, partial)] represents a pattern guard. - The case will be taken if [scrutinee] evaluates to a value matching - [pattern]. Variables bound by the pattern match are available on the RHS of - the case. Like the [Texp_match] constructor, [sort] is the sort of the - scrutinee, and [partial] denotes whether the case matches the scrutinee - partially or totally. *) - -and pattern_guard = - { pg_scrutinee : expression - ; pg_scrutinee_sort : Layouts.sort - ; pg_pattern : computation general_pattern - ; pg_partial : partial - ; pg_loc : Location.t - ; pg_env : Env.t - } +and case_rhs = + | Simple_rhs of expression + | Boolean_guarded_rhs of { bg_guard : expression; bg_rhs : expression } + | Pattern_guarded_rhs of + { pg_scrutinee : expression + ; pg_scrutinee_sort : Layouts.sort + ; pg_cases : computation case list + ; pg_partial : partial + ; pg_loc : Location.t + ; pg_env : Env.t + ; pg_type : Types.type_expr + } + (* [Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort; pg_cases; + pg_partial; pg_partial; pg_loc; pg_env; pg_type } ] + represents a pattern guard case right-hand side. + + [pg_env] contains the bindings available prior to the evaluation of the + pattern guard scrutinee, as in a match expression. These bindings are + available in all pattern guard cases. + + The cases in [pg_cases] are checked in order: a given case will be taken if + [pg_scrutinee] evaluates to a value matching the pattern of that case. Each + case's rhs has access to the bindings in [pg_env], together with the + bindings in its own pattern. + + Like the [Texp_match] constructor, [pg_scrutinee_sort] is the sort of the + scrutinee, and [pg_partial] denotes whether the case matches the scrutinee + partially or totally. + + [pg_loc] contains the source location of the guarded rhs, and [pg_type] is + the type returned by all cases of the pattern guard. *) and record_label_definition = | Kept of Types.type_expr @@ -990,3 +1000,6 @@ val pat_bound_idents_full: (** Splits an or pattern into its value (left) and exception (right) parts. *) val split_pattern: computation general_pattern -> pattern option * pattern option + +val exp_of_rhs: case_rhs -> expression +val loc_of_rhs: case_rhs -> Location.t diff --git a/ocaml/typing/untypeast.ml b/ocaml/typing/untypeast.ml index 2ef63987127..c7de6ede0e5 100644 --- a/ocaml/typing/untypeast.ml +++ b/ocaml/typing/untypeast.ml @@ -411,23 +411,19 @@ let exp_extra sub (extra, loc, attrs) sexp = Exp.mk ~loc ~attrs desc -let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_guard; c_rhs} -> +let case : type k . mapper -> k case -> _ = fun sub {c_lhs; c_rhs} -> { pc_lhs = sub.pat sub c_lhs; pc_rhs = - match c_guard with - | None -> Psimple_rhs (sub.expr sub c_rhs) - | Some (Predicate cond) -> + match c_rhs with + | Simple_rhs rhs -> Psimple_rhs (sub.expr sub rhs) + | Boolean_guarded_rhs { bg_guard; bg_rhs } -> Pboolean_guarded_rhs - { pbg_guard = sub.expr sub cond; pbg_rhs = sub.expr sub c_rhs } - | Some (Pattern { pg_scrutinee; pg_pattern; pg_loc; _ }) -> + { pbg_guard = sub.expr sub bg_guard; pbg_rhs = sub.expr sub bg_rhs } + | Pattern_guarded_rhs { pg_scrutinee; pg_cases; pg_loc; _ } -> Ppattern_guarded_rhs { ppg_scrutinee = sub.expr sub pg_scrutinee - ; ppg_cases = - [ { pc_lhs = sub.pat sub pg_pattern - ; pc_rhs = Psimple_rhs (sub.expr sub c_rhs) - } - ] + ; ppg_cases = List.map (sub.case sub) pg_cases ; ppg_loc = sub.location sub pg_loc } } @@ -490,7 +486,7 @@ let expression sub exp = (* Pexp_function can't have a label, so we split in 3 cases. *) (* One case, no guard: It's a fun. *) - | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}]; + | Texp_function { arg_label; cases = [{c_lhs=p; c_rhs=(Simple_rhs e)}]; _ } -> Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) (* No label: it's a function. *) @@ -602,7 +598,11 @@ let expression sub exp = in let let_ = sub.binding_op sub let_ pat in let ands = List.map2 (sub.binding_op sub) ands and_pats in - let body = sub.expr sub body.c_rhs in + let body = + match body.c_rhs with + | Simple_rhs rhs -> sub.expr sub rhs + | _ -> Misc.fatal_error "Untypeast.expression: guarded letop body" + in Pexp_letop {let_; ands; body } | Texp_unreachable -> Pexp_unreachable @@ -986,8 +986,11 @@ let class_field sub cf = | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) -> let remove_fun_self = function | { exp_desc = - Texp_function { arg_label = Nolabel; cases = [case]; _ } } - when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs + Texp_function + { arg_label = Nolabel + ; cases = [ { c_lhs; c_rhs = Simple_rhs rhs } ] + ; _ } } + when is_self_pat c_lhs -> rhs | e -> e in let exp = remove_fun_self exp in @@ -995,8 +998,11 @@ let class_field sub cf = | Tcf_initializer exp -> let remove_fun_self = function | { exp_desc = - Texp_function { arg_label = Nolabel; cases = [case]; _ } } - when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs + Texp_function + { arg_label = Nolabel + ; cases = [ { c_lhs; c_rhs = Simple_rhs rhs } ] + ; _ } } + when is_self_pat c_lhs -> rhs | e -> e in let exp = remove_fun_self exp in From 23c4cd94eb1ee58208be3ca42b6ffd6045dc40ae Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Thu, 27 Jul 2023 05:41:11 -0400 Subject: [PATCH 02/15] update jane test output --- ocaml/testsuite/tests/pattern-guards/jane_test.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/ocaml/testsuite/tests/pattern-guards/jane_test.ml b/ocaml/testsuite/tests/pattern-guards/jane_test.ml index bc416f59873..c759ccb158d 100644 --- a/ocaml/testsuite/tests/pattern-guards/jane_test.ml +++ b/ocaml/testsuite/tests/pattern-guards/jane_test.ml @@ -33,7 +33,5 @@ let pattern_guard_doesnt_return_local f x = | _ -> 3 ;; [%%expect{| ->> Fatal error: typechecking for multicase pattern guards unimplemented -Uncaught exception: Misc.Fatal_error - +val pattern_guard_doesnt_return_local : 'a -> 'b option -> int = |}] From be5795810517256a7e1666ce813a6aeda2fc9e58 Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Thu, 27 Jul 2023 06:55:59 -0400 Subject: [PATCH 03/15] self-review: format and style in translcore --- ocaml/lambda/translcore.ml | 47 ++++++++++++++++++++++---------------- ocaml/typing/typedtree.mli | 1 - 2 files changed, 27 insertions(+), 21 deletions(-) diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 812a7ebe2db..363f4ebe053 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -225,20 +225,21 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases [{c_lhs=pat; c_rhs= Simple_rhs - ( { exp_desc = Texp_function { arg_label; param; cases; partial; - region; curry; warnings; arg_mode; - arg_sort; ret_sort; alloc_mode } } as exp - )}] + ({ exp_desc = Texp_function { arg_label; param; cases; partial; + region; curry; warnings; arg_mode; + arg_sort; ret_sort; alloc_mode } } + as exp)}] when bindings = [] || trivial_pat pat -> let cases = push_defaults exp.exp_loc bindings false arg_mode arg_sort cases partial warnings in - [{c_lhs=pat; - c_rhs=Simple_rhs {exp with exp_desc = - Texp_function { arg_label; param; cases; partial; - region; curry; warnings; arg_mode; - arg_sort; ret_sort; alloc_mode }}}] + let exp_desc = + Texp_function + { arg_label; param; cases; partial; region; curry; warnings; arg_mode; + arg_sort; ret_sort; alloc_mode } + in + [ { c_lhs = pat; c_rhs = Simple_rhs { exp with exp_desc } } ] | [{c_lhs=pat; c_rhs= Simple_rhs @@ -255,7 +256,13 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases [{case with c_rhs = Simple_rhs (wrap_bindings bindings exp)}] | {c_lhs=pat; c_rhs=rhs } :: _ when bindings <> [] -> - let exp = exp_of_rhs rhs in + let exp_loc, exp_extra, exp_type, exp_env, exp_attributes = + match rhs with + | Simple_rhs e | Boolean_guarded_rhs { bg_rhs = e; _ } -> + e.exp_loc, e.exp_extra, e.exp_type, e.exp_env, e.exp_attributes + | Pattern_guarded_rhs { pg_loc; pg_env; pg_type; _ } -> + pg_loc, [], pg_type, pg_env, [] + in let mode = Value_mode.of_alloc arg_mode in let param = Typecore.name_cases "param" cases in let desc = @@ -263,17 +270,17 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases val_attributes = []; Types.val_loc = Location.none; val_uid = Types.Uid.internal_not_actually_unique; } in - let env = Env.add_value ~mode param desc exp.exp_env in + let env = Env.add_value ~mode param desc exp_env in let name = Ident.name param in let exp = let cases = let pure_case ({c_lhs; _} as case) = {case with c_lhs = as_computation_pattern c_lhs} in List.map pure_case cases in - { exp with exp_loc = loc; exp_env = env; exp_desc = - Texp_match - ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc = - Texp_ident + { exp_loc = loc; exp_env = env; exp_extra; exp_type; exp_attributes; + exp_desc = Texp_match + ({ exp_type = pat.pat_type; exp_env = env; exp_loc; exp_extra; + exp_attributes; exp_desc = Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), desc, Id_value)}, arg_sort, @@ -1039,16 +1046,16 @@ and transl_list_with_shape ~scopes expr_list = and transl_rhs ~scopes rhs_sort rhs = let layout = layout_rhs rhs_sort rhs in - let transl_unguarded rhs = - event_before ~scopes rhs (transl_exp ~scopes rhs_sort rhs) + let transl_body body = + event_before ~scopes body (transl_exp ~scopes rhs_sort body) in match rhs with - | Simple_rhs rhs -> Matching.mk_unguarded_rhs (transl_unguarded rhs) + | Simple_rhs rhs -> Matching.mk_unguarded_rhs (transl_body rhs) | Boolean_guarded_rhs { bg_guard; bg_rhs } -> let guard = transl_exp ~scopes Sort.for_predef_value bg_guard in - let rhs = event_before ~scopes bg_rhs (transl_unguarded bg_rhs) in + let rhs = event_before ~scopes bg_rhs (transl_body bg_rhs) in let patch_guarded ~patch = - event_before ~scopes bg_guard (Lifthenelse (guard, rhs, patch, layout)) + event_before ~scopes bg_guard (Lifthenelse (guard, body, patch, layout)) in let free_variables = Ident.Set.union (free_variables guard) (free_variables rhs) diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index 505ff55e12a..5ea8365e5da 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -1001,5 +1001,4 @@ val pat_bound_idents_full: val split_pattern: computation general_pattern -> pattern option * pattern option -val exp_of_rhs: case_rhs -> expression val loc_of_rhs: case_rhs -> Location.t From 294a52a88b9509b402b7f80faaf32e65d1ab0d3e Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Thu, 27 Jul 2023 07:01:25 -0400 Subject: [PATCH 04/15] more translcore/typedtree cleanup --- ocaml/lambda/translcore.ml | 6 +++++- ocaml/typing/typedtree.ml | 17 ----------------- ocaml/typing/typedtree.mli | 2 -- 3 files changed, 5 insertions(+), 20 deletions(-) diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 363f4ebe053..8de7a785225 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -1797,7 +1797,11 @@ and transl_letop ~scopes loc env let_ ands param param_sort case case_sort in let return_layout = layout_rhs case_sort case.c_rhs in let curry = More_args { partial_mode = Alloc_mode.global } in - let rhs_loc = loc_of_rhs case.c_rhs in + let rhs_loc = + match case.c_rhs with + | Simple_rhs e | Boolean_guarded_rhs { bg_rhs = e; _ } -> e.exp_loc + | Pattern_guarded_rhs { pg_loc; _ } -> pg_loc + in let (kind, params, return, _region), body = event_function_rhs ~scopes case.c_rhs (function repr -> diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index a0dfbe45aa8..7a9f99d1fb1 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -1020,20 +1020,3 @@ let split_pattern pat = combine_opts (into cpat) exns1 exns2 in split_pattern pat - -let exp_of_rhs = function - | Simple_rhs e | Boolean_guarded_rhs { bg_rhs = e; _ } -> e - | Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort; pg_cases; pg_partial; - pg_env; pg_loc; pg_type } -> - { exp_attributes = [] - ; exp_desc = - Texp_match (pg_scrutinee, pg_scrutinee_sort, pg_cases, pg_partial) - ; exp_env = pg_env - ; exp_extra = [] - ; exp_loc = pg_loc - ; exp_type = pg_type - } - -let loc_of_rhs = function - | Simple_rhs e | Boolean_guarded_rhs { bg_rhs = e; _ } -> e.exp_loc - | Pattern_guarded_rhs { pg_loc; _ } -> pg_loc diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index 5ea8365e5da..ad4de5aee09 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -1000,5 +1000,3 @@ val pat_bound_idents_full: (** Splits an or pattern into its value (left) and exception (right) parts. *) val split_pattern: computation general_pattern -> pattern option * pattern option - -val loc_of_rhs: case_rhs -> Location.t From 1bb15506c7ad3d87e5021f4315343b4f759c6e35 Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Thu, 27 Jul 2023 08:20:35 -0400 Subject: [PATCH 05/15] expose value `is_guarded_rhs` --- ocaml/typing/parmatch.ml | 7 ++++--- ocaml/typing/typecore.ml | 6 +++--- ocaml/typing/typedtree.ml | 4 ++++ ocaml/typing/typedtree.mli | 2 ++ 4 files changed, 13 insertions(+), 6 deletions(-) diff --git a/ocaml/typing/parmatch.ml b/ocaml/typing/parmatch.ml index a1347d8fdaa..786f8064ffd 100644 --- a/ocaml/typing/parmatch.ml +++ b/ocaml/typing/parmatch.ml @@ -2168,9 +2168,10 @@ let check_unused pred casel = with Empty | Not_found -> assert false end ; - match c_rhs with - | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> do_rec pref rem - | Simple_rhs _ -> do_rec ([q]::pref) rem + if is_guarded_rhs c_rhs then + do_rec pref rem + else + do_rec ([q]::pref) rem in do_rec [] casel diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index f831844da8a..e1c0bfdc762 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -1442,11 +1442,11 @@ let split_cases env cases = | Some c_lhs -> { case with c_lhs } :: lst in List.fold_right (fun ({ c_lhs; c_rhs } as case) (vals, exns) -> - match split_pattern c_lhs, c_rhs with - | (Some _, Some _), (Boolean_guarded_rhs _ | Pattern_guarded_rhs _) -> + match split_pattern c_lhs with + | Some _, Some _ when is_guarded_rhs c_rhs -> raise (Error (c_lhs.pat_loc, env, Mixed_value_and_exception_patterns_under_guard)) - | (vp, ep), _ -> add_case vals case vp, add_case exns case ep + | vp, ep -> add_case vals case vp, add_case exns case ep ) cases ([], []) (* When typing a for-loop index or similar, we need to restrict ourselves to the diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index 7a9f99d1fb1..6f550979bf7 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -1020,3 +1020,7 @@ let split_pattern pat = combine_opts (into cpat) exns1 exns2 in split_pattern pat + +let is_guarded_rhs = function + | Simple_rhs _ -> false + | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> true diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index ad4de5aee09..d497c200e4e 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -1000,3 +1000,5 @@ val pat_bound_idents_full: (** Splits an or pattern into its value (left) and exception (right) parts. *) val split_pattern: computation general_pattern -> pattern option * pattern option + +val is_guarded_rhs: case_rhs -> bool From f40e26c7f26bc66a635e7fa1e237b78f66da09d5 Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Thu, 27 Jul 2023 08:20:48 -0400 Subject: [PATCH 06/15] fix typedtree printer --- ocaml/typing/printtyped.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ocaml/typing/printtyped.ml b/ocaml/typing/printtyped.ml index dbdd1962157..6ec06a367b2 100644 --- a/ocaml/typing/printtyped.ml +++ b/ocaml/typing/printtyped.ml @@ -1044,11 +1044,10 @@ and case_rhs i ppf = function expression (i + 1) ppf bg_guard; expression i ppf bg_rhs | Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort; pg_cases } -> - line i ppf "\n"; + line i ppf "\n"; expression (i + 1) ppf pg_scrutinee; line (i + 1) ppf "%a\n" Layouts.Sort.format pg_scrutinee_sort; - line i ppf "\n"; - list i case ppf pg_cases + list (i + 1) case ppf pg_cases and value_binding i ppf x = line i ppf "\n"; From ce7cae7408e11b7ceac17c5f8d8999094f8af157 Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Fri, 28 Jul 2023 13:00:00 -0400 Subject: [PATCH 07/15] make discussed changes to ocamldoc --- ocaml/ocamldoc/odoc_ast.ml | 70 +++++++++++++++++--------------------- 1 file changed, 32 insertions(+), 38 deletions(-) diff --git a/ocaml/ocamldoc/odoc_ast.ml b/ocaml/ocamldoc/odoc_ast.ml index e36d37e4926..4465c0d75fe 100644 --- a/ocaml/ocamldoc/odoc_ast.ml +++ b/ocaml/ocamldoc/odoc_ast.ml @@ -302,9 +302,9 @@ module Analyser = that there is a let param_name = ... in ... just right now *) let (p, next_exp) = match func_body with - | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> - parameter, func_body - | Simple_rhs func_body -> + | Pattern_guarded_rhs _ -> parameter, None + | Simple_rhs func_body + | Boolean_guarded_rhs { bg_rhs = func_body; _ } -> match parameter with Simple_name { sn_name = "*opt*" } -> ( @@ -319,18 +319,17 @@ module Analyser = sn_type = Odoc_env.subst_type env exp.exp_type } in - (new_param, Simple_rhs func_body2) + (new_param, Some func_body2) | _ -> - (parameter, Simple_rhs func_body) + (parameter, Some func_body) ) ) | _ -> - parameter, Simple_rhs func_body + parameter, Some func_body in (* continue if the body is still a function *) match next_exp with - Simple_rhs - { exp_desc = Texp_function { cases = pat_exp_list ; _ } } -> + | Some { exp_desc = Texp_function { cases = pat_exp_list ; _ } } -> p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list) | _ -> (* something else ; no more parameter *) @@ -428,8 +427,9 @@ module Analyser = the first time ; in that case we must not keep the first parameter, which is "self-*", the object itself. *) - let rec tt_analyse_method_expression env current_method_name comment_opt ~first = function - | Simple_rhs { exp_desc = Typedtree.Texp_function { cases = pat_exp_list; _ }; _ } -> + let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp = + match exp.Typedtree.exp_desc with + Typedtree.Texp_function { cases = pat_exp_list; _ } -> ( match pat_exp_list with [] -> @@ -450,7 +450,7 @@ module Analyser = in [ new_param ] - | {c_lhs=pattern_param; c_rhs=body} :: [] -> + | {c_lhs=pattern_param; c_rhs=Simple_rhs body | Boolean_guarded_rhs {bg_rhs = body}} :: [] -> (* if this is the first call to the function, this is the first parameter and we skip it *) if not first then ( @@ -464,44 +464,38 @@ module Analyser = (* We look if the name of the parameter we just add is "*opt*", which means that there is a let param_name = ... in ... just right now. *) let (current_param, next_exp) = - match body with - | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> - parameter, body - | Simple_rhs body -> - match parameter with - Simple_name { sn_name = "*opt*"} -> + match parameter with + Simple_name { sn_name = "*opt*"} -> + ( ( - ( - match body.exp_desc with - Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; - vb_expr=exp} :: _, body2) -> - let name = Name.from_ident id in - let new_param = Simple_name - { sn_name = name ; - sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ; - sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ; - } - in - (new_param, Simple_rhs body2) - | _ -> - (parameter, Simple_rhs body) - ) + match body.exp_desc with + Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; + vb_expr=exp} :: _, body2) -> + let name = Name.from_ident id in + let new_param = Simple_name + { sn_name = name ; + sn_text = Odoc_parameter.desc_from_info_opt comment_opt name ; + sn_type = Odoc_env.subst_type env exp.Typedtree.exp_type ; + } + in + (new_param, body2) + | _ -> + (parameter, body) ) - | _ -> - (* no *opt* parameter, we add the parameter then continue *) - (parameter, Simple_rhs body) + ) + | _ -> + (* no *opt* parameter, we add the parameter then continue *) + (parameter, body) in current_param :: (tt_analyse_method_expression env current_method_name comment_opt ~first: false next_exp) ) else tt_analyse_method_expression env current_method_name comment_opt ~first: false body + | {c_rhs=Pattern_guarded_rhs _} :: [] -> [] ) | _ -> (* no more parameter *) [] - - let tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp = - tt_analyse_method_expression env current_method_name comment_opt ~first (Simple_rhs exp) (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple (inherited classes, class elements). *) From 098cbbdc145e33c3f046474291c278fba7aa6474 Mon Sep 17 00:00:00 2001 From: Rajeev Godse <31352765+rajgodse@users.noreply.github.com> Date: Fri, 28 Jul 2023 13:08:56 -0400 Subject: [PATCH 08/15] format: remove unnecessary parens in pattern Co-authored-by: Nick Roberts --- ocaml/typing/untypeast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/typing/untypeast.ml b/ocaml/typing/untypeast.ml index c7de6ede0e5..42245fa30fb 100644 --- a/ocaml/typing/untypeast.ml +++ b/ocaml/typing/untypeast.ml @@ -486,7 +486,7 @@ let expression sub exp = (* Pexp_function can't have a label, so we split in 3 cases. *) (* One case, no guard: It's a fun. *) - | Texp_function { arg_label; cases = [{c_lhs=p; c_rhs=(Simple_rhs e)}]; + | Texp_function { arg_label; cases = [{c_lhs=p; c_rhs=Simple_rhs e}]; _ } -> Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) (* No label: it's a function. *) From dd5b19de5c4f86a3f538a5b55b464812856f2f09 Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Fri, 28 Jul 2023 13:09:53 -0400 Subject: [PATCH 09/15] improve parmatch variable naming --- ocaml/typing/parmatch.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ocaml/typing/parmatch.ml b/ocaml/typing/parmatch.ml index 786f8064ffd..bace829619b 100644 --- a/ocaml/typing/parmatch.ml +++ b/ocaml/typing/parmatch.ml @@ -2102,12 +2102,12 @@ let do_check_fragile loc casel pss = (********************************) let check_unused pred casel = - let refute = function + let is_refutation_case = function | Simple_rhs { exp_desc = Texp_unreachable; _ } -> true | Simple_rhs _ | Boolean_guarded_rhs _ | Pattern_guarded_rhs _ -> false in if Warnings.is_active Warnings.Redundant_case - || List.exists (fun case -> refute case.c_rhs) casel then + || List.exists (fun case -> is_refutation_case case.c_rhs) casel then let rec do_rec pref = function | [] -> () | {c_lhs=q; c_rhs} :: rem -> @@ -2121,7 +2121,7 @@ let check_unused pred casel = |> get_mins le_pats in (* First look for redundant or partially redundant patterns *) let r = every_satisfiables (make_rows pss) (make_row qs) in - let refute = refute c_rhs in + let refute = is_refutation_case c_rhs in (* Do not warn for unused [pat -> .] *) if r = Unused && refute then () else let r = From e1d22b85c9ec01177af8bd3ea3374e710357f33f Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Fri, 28 Jul 2023 13:12:43 -0400 Subject: [PATCH 10/15] explain [exp_attributes] and [exp_extra] weirdness --- ocaml/lambda/translcore.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 8de7a785225..45a15c6da1a 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -277,6 +277,10 @@ let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases let pure_case ({c_lhs; _} as case) = {case with c_lhs = as_computation_pattern c_lhs} in List.map pure_case cases in + (* [exp_attributes] and [exp_extra] are shared by the outer match + expression and its scrutinee. This is a faithful translation of the + earlier code, which we won't interrogate too carefully as it is + deleted as part of syntactic arity changes. *) { exp_loc = loc; exp_env = env; exp_extra; exp_type; exp_attributes; exp_desc = Texp_match ({ exp_type = pat.pat_type; exp_env = env; exp_loc; exp_extra; From 94ae116605824a6cedd7c5212b6b990642679d4b Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Fri, 28 Jul 2023 13:15:00 -0400 Subject: [PATCH 11/15] improve translcore [event_function*] naming --- ocaml/lambda/translcore.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 45a15c6da1a..1d0e17bb79c 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -305,7 +305,7 @@ let event_before ~scopes exp lam = let event_after ~scopes exp lam = Translprim.event_after (of_location ~scopes exp.exp_loc) exp lam -let event_function_impl ~scopes loc env lam = +let event_function ~scopes loc env lam = if !Clflags.debug && not !Clflags.native_code then let repr = Some (ref 0) in let (info, body) = lam repr in @@ -317,15 +317,15 @@ let event_function_impl ~scopes loc env lam = else lam None -let event_function ~scopes exp lam = - event_function_impl ~scopes exp.exp_loc exp.exp_env lam +let event_function_expr ~scopes exp lam = + event_function ~scopes exp.exp_loc exp.exp_env lam let event_function_rhs ~scopes rhs lam = match rhs with | Simple_rhs rhs_exp | Boolean_guarded_rhs { bg_rhs = rhs_exp; _ } -> - event_function ~scopes rhs_exp lam + event_function_expr ~scopes rhs_exp lam | Pattern_guarded_rhs { pg_loc; pg_env; _ } -> - event_function_impl ~scopes pg_loc pg_env lam + event_function ~scopes pg_loc pg_env lam (* Assertions *) @@ -1382,7 +1382,7 @@ and transl_function ~scopes e alloc_mode param arg_mode arg_sort return_sort function_arg_layout e.exp_env e.exp_loc arg_sort e.exp_type in let ((kind, params, return, region), body) = - event_function ~scopes e + event_function_expr ~scopes e (function repr -> let pl = push_defaults e.exp_loc arg_mode arg_sort cases partial warnings From 5e0dd36a2da9c1a49a2bef9fe808d8b3fe60b953 Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Fri, 28 Jul 2023 13:23:07 -0400 Subject: [PATCH 12/15] inlined transl_body in transl_rhs --- ocaml/lambda/translcore.ml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 1d0e17bb79c..1b40488c9ce 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -1050,19 +1050,20 @@ and transl_list_with_shape ~scopes expr_list = and transl_rhs ~scopes rhs_sort rhs = let layout = layout_rhs rhs_sort rhs in - let transl_body body = - event_before ~scopes body (transl_exp ~scopes rhs_sort body) - in match rhs with - | Simple_rhs rhs -> Matching.mk_unguarded_rhs (transl_body rhs) + | Simple_rhs rhs -> + Matching.mk_unguarded_rhs + (event_before ~scopes rhs (transl_exp ~scopes rhs_sort rhs)) | Boolean_guarded_rhs { bg_guard; bg_rhs } -> let guard = transl_exp ~scopes Sort.for_predef_value bg_guard in - let rhs = event_before ~scopes bg_rhs (transl_body bg_rhs) in + let body = + event_before ~scopes bg_rhs (transl_exp ~scopes rhs_sort bg_rhs) + in let patch_guarded ~patch = event_before ~scopes bg_guard (Lifthenelse (guard, body, patch, layout)) in let free_variables = - Ident.Set.union (free_variables guard) (free_variables rhs) + Ident.Set.union (free_variables guard) (free_variables body) in Matching.mk_boolean_guarded_rhs ~patch_guarded ~free_variables | Pattern_guarded_rhs { pg_scrutinee; pg_scrutinee_sort; pg_cases; pg_partial; From 271d61d87e2f8804c4e72c77967480a9c35ac673 Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Fri, 28 Jul 2023 13:25:32 -0400 Subject: [PATCH 13/15] rename pats_exp... to use "rhs" naming --- ocaml/lambda/translcore.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 1b40488c9ce..61f4e3c549f 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -1123,13 +1123,13 @@ and transl_cases_try ~scopes rhs_sort cases = in List.map (transl_case_try ~scopes rhs_sort) cases -and transl_tupled_cases ~scopes rhs_sort patl_expr_list = - let patl_expr_list = - List.filter (fun (_, rhs) -> not (is_rhs_unreachable rhs)) patl_expr_list +and transl_tupled_cases ~scopes rhs_sort patl_rhs_list = + let patl_rhs_list = + List.filter (fun (_, rhs) -> not (is_rhs_unreachable rhs)) patl_rhs_list in List.map (fun (patl, rhs) -> (patl, transl_rhs ~scopes rhs_sort rhs)) - patl_expr_list + patl_rhs_list and transl_apply ~scopes ?(tailcall=Default_tailcall) @@ -1327,7 +1327,7 @@ and transl_tupled_function && List.length pl <= (Lambda.max_arity ()) -> begin try let size = List.length pl in - let pats_expr_list = + let pats_rhs_list = List.map (fun {c_lhs; c_rhs} -> (Matching.flatten_pattern size c_lhs, c_rhs)) @@ -1349,7 +1349,7 @@ and transl_tupled_function let params = List.map fst tparams in let body = Matching.for_tupled_function ~scopes ~return_layout loc params - (transl_tupled_cases ~scopes return_sort pats_expr_list) partial + (transl_tupled_cases ~scopes return_sort pats_rhs_list) partial in let region = region || not (may_allocate_in_region body) in ((Tupled, tparams, return_layout, region), body) From e262902fa0af88237fb6df09a465583a5eb0cef9 Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Fri, 28 Jul 2023 13:36:16 -0400 Subject: [PATCH 14/15] added test for guarded value/exception or-patterns --- ocaml/testsuite/tests/pattern-guards/test.ml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/ocaml/testsuite/tests/pattern-guards/test.ml b/ocaml/testsuite/tests/pattern-guards/test.ml index e320e9d3db2..863c0db09a5 100644 --- a/ocaml/testsuite/tests/pattern-guards/test.ml +++ b/ocaml/testsuite/tests/pattern-guards/test.ml @@ -298,6 +298,19 @@ Line 3, characters 4-32: Error: Mixing value and exception patterns under when-guards is not supported. |}];; +(* Test rejection of pattern guards on mixed exception/value or-patterns *) +let reject_guarded_val_exn_orp k = + match k () with + | Some s | exception Failure s when s match "foo" -> s + | _ -> "Not foo" +;; +[%%expect{| +Line 3, characters 4-32: +3 | | Some s | exception Failure s when s match "foo" -> s + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Mixing value and exception patterns under when-guards is not supported. +|}];; + module M : sig type 'a t From 3f8864d9eacd5238d2cdfc48f1003ffd7f860a2d Mon Sep 17 00:00:00 2001 From: Rajeev Godse Date: Tue, 1 Aug 2023 09:18:54 -0400 Subject: [PATCH 15/15] address ocamldoc CRs --- ocaml/ocamldoc/odoc_ast.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/ocaml/ocamldoc/odoc_ast.ml b/ocaml/ocamldoc/odoc_ast.ml index 4465c0d75fe..5d48a341204 100644 --- a/ocaml/ocamldoc/odoc_ast.ml +++ b/ocaml/ocamldoc/odoc_ast.ml @@ -449,7 +449,7 @@ module Analyser = sn_type = Odoc_env.subst_type env pattern_param.Typedtree.pat_type } in [ new_param ] - + | {c_rhs=Pattern_guarded_rhs _} :: [] -> [] | {c_lhs=pattern_param; c_rhs=Simple_rhs body | Boolean_guarded_rhs {bg_rhs = body}} :: [] -> (* if this is the first call to the function, this is the first parameter and we skip it *) if not first then @@ -467,7 +467,7 @@ module Analyser = match parameter with Simple_name { sn_name = "*opt*"} -> ( - ( + ( match body.exp_desc with Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) }; vb_expr=exp} :: _, body2) -> @@ -481,7 +481,7 @@ module Analyser = (new_param, body2) | _ -> (parameter, body) - ) + ) ) | _ -> (* no *opt* parameter, we add the parameter then continue *) @@ -491,7 +491,6 @@ module Analyser = ) else tt_analyse_method_expression env current_method_name comment_opt ~first: false body - | {c_rhs=Pattern_guarded_rhs _} :: [] -> [] ) | _ -> (* no more parameter *)