From 4ac368a4239ad7d96767e5b96beb3679c06211be Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Wed, 17 Sep 2025 10:29:11 +0200 Subject: [PATCH 1/5] Implement try..finally syntax --- analysis/reanalyze/src/Arnold.ml | 5 +- analysis/reanalyze/src/Exception.ml | 5 +- analysis/reanalyze/src/SideEffects.ml | 6 +- analysis/src/ProcessCmt.ml | 5 +- compiler/core/js_dump.ml | 8 +- compiler/core/lam.ml | 14 +- compiler/core/lam.mli | 4 +- compiler/core/lam_analysis.ml | 11 +- compiler/core/lam_arity_analysis.ml | 7 +- compiler/core/lam_bounded_vars.ml | 7 +- compiler/core/lam_check.ml | 10 +- compiler/core/lam_closure.ml | 5 +- compiler/core/lam_compile.ml | 28 ++-- compiler/core/lam_convert.ml | 21 ++- compiler/core/lam_exit_count.ml | 5 +- compiler/core/lam_free_variables.ml | 7 +- compiler/core/lam_hit.ml | 6 +- compiler/core/lam_iter.ml | 8 +- compiler/core/lam_pass_alpha_conversion.ml | 4 +- compiler/core/lam_pass_collect.ml | 5 +- compiler/core/lam_pass_count.ml | 5 +- compiler/core/lam_pass_deep_flatten.ml | 4 +- compiler/core/lam_pass_eliminate_ref.ml | 6 +- compiler/core/lam_pass_exits.ml | 5 +- compiler/core/lam_pass_lets_dce.ml | 5 +- compiler/core/lam_pass_remove_alias.ml | 4 +- compiler/core/lam_print.ml | 10 +- compiler/core/lam_scc.ml | 3 +- compiler/core/lam_subst.ml | 5 +- compiler/frontend/bs_ast_mapper.ml | 4 +- compiler/ml/ast_helper.ml | 3 +- compiler/ml/ast_helper.mli | 8 +- compiler/ml/ast_iterator.ml | 5 +- compiler/ml/ast_mapper.ml | 4 +- compiler/ml/ast_mapper_from0.ml | 4 +- compiler/ml/ast_mapper_to0.ml | 3 +- compiler/ml/depend.ml | 5 +- compiler/ml/lambda.ml | 15 +- compiler/ml/lambda.mli | 2 +- compiler/ml/parsetree.ml | 4 +- compiler/ml/pprintast.ml | 13 +- compiler/ml/printast.ml | 5 +- compiler/ml/printlambda.ml | 12 +- compiler/ml/printtyped.ml | 5 +- compiler/ml/rec_check.ml | 5 +- compiler/ml/tast_iterator.ml | 5 +- compiler/ml/tast_mapper.ml | 4 +- compiler/ml/translcore.ml | 21 ++- compiler/ml/typecore.ml | 26 +++- compiler/ml/typedtree.ml | 2 +- compiler/ml/typedtree.mli | 4 +- compiler/ml/typedtreeIter.ml | 5 +- compiler/syntax/src/res_ast_debugger.ml | 5 +- compiler/syntax/src/res_comments_table.ml | 44 +++++- compiler/syntax/src/res_core.ml | 52 ++++++- compiler/syntax/src/res_printer.ml | 37 ++++- compiler/syntax/src/res_token.ml | 1 + .../finally_non_unit_type.res.expected | 15 ++ .../fixtures/finally_non_unit_type.res | 9 ++ .../errors/expressions/expected/try.res.txt | 16 +- .../expected/try_finally_errors.res.txt | 71 +++++++++ .../expected/binaryNoEs6Arrow.res.txt | 5 +- .../grammar/expressions/expected/try.res.txt | 56 ++++++- .../expressions/expected/try_finally.res.txt | 147 ++++++++++++++++++ .../data/parsing/grammar/expressions/try.res | 85 +++++++++- .../data/printer/expr/expected/try.res.txt | 138 +++++++++++++++- tests/syntax_tests/data/printer/expr/try.res | 141 ++++++++++++++++- tests/tests/src/try_finally_test.mjs | 129 +++++++++++++++ tests/tests/src/try_finally_test.res | 98 ++++++++++++ 69 files changed, 1264 insertions(+), 167 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/finally_non_unit_type.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/finally_non_unit_type.res create mode 100644 tests/syntax_tests/data/parsing/errors/expressions/expected/try_finally_errors.res.txt create mode 100644 tests/syntax_tests/data/parsing/grammar/expressions/expected/try_finally.res.txt create mode 100644 tests/tests/src/try_finally_test.mjs create mode 100644 tests/tests/src/try_finally_test.res diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index 9eec8d729e..51e9635c8f 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -967,11 +967,12 @@ module Compile = struct | Texp_tuple expressions | Texp_array expressions -> expressions |> List.map (expression ~ctx) |> Command.unorderedSequence | Texp_assert _ -> Command.nothing - | Texp_try (e, cases) -> + | Texp_try (e, cases, finally_expr) -> let cE = e |> expression ~ctx in let cCases = cases |> List.map (case ~ctx) |> Command.nondet in + let cFinally = finally_expr |> expressionOpt ~ctx in let open Command in - cE +++ cCases + cE +++ cCases +++ cFinally | Texp_variant (_label, eOpt) -> eOpt |> expressionOpt ~ctx | Texp_while _ -> notImplemented "Texp_while"; diff --git a/analysis/reanalyze/src/Exception.ml b/analysis/reanalyze/src/Exception.ml index d59516e2dd..ccc1a0ff42 100644 --- a/analysis/reanalyze/src/Exception.ml +++ b/analysis/reanalyze/src/Exception.ml @@ -335,7 +335,7 @@ let traverseAst () = kind = Raises; } :: !currentEvents - | Texp_try (e, cases) -> + | Texp_try (e, cases, finally_expr) -> let exceptions = cases |> List.map (fun case -> case.Typedtree.c_lhs.pat_desc) @@ -346,7 +346,8 @@ let traverseAst () = e |> iterExpr self; currentEvents := {Event.exceptions; loc; kind = Catches !currentEvents} :: oldEvents; - cases |> iterCases self + cases |> iterCases self; + finally_expr |> iterExprOpt self | _ -> super.expr self expr |> ignore); (if isDoesNoRaise then let nestedEvents = !currentEvents in diff --git a/analysis/reanalyze/src/SideEffects.ml b/analysis/reanalyze/src/SideEffects.ml index 5aceaf124d..58a12ee322 100644 --- a/analysis/reanalyze/src/SideEffects.ml +++ b/analysis/reanalyze/src/SideEffects.ml @@ -45,8 +45,10 @@ let rec exprNoSideEffects (expr : Typedtree.expression) = partial = Total && e |> exprNoSideEffects && cases |> List.for_all caseNoSideEffects | Texp_letmodule _ -> false - | Texp_try (e, cases) -> - e |> exprNoSideEffects && cases |> List.for_all caseNoSideEffects + | Texp_try (e, cases, finally_expr) -> + e |> exprNoSideEffects + && cases |> List.for_all caseNoSideEffects + && finally_expr |> exprOptNoSideEffects | Texp_tuple el -> el |> List.for_all exprNoSideEffects | Texp_variant (_lbl, eo) -> eo |> exprOptNoSideEffects | Texp_field (e, _lid, _ld) -> e |> exprNoSideEffects diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml index 96601f6e3b..1dec1aa978 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -700,14 +700,15 @@ and scanLetModules ~env (e : Typedtree.expression) = | Some g -> scanLetModules ~env g | None -> ()); scanLetModules ~env c_rhs - | Texp_try (e, cases) -> + | Texp_try (e, cases, finally_expr) -> scanLetModules ~env e; cases |> List.iter (fun {Typedtree.c_lhs = _; c_guard; c_rhs} -> (match c_guard with | Some g -> scanLetModules ~env g | None -> ()); - scanLetModules ~env c_rhs) + scanLetModules ~env c_rhs); + finally_expr |> Option.iter (scanLetModules ~env) | Texp_ifthenelse (e1, e2, e3Opt) -> ( scanLetModules ~env e1; scanLetModules ~env e2; diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 49ace5fa6c..7eaa149d07 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -1581,10 +1581,10 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt = match fin with | None -> cxt | Some b -> - P.group f 1 (fun _ -> - P.string f L.finally; - P.space f; - brace_block cxt f b)) + P.space f; + P.string f L.finally; + P.space f; + brace_block cxt f b) and function_body ?directive (cxt : cxt) f ~return_unit (b : J.block) : unit = (match directive with diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 51b8bb3e38..7123f911ad 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -101,7 +101,7 @@ module Types = struct | Lstringswitch of t * (string * t) list * t option | Lstaticraise of int * t list | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t + | Ltrywith of t * ident * t option * t option | Lifthenelse of t * t * t | Lsequence of t * t | Lwhile of t * t @@ -153,7 +153,7 @@ module X = struct | Lstringswitch of t * (string * t) list * t option | Lstaticraise of int * t list | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t + | Ltrywith of t * ident * t option * t option | Lifthenelse of t * t * t | Lsequence of t * t | Lwhile of t * t @@ -224,10 +224,11 @@ let inner_map (l : t) (f : t -> X.t) : X.t = let e1 = f e1 in let e2 = f e2 in Lstaticcatch (e1, vars, e2) - | Ltrywith (e1, exn, e2) -> + | Ltrywith (e1, exn, e2, finally_expr) -> let e1 = f e1 in - let e2 = f e2 in - Ltrywith (e1, exn, e2) + let e2 = Ext_option.map e2 f in + let finally_expr = Ext_option.map finally_expr f in + Ltrywith (e1, exn, e2, finally_expr) | Lifthenelse (e1, e2, e3) -> let e1 = f e1 in let e2 = f e2 in @@ -457,7 +458,8 @@ let function_ ~attr ~arity ~params ~body : t = let let_ kind id e body : t = Llet (kind, id, e, body) let letrec bindings body : t = Lletrec (bindings, body) let while_ a b : t = Lwhile (a, b) -let try_ body id handler : t = Ltrywith (body, id, handler) +let try_ body id handler finally_expr : t = + Ltrywith (body, id, handler, finally_expr) let for_ v e1 e2 dir e3 : t = Lfor (v, e1, e2, dir, e3) let assign v l : t = Lassign (v, l) let staticcatch a b c : t = Lstaticcatch (a, b, c) diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 560d247669..825fcb79f0 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -74,7 +74,7 @@ and t = private | Lstringswitch of t * (string * t) list * t option | Lstaticraise of int * t list | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t + | Ltrywith of t * ident * t option * t option | Lifthenelse of t * t * t | Lsequence of t * t | Lwhile of t * t @@ -151,7 +151,7 @@ val seq : t -> t -> t val while_ : t -> t -> t (* val event : t -> Lambda.lambda_event -> t *) -val try_ : t -> ident -> t -> t +val try_ : t -> ident -> t option -> t option -> t val assign : ident -> t -> t diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index a4b78bea0e..ce3ba5b4bc 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -109,8 +109,10 @@ let rec no_side_effects (lam : Lam.t) : bool = for example [String.contains], [Format.make_queue_elem] *) - | Ltrywith (body, _exn, handler) -> - no_side_effects body && no_side_effects handler + | Ltrywith (body, _exn, handler, finally_expr) -> + no_side_effects body + && Option.fold ~none:true ~some:no_side_effects handler + && Option.fold ~none:true ~some:no_side_effects finally_expr | Lifthenelse (a, b, c) -> no_side_effects a && no_side_effects b && no_side_effects c | Lsequence (a, b) -> no_side_effects a && no_side_effects b @@ -174,7 +176,10 @@ let rec size (lam : Lam.t) = | Lstaticraise (_i, ls) -> Ext_list.fold_left ls 1 (fun acc x -> size x + acc) | Lstaticcatch _ -> really_big () - | Ltrywith _ -> really_big () + | Ltrywith (body, _exn, handler, finally_expr) -> + size body + + Option.fold ~none:0 ~some:size handler + + Option.fold ~none:0 ~some:size finally_expr | Lifthenelse (l1, l2, l3) -> 1 + size l1 + size l2 + size l3 | Lsequence (l1, l2) -> size l1 + size l2 | Lwhile _ -> really_big () diff --git a/compiler/core/lam_arity_analysis.ml b/compiler/core/lam_arity_analysis.ml index ee3d91f154..7557fd02be 100644 --- a/compiler/core/lam_arity_analysis.ml +++ b/compiler/core/lam_arity_analysis.ml @@ -125,7 +125,12 @@ let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = | None -> all_lambdas meta (Ext_list.map sw snd) | Some v -> all_lambdas meta (v :: Ext_list.map sw snd)) | Lstaticcatch (_, _, handler) -> get_arity meta handler - | Ltrywith (l1, _, l2) -> all_lambdas meta [l1; l2] + | Ltrywith (l1, _, Some l2, Some finally_expr) -> + all_lambdas meta [l1; l2; finally_expr] + | Ltrywith (l1, _, Some l2, None) -> all_lambdas meta [l1; l2] + | Ltrywith (l1, _, None, Some finally_expr) -> + all_lambdas meta [l1; finally_expr] + | Ltrywith (l1, _, None, None) -> all_lambdas meta [l1] | Lifthenelse (_, l2, l3) -> all_lambdas meta [l2; l3] | Lsequence (_, l2) -> get_arity meta l2 | Lstaticraise _ (* since it will not be in tail position *) -> Lam_arity.na diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index e038e56798..75a83ffd4f 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -136,11 +136,12 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = let l = aux l in Lam.stringswitch l (Ext_list.map_snd sw aux) (option_map d) | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) - | Ltrywith (l1, v, l2) -> + | Ltrywith (l1, v, l2, finally_expr) -> let l1 = aux l1 in let v = rebind v in - let l2 = aux l2 in - Lam.try_ l1 v l2 + let l2 = option_map l2 in + let finally_expr = option_map finally_expr in + Lam.try_ l1 v l2 finally_expr | Lifthenelse (l1, l2, l3) -> let l1 = aux l1 in let l2 = aux l2 in diff --git a/compiler/core/lam_check.ml b/compiler/core/lam_check.ml index 0ef71f2cee..940dcaeb67 100644 --- a/compiler/core/lam_check.ml +++ b/compiler/core/lam_check.ml @@ -81,9 +81,10 @@ let check file lam = | Lstaticcatch (e1, (j, _vars), e2) -> check_staticfails e1 (Set_int.add cxt j); check_staticfails e2 cxt - | Ltrywith (e1, _exn, e2) -> + | Ltrywith (e1, _exn, e2, finally_expr) -> check_staticfails e1 cxt; - check_staticfails e2 cxt + Ext_option.iter e2 (fun expr -> check_staticfails expr cxt); + Ext_option.iter finally_expr (fun expr -> check_staticfails expr cxt) | Lifthenelse (e1, e2, e3) -> check_list [e1; e2; e3] cxt | Lsequence (e1, e2) -> check_list [e1; e2] cxt | Lassign (_id, e) -> check_staticfails e cxt @@ -127,10 +128,11 @@ let check file lam = iter e1; List.iter def vars; iter e2 - | Ltrywith (e1, exn, e2) -> + | Ltrywith (e1, exn, e2, finally_expr) -> iter e1; def exn; - iter e2 + Ext_option.iter e2 iter; + Ext_option.iter finally_expr iter | Lifthenelse (e1, e2, e3) -> iter e1; iter e2; diff --git a/compiler/core/lam_closure.ml b/compiler/core/lam_closure.ml index c02f05b705..41df5a7de1 100644 --- a/compiler/core/lam_closure.ml +++ b/compiler/core/lam_closure.ml @@ -115,9 +115,10 @@ let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) iter sink_pos e1; local_add_list vars; iter sink_pos e2 - | Ltrywith (e1, _exn, e2) -> + | Ltrywith (e1, _exn, e2, finally_expr) -> iter top e1; - iter sink_pos e2 + Ext_option.iter e2 (iter sink_pos); + Ext_option.iter finally_expr (iter sink_pos) | Lifthenelse (e1, e2, e3) -> iter top e1; let top = Lam_var_stats.new_position_after_lam e1 top in diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 739056132b..0125237cca 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -1211,17 +1211,27 @@ let compile output_prefix = } ]} *) - and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) = + and compile_trywith lam id catch finally_expr + (lambda_cxt : Lam_compile_context.t) = let aux (with_context : Lam_compile_context.t) (body_context : Lam_compile_context.t) = (* should_return is passed down #1701, try should prevent tailcall *) - [ - S.try_ - (Js_output.output_as_block (compile_lambda body_context lam)) - ~with_: - (id, Js_output.output_as_block (compile_lambda with_context catch)); - ] + let body = Js_output.output_as_block (compile_lambda body_context lam) in + let with_ = + Ext_option.map catch (fun catch_lam -> + ( id, + Js_output.output_as_block (compile_lambda with_context catch_lam) + )) + in + let finally = + Ext_option.map finally_expr (fun finally_lam -> + let finally_cxt = + {lambda_cxt with continuation = EffectCall Not_tail} + in + Js_output.output_as_block (compile_lambda finally_cxt finally_lam)) + in + [S.try_ body ?with_ ?finally] in match lambda_cxt.continuation with | Declare (kind, id) -> @@ -1825,9 +1835,9 @@ let compile output_prefix = (if direction = Upto then Upto else Downto) body lambda_cxt) | Lassign (id, lambda) -> compile_assign id lambda lambda_cxt - | Ltrywith (lam, id, catch) -> + | Ltrywith (lam, id, catch, finally_expr) -> (* generate documentation *) - compile_trywith lam id catch lambda_cxt + compile_trywith lam id catch finally_expr lambda_cxt in (compile_recursive_lets, compile_lambda) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 2e88a3b703..768b8dffba 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -84,7 +84,8 @@ let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool = | Lvar id -> Ident.same id fv | Lassign (id, e) -> Ident.same id fv || hit e | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 + | Ltrywith (e1, _exn, e2, finally_expr) -> + hit e1 || Ext_option.exists e2 hit || Ext_option.exists finally_expr hit | Lfunction {body; params = _} -> hit body | Llet (_str, _id, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl @@ -491,16 +492,20 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : convert_aux b | Lstaticcatch (b, (i, ids), handler) -> Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler) - | Ltrywith (b, id, handler) -> + | Ltrywith (b, id, handler, finally) -> ( let body = convert_aux b in - let handler = convert_aux handler in - if exception_id_destructed handler id then + let handler = Ext_option.map handler convert_aux in + let converted_finally = Ext_option.map finally convert_aux in + match handler with + | Some handler when exception_id_destructed handler id -> let new_id = Ident.create ("raw_" ^ id.name) in Lam.try_ body new_id - (Lam.let_ StrictOpt id - (prim ~primitive:Pwrap_exn ~args:[Lam.var new_id] Location.none) - handler) - else Lam.try_ body id handler + (Some + (Lam.let_ StrictOpt id + (prim ~primitive:Pwrap_exn ~args:[Lam.var new_id] Location.none) + handler)) + converted_finally + | _ -> Lam.try_ body id handler converted_finally) | Lifthenelse (b, then_, else_) -> Lam.if_ (convert_aux b) (convert_aux then_) (convert_aux else_) | Lsequence (a, b) -> Lam.seq (convert_aux a) (convert_aux b) diff --git a/compiler/core/lam_exit_count.ml b/compiler/core/lam_exit_count.ml index d9535ac2ee..e25d09a188 100644 --- a/compiler/core/lam_exit_count.ml +++ b/compiler/core/lam_exit_count.ml @@ -79,9 +79,10 @@ let count_helper (lam : Lam.t) : collection = count l; Ext_list.iter_snd sw.sw_consts count; Ext_list.iter_snd sw.sw_blocks count - | Ltrywith (l1, _v, l2) -> + | Ltrywith (l1, _v, l2, finally_expr) -> count l1; - count l2 + Ext_option.iter l2 count; + Ext_option.iter finally_expr count | Lifthenelse (l1, l2, l3) -> count l1; count l2; diff --git a/compiler/core/lam_free_variables.ml b/compiler/core/lam_free_variables.ml index 1fdd31f1c6..ccd5e9b3fa 100644 --- a/compiler/core/lam_free_variables.ml +++ b/compiler/core/lam_free_variables.ml @@ -37,10 +37,11 @@ let pass_free_variables (l : Lam.t) : Set_ident.t = free e1; free e2; Ext_list.iter vars (fun id -> fv := Set_ident.remove !fv id) - | Ltrywith (e1, exn, e2) -> + | Ltrywith (e1, exn, e2, finally_expr) -> free e1; - free e2; - fv := Set_ident.remove !fv exn + Ext_option.iter e2 free; + fv := Set_ident.remove !fv exn; + Ext_option.iter finally_expr free | Lfunction {body; params} -> free body; Ext_list.iter params (fun param -> fv := Set_ident.remove !fv param) diff --git a/compiler/core/lam_hit.ml b/compiler/core/lam_hit.ml index dd1c2c9270..6be069f6f8 100644 --- a/compiler/core/lam_hit.ml +++ b/compiler/core/lam_hit.ml @@ -38,7 +38,8 @@ let hit_variables (fv : Set_ident.t) (l : t) : bool = | Lvar id -> hit_var id | Lassign (id, e) -> hit_var id || hit e | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 + | Ltrywith (e1, _exn, e2, finally_expr) -> + hit e1 || Ext_option.exists e2 hit || Ext_option.exists finally_expr hit | Lfunction {body; params = _} -> hit body | Llet (_str, _id, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl @@ -73,7 +74,8 @@ let hit_variable (fv : Ident.t) (l : t) : bool = | Lvar id -> hit_var id | Lassign (id, e) -> hit_var id || hit e | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 + | Ltrywith (e1, _exn, e2, finally_expr) -> + hit e1 || Ext_option.exists e2 hit || Ext_option.exists finally_expr hit | Lfunction {body; params = _} -> hit body | Llet (_str, _id, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl diff --git a/compiler/core/lam_iter.ml b/compiler/core/lam_iter.ml index 94b8729eca..4014c4cec0 100644 --- a/compiler/core/lam_iter.ml +++ b/compiler/core/lam_iter.ml @@ -62,9 +62,10 @@ let inner_iter (l : t) (f : t -> unit) : unit = | Lstaticcatch (e1, _vars, e2) -> f e1; f e2 - | Ltrywith (e1, _exn, e2) -> + | Ltrywith (e1, _exn, e2, finally_expr) -> f e1; - f e2 + Ext_option.iter e2 f; + Ext_option.iter finally_expr f | Lifthenelse (e1, e2, e3) -> f e1; f e2; @@ -107,7 +108,8 @@ let inner_exists (l : t) (f : t -> bool) : bool = | Lprim {args; primitive = _; loc = _} -> Ext_list.exists args f | Lstaticraise (_id, args) -> Ext_list.exists args f | Lstaticcatch (e1, _vars, e2) -> f e1 || f e2 - | Ltrywith (e1, _exn, e2) -> f e1 || f e2 + | Ltrywith (e1, _exn, e2, finally_expr) -> + f e1 || Ext_option.exists e2 f || Ext_option.exists finally_expr f | Lifthenelse (e1, e2, e3) -> f e1 || f e2 || f e3 | Lsequence (e1, e2) -> f e1 || f e2 | Lwhile (e1, e2) -> f e1 || f e2 diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml index 1d80ae16ed..f9789aa9a9 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_alpha_conversion.ml @@ -113,7 +113,9 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (Ext_option.map d simpl) | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) + | Ltrywith (l1, v, l2, finally_expr) -> + Lam.try_ (simpl l1) v (Ext_option.map l2 simpl) + (Ext_option.map finally_expr simpl) | Lifthenelse (l1, l2, l3) -> Lam.if_ (simpl l1) (simpl l2) (simpl l3) | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index 8c4cde883b..ad6fc997c3 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -127,9 +127,10 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = | Lstaticcatch (l1, (_, _), l2) -> collect l1; collect l2 - | Ltrywith (l1, _, l2) -> + | Ltrywith (l1, _, l2, finally_expr) -> collect l1; - collect l2 + Ext_option.iter l2 collect; + Ext_option.iter finally_expr collect | Lifthenelse (l1, l2, l3) -> collect l1; collect l2; diff --git a/compiler/core/lam_pass_count.ml b/compiler/core/lam_pass_count.ml index 3fc3a89090..14ff08ea69 100644 --- a/compiler/core/lam_pass_count.ml +++ b/compiler/core/lam_pass_count.ml @@ -176,9 +176,10 @@ let collect_occurs lam : occ_tbl = | Lstaticcatch (l1, (_i, _), l2) -> count bv l1; count bv l2 - | Ltrywith (l1, _v, l2) -> + | Ltrywith (l1, _v, l2, finally_expr) -> count bv l1; - count bv l2 + Ext_option.iter l2 (count bv); + Ext_option.iter finally_expr (count bv) | Lifthenelse (l1, l2, l3) -> count bv l1; count bv l2; diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index 11258e6a12..0d38978437 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -254,7 +254,9 @@ let deep_flatten (lam : Lam.t) : Lam.t = Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) (Ext_option.map d aux) | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (aux l1) ids (aux l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (aux l1) v (aux l2) + | Ltrywith (l1, v, l2, finally_expr) -> + Lam.try_ (aux l1) v (Ext_option.map l2 aux) + (Ext_option.map finally_expr aux) | Lifthenelse (l1, l2, l3) -> Lam.if_ (aux l1) (aux l2) (aux l3) | Lwhile (l1, l2) -> Lam.while_ (aux l1) (aux l2) | Lfor (flag, l1, l2, dir, l3) -> diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index eb54fb2067..169382c89f 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -90,8 +90,10 @@ let rec eliminate_ref id (lam : Lam.t) = Lam.staticraise i (Ext_list.map args (eliminate_ref id)) | Lstaticcatch (e1, i, e2) -> Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) - | Ltrywith (e1, v, e2) -> - Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2) + | Ltrywith (e1, v, e2, finally_expr) -> + Lam.try_ (eliminate_ref id e1) v + (Ext_option.map e2 (eliminate_ref id)) + (Ext_option.map finally_expr (eliminate_ref id)) | Lifthenelse (e1, e2, e3) -> Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) | Lsequence (e1, e2) -> Lam.seq (eliminate_ref id e1) (eliminate_ref id e2) diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index 2eb6295699..0e87cd622c 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -228,7 +228,10 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t Lam.stringswitch (simplif l) (Ext_list.map_snd sw simplif) (Ext_option.map d simplif) - | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) + | Ltrywith (l1, v, l2, finally_expr) -> + Lam.try_ (simplif l1) v + (Ext_option.map l2 simplif) + (Ext_option.map finally_expr simplif) | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index bf32bbc56b..d5e739baa3 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -195,7 +195,10 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simplif) | Lstaticcatch (l1, (i, args), l2) -> Lam.staticcatch (simplif l1) (i, args) (simplif l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) + | Ltrywith (l1, v, l2, finally_expr) -> + Lam.try_ (simplif l1) v + (Ext_option.map l2 simplif) + (Ext_option.map finally_expr simplif) | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) | Lfor (v, l1, l2, dir, l3) -> diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index fe19cf1961..a0d6e70975 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -270,7 +270,9 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = Lam.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) + | Ltrywith (l1, v, l2, finally_expr) -> + Lam.try_ (simpl l1) v (Ext_option.map l2 simpl) + (Ext_option.map finally_expr simpl) | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) | Lfor (flag, l1, l2, dir, l3) -> diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index 172e219abb..8eeb42d529 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -394,9 +394,13 @@ let lambda ppf v = | [] -> () | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) vars lam lhandler - | Ltrywith (lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print - param lam lhandler + | Ltrywith (lbody, param, lhandler, finally_expr) -> + fprintf ppf "@[<2>(try@ %a" lam lbody; + Ext_option.iter lhandler (fun handler -> + fprintf ppf "@;<1 -1>with %a@ %a" Ident.print param lam handler); + Ext_option.iter finally_expr (fun expr -> + fprintf ppf "@ finally@ %a" lam expr); + fprintf ppf "@])" | Lifthenelse (lcond, lif, lelse) -> fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse | Lsequence (l1, l2) -> diff --git a/compiler/core/lam_scc.ml b/compiler/core/lam_scc.ml index 556feed559..edf1e5ebdf 100644 --- a/compiler/core/lam_scc.ml +++ b/compiler/core/lam_scc.ml @@ -43,7 +43,8 @@ let hit_mask (mask : Hash_set_ident_mask.t) (l : Lam.t) : bool = | Lvar id -> hit_var id | Lassign (id, e) -> hit_var id || hit e | Lstaticcatch (e1, (_, _), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 + | Ltrywith (e1, _exn, e2, finally_expr) -> + hit e1 || Ext_option.exists e2 hit || Ext_option.exists finally_expr hit | Lfunction {body; params = _} -> hit body | Llet (_str, _id, arg, body) -> hit arg || hit body | Lletrec (decl, body) -> hit body || hit_list_snd decl diff --git a/compiler/core/lam_subst.ml b/compiler/core/lam_subst.ml index d5469619a3..f3e7dff7b9 100644 --- a/compiler/core/lam_subst.ml +++ b/compiler/core/lam_subst.ml @@ -59,7 +59,10 @@ let subst (s : Lam.t Map_ident.t) lam = | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args subst_aux) | Lstaticcatch (e1, io, e2) -> Lam.staticcatch (subst_aux e1) io (subst_aux e2) - | Ltrywith (e1, exn, e2) -> Lam.try_ (subst_aux e1) exn (subst_aux e2) + | Ltrywith (e1, exn, e2, finally_expr) -> + Lam.try_ (subst_aux e1) exn + (Ext_option.map e2 subst_aux) + (Ext_option.map finally_expr subst_aux) | Lifthenelse (e1, e2, e3) -> Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3) | Lsequence (e1, e2) -> Lam.seq (subst_aux e1) (subst_aux e2) diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 292e199b5a..17671a24be 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -333,7 +333,9 @@ module E = struct (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel, finally_expr) -> + let finally_expr = Ext_option.map finally_expr (sub.expr sub) in + try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) finally_expr | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, arg) -> construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 2fae640eb0..34a77b889e 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -167,7 +167,8 @@ module Exp = struct = mk ?loc ?attrs (Pexp_apply {funct; args; partial; transformed_jsx}) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) + let try_ ?loc ?attrs a b finally_expr = + mk ?loc ?attrs (Pexp_try (a, b, finally_expr)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 11227b903a..ee4718054a 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -148,7 +148,13 @@ module Exp : sig (arg_label * expression) list -> expression val match_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val try_ : + ?loc:loc -> + ?attrs:attrs -> + expression -> + case list -> + expression option -> + expression val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression val construct : ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index a430bb0b7b..89fc008f9c 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -299,9 +299,10 @@ module E = struct | Pexp_match (e, pel) -> sub.expr sub e; sub.cases sub pel - | Pexp_try (e, pel) -> + | Pexp_try (e, pel, finally_expr) -> sub.expr sub e; - sub.cases sub pel + sub.cases sub pel; + iter_opt (sub.expr sub) finally_expr | Pexp_tuple el -> List.iter (sub.expr sub) el | Pexp_construct (lid, arg) -> iter_loc sub lid; diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 673465477b..be3ffa29da 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -296,7 +296,9 @@ module E = struct (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel, finally_expr) -> + let finally_expr = Ext_option.map finally_expr (sub.expr sub) in + try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) finally_expr | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, arg) -> construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 3f91d6ac1e..c5bd752964 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -459,7 +459,9 @@ module E = struct l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> + try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + (Some (ident {txt = Longident.Lident "_"; loc})) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) (* <> *) | Pexp_construct ({txt = Longident.Lident "[]" | Longident.Lident "::"}, _) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index d0ac43d737..eb3fcceda6 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -419,7 +419,8 @@ module E = struct args) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel, _) -> + try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, arg) -> construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index e5e39eb4b5..a16fc0b166 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -226,9 +226,10 @@ let rec add_expr bv exp = | Pexp_match (e, pel) -> add_expr bv e; add_cases bv pel - | Pexp_try (e, pel) -> + | Pexp_try (e, pel, finally_expr) -> add_expr bv e; - add_cases bv pel + add_cases bv pel; + add_opt add_expr bv finally_expr | Pexp_tuple el -> List.iter (add_expr bv) el | Pexp_construct (c, opte) -> add bv c; diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index db810d4f91..bebdc988a8 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -361,7 +361,7 @@ type lambda = lambda * (string * lambda) list * lambda option * Location.t | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda - | Ltrywith of lambda * Ident.t * lambda + | Ltrywith of lambda * Ident.t * lambda option * lambda option | Lifthenelse of lambda * lambda * lambda | Lsequence of lambda * lambda | Lwhile of lambda * lambda @@ -471,7 +471,8 @@ let make_key e = | Lstaticraise (i, es) -> Lstaticraise (i, tr_recs env es) | Lstaticcatch (e1, xs, e2) -> Lstaticcatch (tr_rec env e1, xs, tr_rec env e2) - | Ltrywith (e1, x, e2) -> Ltrywith (tr_rec env e1, x, tr_rec env e2) + | Ltrywith (e1, x, e2, finally) -> + Ltrywith (tr_rec env e1, x, tr_opt env e2, tr_opt env finally) | Lifthenelse (cond, ifso, ifnot) -> Lifthenelse (tr_rec env cond, tr_rec env ifso, tr_rec env ifnot) | Lsequence (e1, e2) -> Lsequence (tr_rec env e1, tr_rec env e2) @@ -532,9 +533,10 @@ let iter f = function | Lstaticcatch (e1, _, e2) -> f e1; f e2 - | Ltrywith (e1, _, e2) -> + | Ltrywith (e1, _, e2, finally) -> f e1; - f e2 + iter_opt f e2; + iter_opt f finally | Lifthenelse (e1, e2, e3) -> f e1; f e2; @@ -567,7 +569,7 @@ let free_ids get l = List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl | Lstaticcatch (_e1, (_, vars), _e2) -> List.iter (fun id -> fv := IdentSet.remove id !fv) vars - | Ltrywith (_e1, exn, _e2) -> fv := IdentSet.remove exn !fv + | Ltrywith (_e1, exn, _e2, _finally) -> fv := IdentSet.remove exn !fv | Lfor (v, _e1, _e2, _dir, _e3) -> fv := IdentSet.remove v !fv | Lassign (id, _e) -> fv := IdentSet.add id !fv | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ @@ -672,7 +674,8 @@ let subst_lambda s lam = (subst arg, List.map subst_strcase cases, subst_opt default, loc) | Lstaticraise (i, args) -> Lstaticraise (i, List.map subst args) | Lstaticcatch (e1, io, e2) -> Lstaticcatch (subst e1, io, subst e2) - | Ltrywith (e1, exn, e2) -> Ltrywith (subst e1, exn, subst e2) + | Ltrywith (e1, exn, e2, finally) -> + Ltrywith (subst e1, exn, subst_opt e2, subst_opt finally) | Lifthenelse (e1, e2, e3) -> Lifthenelse (subst e1, subst e2, subst e3) | Lsequence (e1, e2) -> Lsequence (subst e1, subst e2) | Lwhile (e1, e2) -> Lwhile (subst e1, subst e2) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index d8eaf57be6..0c60c09325 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -332,7 +332,7 @@ type lambda = lambda * (string * lambda) list * lambda option * Location.t | Lstaticraise of int * lambda list | Lstaticcatch of lambda * (int * Ident.t list) * lambda - | Ltrywith of lambda * Ident.t * lambda + | Ltrywith of lambda * Ident.t * lambda option * lambda option | Lifthenelse of lambda * lambda * lambda | Lsequence of lambda * lambda | Lwhile of lambda * lambda diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 78c9899f74..0508f9b7d1 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -255,8 +255,8 @@ and expression_desc = *) | Pexp_match of expression * case list (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_try of expression * case list * expression option + (* try E0 with P1 -> E1 | ... | Pn -> En [finally E_final] *) | Pexp_tuple of expression list (* (E1, ..., En) diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index 585ac64b81..76fa8de0c5 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -625,11 +625,14 @@ and expression ctxt f x = | Pexp_match (e, l) -> pp f "@[@[@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt) e (case_list ctxt) l - | Pexp_try (e, l) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - (* "try@;@[<2>%a@]@\nwith@\n%a"*) - (expression reset_ctxt) - e (case_list ctxt) l + | Pexp_try (e, l, finally_expr) -> ( + pp f "@[<0>@[try@ %a@]" (expression reset_ctxt) e; + (* Print "with" part conditionally *) + if l <> [] then pp f " @[<0>with%a@]" (case_list ctxt) l; + (* Print "finally" part conditionally *) + match finally_expr with + | Some expr -> pp f " finally@ %a@]" (expression reset_ctxt) expr + | None -> pp f "@]") | Pexp_let (rf, l, e) -> (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" (*no indentation here, a new line*) *) diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 44d699eb38..81e79d6856 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -268,10 +268,11 @@ and expression i ppf x = line i ppf "Pexp_match\n"; expression i ppf e; list i case ppf l - | Pexp_try (e, l) -> + | Pexp_try (e, l, finally_expr) -> line i ppf "Pexp_try\n"; expression i ppf e; - list i case ppf l + list i case ppf l; + option (i + 2) expression ppf finally_expr | Pexp_tuple l -> line i ppf "Pexp_tuple\n"; list i expression ppf l diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 0282f6e113..42241b63ca 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -371,9 +371,15 @@ let rec lam ppf = function | [] -> () | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) vars lam lhandler - | Ltrywith (lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print - param lam lhandler + | Ltrywith (lbody, param, lhandler, finally) -> + fprintf ppf "@[<2>(try@ %a" lam lbody; + (* Print "with" part conditionally *) + Ext_option.iter lhandler (fun handler -> + fprintf ppf "@;<1 -1>with %a@ %a" Ident.print param lam handler); + (* Print "finally" part conditionally *) + Ext_option.iter finally (fun lfinally -> + fprintf ppf "@ finally@ %a" lam lfinally); + fprintf ppf ")@]" | Lifthenelse (lcond, lif, lelse) -> fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse | Lsequence (l1, l2) -> fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 064f0ab55c..6d2cb6df3f 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -298,10 +298,11 @@ and expression i ppf x = expression i ppf e; list i case ppf l1; list i case ppf l2 - | Texp_try (e, l) -> + | Texp_try (e, l, finally) -> line i ppf "Texp_try\n"; expression i ppf e; - list i case ppf l + list i case ppf l; + Ext_option.iter finally (expression i ppf) | Texp_tuple l -> line i ppf "Texp_tuple\n"; list i expression ppf l diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 3d016a7438..55884cb5e7 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -284,10 +284,11 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = | Texp_letexception (_, e) -> expression env e | Texp_assert e -> Use.inspect (expression env e) | Texp_pack m -> modexp env m - | Texp_try (e, cases) -> + | Texp_try (e, cases, finally_expr) -> (* This is more permissive than the old check. *) let case env {Typedtree.c_rhs} = expression env c_rhs in - Use.join (expression env e) (list case env cases) + Use.join (expression env e) + (Use.join (list case env cases) (option expression env finally_expr)) | Texp_function {case = case_} -> Use.delay (list (case ~scrutinee:Use.empty) env [case_]) | Texp_extension_constructor _ -> Use.empty diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 5c12d3da4d..6ada092859 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -159,9 +159,10 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = sub.expr sub exp; sub.cases sub list1; sub.cases sub list2 - | Texp_try (exp, cases) -> + | Texp_try (exp, cases, finally_expr) -> sub.expr sub exp; - sub.cases sub cases + sub.cases sub cases; + Option.iter (sub.expr sub) finally_expr | Texp_tuple list -> List.iter (sub.expr sub) list | Texp_construct (_, _, args) -> List.iter (sub.expr sub) args | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 54eba02869..2d8306fafe 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -209,7 +209,9 @@ let expr sub x = | Texp_match (exp, cases, exn_cases, p) -> Texp_match (sub.expr sub exp, sub.cases sub cases, sub.cases sub exn_cases, p) - | Texp_try (exp, cases) -> Texp_try (sub.expr sub exp, sub.cases sub cases) + | Texp_try (exp, cases, finally_expr) -> + Texp_try + (sub.expr sub exp, sub.cases sub cases, opt (sub.expr sub) finally_expr) | Texp_tuple list -> Texp_tuple (List.map (sub.expr sub) list) | Texp_construct (lid, cd, args) -> Texp_construct (lid, cd, List.map (sub.expr sub) args) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 078cbf133a..1bffe35072 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -775,12 +775,20 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (transl_exp funct) oargs e.exp_loc | Texp_match (arg, pat_expr_list, exn_pat_expr_list, partial) -> transl_match e arg pat_expr_list exn_pat_expr_list partial - | Texp_try (body, pat_expr_list) -> + | Texp_try (body, pat_expr_list, finally_expr) -> let id = Typecore.name_pattern "exn" pat_expr_list in - Ltrywith - ( transl_exp body, - id, - Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list) ) + let finally_lambda = + match finally_expr with + | None -> None + | Some expr -> Some (transl_exp expr) + in + let catch_handler = + match pat_expr_list with + | [] -> None (* No catch cases *) + | _ :: _ -> + Some (Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list)) + in + Ltrywith (transl_exp body, id, catch_handler, finally_lambda) | Texp_tuple el -> ( let ll = transl_list el in try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) @@ -1251,7 +1259,8 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial = ( Ltrywith ( Lstaticraise (static_exception_id, body), id, - Matching.for_trywith (Lvar id) exn_cases ), + Some (Matching.for_trywith (Lvar id) exn_cases), + None ), (static_exception_id, val_ids), handler ) in diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 90522f13d2..71746458c3 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -161,9 +161,13 @@ let iter_expression f e = | Pexp_let (_, pel, e) -> expr e; List.iter binding pel - | Pexp_match (e, pel) | Pexp_try (e, pel) -> + | Pexp_match (e, pel) -> expr e; List.iter case pel + | Pexp_try (e, pel, finally_expr) -> + expr e; + List.iter case pel; + may expr finally_expr | Pexp_array el | Pexp_tuple el -> List.iter expr el | Pexp_construct (_, eo) | Pexp_variant (_, eo) -> may expr eo | Pexp_record (iel, eo) -> @@ -1782,7 +1786,7 @@ let rec final_subexpression sexp = match sexp.pexp_desc with | Pexp_let (_, _, e) | Pexp_sequence (_, e) - | Pexp_try (e, _) + | Pexp_try (e, _, _) | Pexp_ifthenelse (_, e, _) | Pexp_match (_, {pc_rhs = e} :: _) -> final_subexpression e @@ -1915,7 +1919,7 @@ let rec type_approx env sexp = let ty = if is_optional p then type_option (newvar ()) else newvar () in newty (Tarrow ({lbl = p; typ = ty}, type_approx env e, Cok, arity)) | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e - | Pexp_try (e, _) -> type_approx env e + | Pexp_try (e, _, _) -> type_approx env e | Pexp_tuple l -> newty (Ttuple (List.map (type_approx env) l)) | Pexp_ifthenelse (_, e, _) -> type_approx env e | Pexp_sequence (_, e) -> type_approx env e @@ -2512,15 +2516,27 @@ and type_expect_ ~context ?in_function ?(recarg = Rejected) env sexp ty_expected exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_try (sbody, caselist) -> + | Pexp_try (sbody, caselist, finally_expr) -> let body = type_expect ~context:None env sbody ty_expected in let cases, _ = type_cases ~call_context:`Try env Predef.type_exn ty_expected false loc caselist in + let finally_exp = + match finally_expr with + | None -> None + | Some expr -> + let finally_typed = + type_expect ~context:None env expr Predef.type_unit + in + (* Finally blocks must return unit *) + unify_exp_types ~context:None loc env finally_typed.exp_type + Predef.type_unit; + Some finally_typed + in re { - exp_desc = Texp_try (body, cases); + exp_desc = Texp_try (body, cases, finally_exp); exp_loc = loc; exp_extra = []; exp_type = body.exp_type; diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 9ef328be4a..2b4431d09c 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -89,7 +89,7 @@ and expression_desc = transformed_jsx: bool; } | Texp_match of expression * case list * case list * partial - | Texp_try of expression * case list + | Texp_try of expression * case list * expression option | Texp_tuple of expression list | Texp_construct of Longident.t loc * constructor_description * expression list diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 6e6b1c5159..82a1b5217d 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -174,8 +174,8 @@ and expression_desc = [Texp_match (E0, [(P1, E1); (P2, E2)], [(P3, E3)], _)] *) - | Texp_try of expression * case list - (** try E with P1 -> E1 | ... | PN -> EN *) + | Texp_try of expression * case list * expression option + (** try E with P1 -> E1 | ... | PN -> EN [finally E_final] *) | Texp_tuple of expression list (** (E1, ..., EN) *) | Texp_construct of Longident.t loc * constructor_description * expression list diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index 9a31b9b5b9..c549f2f621 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.ml @@ -239,9 +239,10 @@ end = struct iter_expression exp; iter_cases list1; iter_cases list2 - | Texp_try (exp, list) -> + | Texp_try (exp, list, finally_expr) -> iter_expression exp; - iter_cases list + iter_cases list; + may_iter iter_expression finally_expr | Texp_tuple list -> List.iter iter_expression list | Texp_construct (_, _, args) -> List.iter iter_expression args | Texp_variant (_label, expo) -> ( diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 52a57b89c5..dce3f5dada 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -584,12 +584,15 @@ module SexpAst = struct expression expr; Sexp.list (map_empty ~f:case cases); ] - | Pexp_try (expr, cases) -> + | Pexp_try (expr, cases, finally_expr) -> Sexp.list [ Sexp.atom "Pexp_try"; expression expr; Sexp.list (map_empty ~f:case cases); + (match finally_expr with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); ] | Pexp_tuple exprs -> Sexp.list diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index b9a81d53a9..a9d0554497 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1469,7 +1469,7 @@ and walk_expression expr t comments = after) in attach t.trailing else_branch.pc_rhs.pexp_loc after - | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> + | Pexp_match (expr, cases) -> let before, inside, after = partition_by_loc comments expr.pexp_loc in let after = if is_block_expr expr then ( @@ -1486,7 +1486,47 @@ and walk_expression expr t comments = let after_expr, rest = partition_adjacent_trailing expr.pexp_loc after in attach t.trailing expr.pexp_loc after_expr; walk_list (cases |> List.map (fun case -> Case case)) t rest - (* unary expression: todo use parsetreeviewer *) + | Pexp_try (expr, cases, finally_expr) -> ( + let before, inside, after = partition_by_loc comments expr.pexp_loc in + let after = + if is_block_expr expr then ( + let after_expr, rest = + partition_adjacent_trailing expr.pexp_loc after + in + walk_expression expr t (List.concat [before; inside; after_expr]); + rest) + else ( + attach t.leading expr.pexp_loc before; + walk_expression expr t inside; + after) + in + let after_expr, remaining_after_try = + partition_adjacent_trailing expr.pexp_loc after + in + attach t.trailing expr.pexp_loc after_expr; + let remaining_after_cases = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (node : node) -> get_loc node) + ~walk_node ~newline_delimited:false + (cases |> List.map (fun case -> Case case)) + t remaining_after_try + in + match finally_expr with + | Some finally_expr -> + let before, inside, after = + partition_by_loc remaining_after_cases finally_expr.pexp_loc + in + if is_block_expr finally_expr then + let after_expr, _ = + partition_adjacent_trailing finally_expr.pexp_loc after + in + walk_expression finally_expr t + (List.concat [before; inside; after_expr]) + else ( + attach t.leading finally_expr.pexp_loc before; + walk_expression finally_expr t inside) + | None -> () + (* unary expression: todo use parsetreeviewer *)) | Pexp_apply { funct = diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 380fe21c2e..e7bf8ba009 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -3548,12 +3548,54 @@ and parse_try_expression p = let start_pos = p.Parser.start_pos in Parser.expect Try p; let expr = parse_expr ~context:WhenExpr p in - Parser.expect Res_token.catch p; - Parser.expect Lbrace p; - let cases = parse_pattern_matching p in - Parser.expect Rbrace p; + + (* Check if we have catch or finally *) + let cases, finally_expr = + if + Parser.lookahead p (fun state -> + match state.Parser.token with + | Lident "catch" -> true + | _ -> false) + then ( + (* Parse catch block *) + Parser.expect Res_token.catch p; + Parser.expect Lbrace p; + let cases = parse_pattern_matching p in + Parser.expect Rbrace p; + + (* Check for optional finally *) + let finally_expr = + if + Parser.lookahead p (fun state -> + match state.Parser.token with + | Lident "finally" -> true + | _ -> false) + then ( + Parser.expect (Lident "finally") p; + let finally_expr = parse_expr ~context:WhenExpr p in + Some finally_expr) + else None + in + (cases, finally_expr)) + else if + Parser.lookahead p (fun state -> + match state.Parser.token with + | Lident "finally" -> true + | _ -> false) + then ( + (* Parse finally block without catch *) + Parser.expect (Lident "finally") p; + let finally_expr = parse_expr ~context:WhenExpr p in + ([], Some finally_expr)) + else ( + (* Error: need either catch or finally *) + Parser.err p + (Diagnostics.message "Expected 'catch' or 'finally' after 'try'"); + ([], None)) + in + let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.try_ ~loc expr cases + Ast_helper.Exp.try_ ~loc expr cases finally_expr and parse_if_condition p = Parser.leave_breadcrumb p Grammar.IfCondition; diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 2f73bd2684..b047bb0106 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -3477,7 +3477,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = ]) | Pexp_sequence _ -> print_expression_block ~state ~braces:true e cmt_tbl | Pexp_let _ -> print_expression_block ~state ~braces:true e cmt_tbl - | Pexp_try (expr, cases) -> + | Pexp_try (expr, cases, finally_expr) -> let expr_doc = let doc = print_expression_with_comments ~state expr cmt_tbl in match Parens.expr expr with @@ -3485,13 +3485,34 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = | Braced braces -> print_braces doc expr braces | Nothing -> doc in - Doc.concat - [ - Doc.text "try "; - expr_doc; - Doc.text " catch "; - print_cases ~state cases cmt_tbl; - ] + let base_doc = + if cases = [] then + (* try..finally without catch *) + Doc.concat [Doc.text "try "; expr_doc] + else + (* try..catch..finally *) + Doc.concat + [ + Doc.text "try "; + expr_doc; + Doc.text " catch "; + print_cases ~state cases cmt_tbl; + ] + in + let finally_doc = + match finally_expr with + | None -> Doc.nil + | Some expr -> + let finally_expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + Doc.concat [Doc.text " finally "; finally_expr_doc] + in + Doc.concat [base_doc; finally_doc] | Pexp_match (_, [_; _]) when ParsetreeViewer.is_if_let_expr e -> let ifs, else_expr = ParsetreeViewer.collect_if_expressions e in print_if_chain ~state e.pexp_attributes ifs else_expr cmt_tbl diff --git a/compiler/syntax/src/res_token.ml b/compiler/syntax/src/res_token.ml index d48a97d24e..26ba2251e2 100644 --- a/compiler/syntax/src/res_token.ml +++ b/compiler/syntax/src/res_token.ml @@ -272,3 +272,4 @@ let is_keyword_txt str = with Not_found -> false let catch = Lident "catch" +let finally = Lident "finally" diff --git a/tests/build_tests/super_errors/expected/finally_non_unit_type.res.expected b/tests/build_tests/super_errors/expected/finally_non_unit_type.res.expected new file mode 100644 index 0000000000..048258e966 --- /dev/null +++ b/tests/build_tests/super_errors/expected/finally_non_unit_type.res.expected @@ -0,0 +1,15 @@ + + We've found a bug for you! + /.../fixtures/finally_non_unit_type.res:7:5-6 + + 5 │ | _ => () + 6 │ } finally { + 7 │ 42 + 8 │ } + 9 │ } + + This has type: int + But it's expected to have type: unit + + - Did you mean to assign this to a variable? + - If you don't care about the result of this expression, you can assign it to _ via let _ = ... or pipe it to ignore via expression->ignore \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/finally_non_unit_type.res b/tests/build_tests/super_errors/fixtures/finally_non_unit_type.res new file mode 100644 index 0000000000..eb9bb35e33 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/finally_non_unit_type.res @@ -0,0 +1,9 @@ +let f = () => { + try { + Console.log("hello") + } catch { + | _ => () + } finally { + 42 + } +} diff --git a/tests/syntax_tests/data/parsing/errors/expressions/expected/try.res.txt b/tests/syntax_tests/data/parsing/errors/expressions/expected/try.res.txt index 86ec4af148..86ae836e04 100644 --- a/tests/syntax_tests/data/parsing/errors/expressions/expected/try.res.txt +++ b/tests/syntax_tests/data/parsing/errors/expressions/expected/try.res.txt @@ -1,4 +1,15 @@ + Syntax error! + syntax_tests/data/parsing/errors/expressions/try.res:2:38 + + 1 ┆ let parsedPayload = + 2 ┆ try (Js.Json.parseExn(response)) { + 3 ┆ | _ => Js.Json.null + 4 ┆ } + + Expected 'catch' or 'finally' after 'try' + + Syntax error! syntax_tests/data/parsing/errors/expressions/try.res:2:37-38 @@ -7,6 +18,7 @@ 3 ┆ | _ => Js.Json.null 4 ┆ } - Did you forget a `catch` here? + consecutive statements on a line must be separated by ';' or a newline -let parsedPayload = try Js.Json.parseExn response with | _ -> Js.Json.null \ No newline at end of file +let parsedPayload = try Js.Json.parseExn response +;;(([%rescript.exprhole ]; (fun [arity:1]_ -> Js.Json.null))[@res.braces ]) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/expressions/expected/try_finally_errors.res.txt b/tests/syntax_tests/data/parsing/errors/expressions/expected/try_finally_errors.res.txt new file mode 100644 index 0000000000..b3121693a9 --- /dev/null +++ b/tests/syntax_tests/data/parsing/errors/expressions/expected/try_finally_errors.res.txt @@ -0,0 +1,71 @@ + + Syntax error! + syntax_tests/data/parsing/errors/expressions/try_finally_errors.res:2:36-5:3 + + 1 │ // Test try without catch or finally + 2 │ let missingBoth = try doSomething() + 3 │ + 4 │ // Test try with malformed finally + 5 │ try doSomething() finally + 6 │ + 7 │ // Test try with empty finally block + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/errors/expressions/try_finally_errors.res:5:18-25 + + 3 │ + 4 │ // Test try with malformed finally + 5 │ try doSomething() finally + 6 │ + 7 │ // Test try with empty finally block + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/errors/expressions/try_finally_errors.res:26:35-42 + + 24 │ + 25 │ // Test malformed patterns in catch with finally + 26 │ try doSomething() catch {| invalid pattern => ()} finally cleanup() + 27 │ + 28 │ // Test missing closing brace in finally + + Did you forget a `=>` here? + + + Syntax error! + syntax_tests/data/parsing/errors/expressions/try_finally_errors.res:37:23-38:1 + + 35 │ // Test try-finally with invalid syntax in finally block + 36 │ try doSomething() finally { + 37 │ let invalid_syntax = + 38 │ } + + This let-binding misses an expression + +let missingBoth = try doSomething () with +;;try doSomething () with finally try doSomething () with finally { } +;;try doSomething () with | _ -> () finally cleanup () +;;finally +;;extraCleanup () +;;finally +;;cleanup () +;;try doSomething () with finally cleanup () +;;catch +;;(([%rescript.exprhole ]; (fun [arity:1]_ -> ()))[@res.braces ]) +;;try doSomething () with finally catch +;;(([%rescript.exprhole ]; (fun [arity:1]_ -> ()))[@res.braces ]) +;;try doSomething () with finally try innerOp () with finally innerCleanup () +;;try doSomething () with | invalid -> (fun [arity:1]pattern -> ()) finally + cleanup () +;;try doSomething () with finally + ((cleanup (); + (try doSomething () with finally cleanup ()); + extraToken; + (try doSomething () with finally + ((let invalid_syntax = [%rescript.exprhole ] in ())[@res.braces ]))) + [@res.braces ]) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/binaryNoEs6Arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/binaryNoEs6Arrow.res.txt index 260cca36aa..8c1d7f264e 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/binaryNoEs6Arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/binaryNoEs6Arrow.res.txt @@ -9,12 +9,11 @@ ((sibling === None) || (parent === None)) with | _ -> () -;;try (color === Black) && ((sibling === None) || (parent === None)) +;;try (color === Black) && ((sibling === None) || (parent === None)) with | _ -> () ;;try ((color === Black) && (color === Red)) && - ((sibling === None) || (parent === None)) - with | _ -> () + ((sibling === None) || (parent === None)) with | _ -> () ;;while (color === Black) && ((sibling === None) || (parent === None)) do () done ;;while diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/try.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/try.res.txt index 5516982c57..a7c2fe606c 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/try.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/try.res.txt @@ -1,6 +1,52 @@ -;;try ((let x = 1 in let y = 2 in dangerousCall (x + y))[@res.braces ]) - with | Foo -> Js.log {js|catched Foo|js} - | Exit -> Js.log {js|catched exit|js} -;;try myDangerousFn () with | Foo -> Js.log {js|catched Foo|js}[@@attr ] +;;try ((let x = 1 in let y = 2 in dangerousCall (x + y))[@res.braces ]) + with | Foo -> Console.log {js|caught Foo|js} + | Exit -> Console.log {js|caught exit|js} +;;try myDangerousFn () with | Foo -> Console.log {js|caught Foo|js}[@@attr ] let x = ((let y = 1 in try ((apply y)[@res.braces ]) with | _ -> 2) - [@res.braces ]) \ No newline at end of file + [@res.braces ]) +;;try ((riskyOperation ())[@res.braces ]) with + | Not_found -> + Console.log + {js|Item not found|js} + | exn -> + Console.log {js|Other error|js} finally + ((Console.log {js|Cleanup complete|js})[@res.braces ]) +;;try ((let result = fetchData () in processResult result)[@res.braces ]) + with | ParseError -> defaultValue | ValidationError -> fallbackValue finally + ((logProcessingComplete (); releaseParser ())[@res.braces ]) +;;try + ((try ((innerOperation ())[@res.braces ]) with + | InnerError -> + Console.log + {js|Inner error handled|js} finally + ((Console.log {js|Inner cleanup|js})[@res.braces ])) + [@res.braces ]) with + | OuterError -> Console.log {js|Outer error handled|js} finally + ((Console.log {js|Outer cleanup|js})[@res.braces ]) +let tryFinally1 = try doSomething () finally cleanup () +let tryFinally2 = + try ((let x = 1 in let y = 2 in dangerousOperation (x + y))[@res.braces ]) finally + ((Console.log {js|Cleanup complete|js})[@res.braces ]) +let tryFinallyInAssignment = + { + value = (try computeValue () finally logComputation ()); + status = {js|computed|js} + } +let tryFinallyInArray = + [|((try getItem 0 finally logAccess 0));((try getItem 1 finally logAccess 1))|] +let tryFinallyInFunction [arity:1]() = + ((try performOperation () finally logOperationComplete ())[@res.braces ]) +let complex = + { + data = + (try + ((let raw = try parseJson input finally logParseAttempt () in + let validated = try validate raw finally logValidation () in + try transform validated finally logTransform ()) + [@res.braces ]) with + | ParseError -> + { error = {js|parse|js}; value = null } + | ValidationError -> + { error = {js|validation|js}; value = null } finally + ((Console.log {js|Overall cleanup|js})[@res.braces ])) + } \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/try_finally.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/try_finally.res.txt new file mode 100644 index 0000000000..062426f6be --- /dev/null +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/try_finally.res.txt @@ -0,0 +1,147 @@ + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:2:31-5:3 + + 1 │ // Test try without catch or finally (should error) + 2 │ let badTry = try doSomething() + 3 │ + 4 │ // Test try with only finally (valid) + 5 │ let goodTryFinally = try doSomething() finally cleanup() + 6 │ + 7 │ // Test try-finally in various contexts + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:5:39-46 + + 3 │ + 4 │ // Test try with only finally (valid) + 5 │ let goodTryFinally = try doSomething() finally cleanup() + 6 │ + 7 │ // Test try-finally in various contexts + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:13:4-11 + + 11 ┆ try { + 12 ┆ parse(data) + 13 ┆ } finally { + 14 ┆ log("Processing complete") + 15 ┆ } + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:19:27-34 + + 17 │ + 18 │ // In assignment + 19 │ let value = try getValue() finally logAttempt() + 20 │ + 21 │ // In conditional + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:23:25-32 + + 21 │ // In conditional + 22 │ let result = if condition { + 23 │ try getPositiveValue() finally logAttempt() + 24 │ } else { + 25 │ defaultValue + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:30:28-35 + + 28 │ // In record field + 29 │ let record = { + 30 │ value: try computeValue() finally logComputation(), + 31 │ status: "computed" + 32 │ } + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:36:17-24 + + 34 │ // In array element + 35 │ let items = [ + 36 │ try getItem(0) finally logAccess(0), + 37 │ try getItem(1) finally logAccess(1) + 38 │ ] + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:41:28-35 + + 39 │ + 40 │ // In tuple + 41 │ let tuple = (try getFirst() finally logFirst(), try getSecond() finally + │ logSecond()) + 42 │ + 43 │ // In function argument + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:44:40-47 + + 42 │ + 43 │ // In function argument + 44 │ let result = processData(try getInput() finally logInput()) + 45 │ + 46 │ // In return position (function body) + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:60:35-42 + + 58 │ let complex = { + 59 │ data: try { + 60 │ let raw = try parseJson(input) finally logParseAttempt() + 61 │ let validated = try validate(raw) finally logValidation() + 62 │ try transform(validated) finally logTransform() + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:61:38-45 + + 59 ┆ data: try { + 60 ┆ let raw = try parseJson(input) finally logParseAttempt() + 61 ┆ let validated = try validate(raw) finally logValidation() + 62 ┆ try transform(validated) finally logTransform() + 63 ┆ } catch { + + Did you forget a `catch` here? + + + Syntax error! + syntax_tests/data/parsing/grammar/expressions/try_finally.res:62:29-36 + + 60 ┆ let raw = try parseJson(input) finally logParseAttempt() + 61 ┆ let validated = try validate(raw) finally logValidation() + 62 ┆ try transform(validated) finally logTransform() + 63 ┆ } catch { + 64 ┆ | ParseError => {error: "parse", value: null} + + Did you forget a `catch` here? + diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/try.res b/tests/syntax_tests/data/parsing/grammar/expressions/try.res index a61cc70046..68125ff6bc 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/try.res +++ b/tests/syntax_tests/data/parsing/grammar/expressions/try.res @@ -3,13 +3,13 @@ try { let y = 2 dangerousCall(x + y) } catch { -| Foo => Js.log("catched Foo") -| Exit => Js.log("catched exit") +| Foo => Console.log("caught Foo") +| Exit => Console.log("caught exit") } @attr try myDangerousFn() catch { -| Foo => Js.log("catched Foo") +| Foo => Console.log("caught Foo") } let x = { @@ -20,3 +20,82 @@ let x = { | _ => 2 } } + +// Try-catch-finally with block expressions +try { + riskyOperation() +} catch { +| Not_found => Console.log("Item not found") +| exn => Console.log("Other error") +} finally { + Console.log("Cleanup complete") +} + +// Try-catch-finally with comments +try { + // This is a comment in the try block + let result = fetchData() + processResult(result) +} catch { +| ParseError => defaultValue +| ValidationError => fallbackValue +} finally { + // Comment in finally block + logProcessingComplete() + releaseParser() +} + +// Nested try-catch-finally +try { + try { + innerOperation() + } catch { + | InnerError => Console.log("Inner error handled") + } finally { + Console.log("Inner cleanup") + } +} catch { +| OuterError => Console.log("Outer error handled") +} finally { + Console.log("Outer cleanup") +} + +// Try-finally without catch tests +let tryFinally1 = try doSomething() finally cleanup() + +let tryFinally2 = try { + let x = 1 + let y = 2 + dangerousOperation(x + y) +} finally { + Console.log("Cleanup complete") +} + +// Try-finally in various contexts +let tryFinallyInAssignment = { + value: try computeValue() finally logComputation(), + status: "computed" +} + +let tryFinallyInArray = [ + try getItem(0) finally logAccess(0), + try getItem(1) finally logAccess(1) +] + +let tryFinallyInFunction = () => { + try performOperation() finally logOperationComplete() +} + +// Complex nested try-finally +let complex = { + data: try { + let raw = try parseJson(input) finally logParseAttempt() + let validated = try validate(raw) finally logValidation() + try transform(validated) finally logTransform() + } catch { + | ParseError => {error: "parse", value: null} + | ValidationError => {error: "validation", value: null} + } finally { + Console.log("Overall cleanup") + } +} diff --git a/tests/syntax_tests/data/printer/expr/expected/try.res.txt b/tests/syntax_tests/data/printer/expr/expected/try.res.txt index b880ec0c6a..0cf1a25284 100644 --- a/tests/syntax_tests/data/printer/expr/expected/try.res.txt +++ b/tests/syntax_tests/data/printer/expr/expected/try.res.txt @@ -3,12 +3,12 @@ try { let y = 2 dangerousCall() } catch { -| Foo => Js.log() -| Exit => Js.log() +| Foo => Console.log() +| Exit => Console.log() } try myDangerousFn() catch { -| Foo => Js.log() +| Foo => Console.log() } let x = { @@ -22,11 +22,139 @@ let x = { @attr @attr2 try myDangerousFn() catch { -| Foo => Js.log() +| Foo => Console.log() } let () = @attr @attr2 try myDangerousFn() catch { - | Foo => Js.log() + | Foo => Console.log() } + +// Try-catch-finally tests +// Comment before try +try { + // Comment inside try block + dangerousOperation() + // Another comment in try +} catch { +// Comment in catch block +| Error => Console.log("Error") +// More catch comments +} finally { + // Comment in finally block + cleanup() +} + +try { + // Comment: getting data + let result = fetchData() + // Comment: processing result + processResult(result) +} catch { +// Comment: not found case +| Not_found => Console.log("Not found") +// Comment: other errors +| _ => Console.log("Other error") +} finally { + // Comment: releasing resources + releaseResources() +} + +// Nested try-catch-finally +try { + // Outer try start + try { + // Inner try + innerOperation() + } catch { + // Inner catch + | InnerError => Console.log("Inner error") + } finally { + // Inner finally + innerCleanup() + } + // End outer try +} catch { +// Outer catch +| OuterError => Console.log("Outer error") +} finally { + // Outer finally + outerCleanup() +} + +// Try-catch-finally with attributes +// Comment before attr +@attr +try { + // Try with attribute + operation() +} catch { +// Catch with attribute +| Error => Console.log("Error") +} finally { + // Finally with attribute + cleanup() +} + +// Multiple attributes +@attr @attr2 +try { + // Complex operation with multiple attrs + complexOperation() +} catch { +// Error handling +| Error => Console.log("Error") +} finally { + // Cleanup with logging + Console.log("Cleanup") +} + +let () = + // Function with try-catch-finally + + @attr @attr2 + try { + // Operation in function + operation() + } catch { + // Error in function + | Error => Console.log("Error") + } finally { + // Finally in function + cleanup() + } + +// Try-finally without catch tests +try { + dangerousOperation() +} finally { + cleanup() +} + +try simpleCall() finally simpleCleanup() + +@attr +try { + operation() +} finally { + cleanup() +} + +// Try-finally in assignment +let result = try { + getValue() +} finally { + releaseResources() +} + +// Nested try-finally +try { + try { + innerOperation() + } finally { + innerCleanup() + } +} finally { + outerCleanup() +} diff --git a/tests/syntax_tests/data/printer/expr/try.res b/tests/syntax_tests/data/printer/expr/try.res index 0eb82572a3..5070f3e603 100644 --- a/tests/syntax_tests/data/printer/expr/try.res +++ b/tests/syntax_tests/data/printer/expr/try.res @@ -3,12 +3,12 @@ try { let y = 2 dangerousCall() } catch { -| Foo => Js.log() -| Exit => Js.log() +| Foo => Console.log() +| Exit => Console.log() } try myDangerousFn() catch { -| Foo => Js.log() +| Foo => Console.log() } let x = { @@ -22,12 +22,143 @@ let x = { @attr @attr2 try myDangerousFn() catch { -| Foo => Js.log() +| Foo => Console.log() } let () = @attr @attr2 try myDangerousFn() catch { - | Foo => Js.log() + | Foo => Console.log() } + +// Try-catch-finally tests +// Comment before try +try { + // Comment inside try block + dangerousOperation() + // Another comment in try +} catch { + // Comment in catch block +| Error => Console.log("Error") + // More catch comments +} finally { + // Comment in finally block + cleanup() + // Finally block end comment +} + +try { + // Comment: getting data + let result = fetchData() + // Comment: processing result + processResult(result) +} catch { + // Comment: not found case +| Not_found => Console.log("Not found") + // Comment: other errors +| _ => Console.log("Other error") +} finally { + // Comment: releasing resources + releaseResources() + // Comment: cleanup complete +} + +// Nested try-catch-finally +try { + // Outer try start + try { + // Inner try + innerOperation() + } catch { + // Inner catch + | InnerError => Console.log("Inner error") + } finally { + // Inner finally + innerCleanup() + // End inner finally + } + // End outer try +} catch { + // Outer catch +| OuterError => Console.log("Outer error") +} finally { + // Outer finally + outerCleanup() + // End outer finally +} + +// Try-catch-finally with attributes +// Comment before attr +@attr +try { + // Try with attribute + operation() +} catch { + // Catch with attribute +| Error => Console.log("Error") +} finally { + // Finally with attribute + cleanup() +} + +// Multiple attributes +@attr @attr2 +try { + // Complex operation with multiple attrs + complexOperation() +} catch { + // Error handling +| Error => Console.log("Error") +} finally { + // Cleanup with logging + Console.log("Cleanup") +} + +let () = + // Function with try-catch-finally + @attr @attr2 + try { + // Operation in function + operation() + } catch { + // Error in function + | Error => Console.log("Error") + } finally { + // Finally in function + cleanup() + } + +// Try-finally without catch tests +try { + dangerousOperation() +} finally { + cleanup() +} + +try simpleCall() finally simpleCleanup() + +@attr +try { + operation() +} finally { + cleanup() +} + +// Try-finally in assignment +let result = try { + getValue() +} finally { + releaseResources() +} + +// Nested try-finally +try { + try { + innerOperation() + } finally { + innerCleanup() + } +} finally { + outerCleanup() +} diff --git a/tests/tests/src/try_finally_test.mjs b/tests/tests/src/try_finally_test.mjs new file mode 100644 index 0000000000..7fcb6e7aa9 --- /dev/null +++ b/tests/tests/src/try_finally_test.mjs @@ -0,0 +1,129 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Primitive_exceptions from "@rescript/runtime/lib/es6/Primitive_exceptions.js"; + +let TestError = /* @__PURE__ */Primitive_exceptions.create("Try_finally_test.TestError"); + +function testFinallyBasic() { + try { + return 2; + } catch (exn) { + return 0; + } finally { + console.log("Finally executed!"); + } +} + +function testFinallyWithException() { + try { + throw { + RE_EXN_ID: TestError, + Error: new Error() + }; + } catch (raw_exn) { + let exn = Primitive_exceptions.internalToException(raw_exn); + if (exn.RE_EXN_ID === TestError) { + return 1; + } + throw exn; + } finally { + console.log("Finally with exception executed!"); + } +} + +function testFinallyWithoutCatch() { + try { + return 42; + } catch (exn) { + return 0; + } finally { + console.log("Finally without catch executed!"); + } +} + +function testFinallyWithAssignment() { + let x; + try { + x = 42; + } catch (exn) { + x = 0; + } finally { + console.log("Finally with assignment executed!"); + } + console.log(x); +} + +function testSingleLineFinally() { + try { + return 2; + } catch (exn) { + return 0; + } finally { + console.log("Single line!"); + } +} + +function testMultiLineFinally() { + try { + throw { + RE_EXN_ID: TestError, + Error: new Error() + }; + } catch (raw_exn) { + let exn = Primitive_exceptions.internalToException(raw_exn); + if (exn.RE_EXN_ID === TestError) { + return 1; + } + throw exn; + } finally { + console.log("Line 1"); + console.log("Line 2"); + console.log("Line 3"); + } +} + +function testTryFinallyWithoutCatch() { + try { + console.log("Doing operation"); + return 42; + } finally { + console.log("Finally without catch executed!"); + } +} + +function testTryFinallyWithoutCatchWithException() { + try { + console.log("About to throw"); + throw { + RE_EXN_ID: TestError, + Error: new Error() + }; + } finally { + console.log("Finally without catch with exception executed!"); + } +} + +function testTryFinallyWithoutCatchAssignment() { + let x; + try { + console.log("Getting value"); + x = 42; + } finally { + console.log("Finally without catch with assignment executed!"); + } + console.log(x); +} + +export { + TestError, + testFinallyBasic, + testFinallyWithException, + testFinallyWithoutCatch, + testFinallyWithAssignment, + testSingleLineFinally, + testMultiLineFinally, + testTryFinallyWithoutCatch, + testTryFinallyWithoutCatchWithException, + testTryFinallyWithoutCatchAssignment, +} +/* No side effect */ diff --git a/tests/tests/src/try_finally_test.res b/tests/tests/src/try_finally_test.res new file mode 100644 index 0000000000..734515d785 --- /dev/null +++ b/tests/tests/src/try_finally_test.res @@ -0,0 +1,98 @@ +// Basic finally block test + +exception TestError + +let testFinallyBasic = () => { + try { + 1 + 1 + } catch { + | _ => 0 + } finally { + Console.log("Finally executed!") + } +} + +let testFinallyWithException = () => { + try { + throw(TestError) + } catch { + | TestError => 1 + } finally { + Console.log("Finally with exception executed!") + } +} + +let testFinallyWithoutCatch = () => { + try { + 42 + } catch { + | _ => 0 + } finally { + Console.log("Finally without catch executed!") + } +} + +let testFinallyWithAssignment = () => { + let x = try { + 42 + } catch { + | _ => 0 + } finally { + Console.log("Finally with assignment executed!") + } + + Console.log(x) +} + +// Test single-line finally block +let testSingleLineFinally = () => { + try { + 1 + 1 + } catch { + | _ => 0 + } finally Console.log("Single line!") +} + +// Test multi-line finally block +let testMultiLineFinally = () => { + try { + throw(TestError) + } catch { + | TestError => 1 + } finally { + Console.log("Line 1") + Console.log("Line 2") + Console.log("Line 3") + } +} + +// Test try..finally without catch +let testTryFinallyWithoutCatch = () => { + try { + Console.log("Doing operation") + 42 + } finally { + Console.log("Finally without catch executed!") + } +} + +let testTryFinallyWithoutCatchWithException = () => { + try { + Console.log("About to throw") + throw(TestError) + } finally { + Console.log("Finally without catch with exception executed!") + } +} + +// Test try..finally without catch with assignment +let testTryFinallyWithoutCatchAssignment = () => { + let x = try { + Console.log("Getting value") + 42 + } finally { + Console.log("Finally without catch with assignment executed!") + } + + Console.log(x) +} From 3a221e5b7f00c57dc91fa0ff6753d1c3ca8cbb92 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 18 Sep 2025 18:03:44 +0200 Subject: [PATCH 2/5] AST mapping --- compiler/ml/ast_mapper_from0.ml | 19 +++++++- compiler/ml/ast_mapper_to0.ml | 11 ++++- .../data/ast-mapping/TryExpressions.res | 45 +++++++++++++++++++ .../expected/TryExpressions.res.txt | 45 +++++++++++++++++++ 4 files changed, 117 insertions(+), 3 deletions(-) create mode 100644 tests/syntax_tests/data/ast-mapping/TryExpressions.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/TryExpressions.res.txt diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index c5bd752964..a5dccd4d33 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -310,6 +310,20 @@ module E = struct | _ -> true) attrs + let extract_finally_attribute attrs = + List.find_map + (function + | {Location.txt = "res.finally"}, Pt.PPat (_, Some expr) -> Some expr + | _ -> None) + attrs + + let remove_finally_attribute attrs = + List.filter + (function + | {Location.txt = "res.finally"}, _ -> false + | _ -> true) + attrs + let map_jsx_children sub (e : expression) : Pt.jsx_children = let rec visit (e : expression) : Pt.expression list = match e.pexp_desc with @@ -460,8 +474,9 @@ module E = struct | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_try (e, pel) -> - try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - (Some (ident {txt = Longident.Lident "_"; loc})) + let finally_expr = extract_finally_attribute attrs in + let attrs = remove_finally_attribute attrs in + try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) finally_expr | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) (* <> *) | Pexp_construct ({txt = Longident.Lident "[]" | Longident.Lident "::"}, _) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index eb3fcceda6..d55ca574f3 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -419,7 +419,16 @@ module E = struct args) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel, _) -> + | Pexp_try (e, pel, finally_expr) -> + let attrs = + match finally_expr with + | Some expr -> + let finally_attr = + sub.attribute sub (Location.mknoloc "res.finally", Parsetree.PPat (Ast_helper.Pat.any (), Some expr)) + in + finally_attr :: attrs + | None -> attrs + in try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, arg) -> diff --git a/tests/syntax_tests/data/ast-mapping/TryExpressions.res b/tests/syntax_tests/data/ast-mapping/TryExpressions.res new file mode 100644 index 0000000000..5a9d1d110d --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/TryExpressions.res @@ -0,0 +1,45 @@ +// Test for try..catch (existing syntax) +let tryCatch = try { + Console.log("Trying") +} catch { +| _ => Console.log("Caught") +} + +// Test for try..finally (new syntax) +let tryFinally = try { + Console.log("Trying") +} finally { + Console.log("Finally") +} + +// Test for try..catch..finally (new syntax) +let tryCatchFinally = try { + Console.log("Trying") +} catch { +| _ => Console.log("Caught") +} finally { + Console.log("Finally") +} + +// Test with complex expressions +let complexTry = try { + let x = 1 + 2 + let y = x * 3 + Some(y) +} catch { +| Not_found => None +| exn => Console.log("Error: " ++ Js.String.make(exn)) +} + +// Test nested try expressions +let nestedTry = try { + try { + dangerousOperation() + } catch { + | InnerError => Console.log("Inner caught") + } +} catch { +| OuterError => Console.log("Outer caught") +} finally { + Console.log("Outer finally") +} diff --git a/tests/syntax_tests/data/ast-mapping/expected/TryExpressions.res.txt b/tests/syntax_tests/data/ast-mapping/expected/TryExpressions.res.txt new file mode 100644 index 0000000000..5a9d1d110d --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/TryExpressions.res.txt @@ -0,0 +1,45 @@ +// Test for try..catch (existing syntax) +let tryCatch = try { + Console.log("Trying") +} catch { +| _ => Console.log("Caught") +} + +// Test for try..finally (new syntax) +let tryFinally = try { + Console.log("Trying") +} finally { + Console.log("Finally") +} + +// Test for try..catch..finally (new syntax) +let tryCatchFinally = try { + Console.log("Trying") +} catch { +| _ => Console.log("Caught") +} finally { + Console.log("Finally") +} + +// Test with complex expressions +let complexTry = try { + let x = 1 + 2 + let y = x * 3 + Some(y) +} catch { +| Not_found => None +| exn => Console.log("Error: " ++ Js.String.make(exn)) +} + +// Test nested try expressions +let nestedTry = try { + try { + dangerousOperation() + } catch { + | InnerError => Console.log("Inner caught") + } +} catch { +| OuterError => Console.log("Outer caught") +} finally { + Console.log("Outer finally") +} From 3cd436fd351efdc72599abe6c1b113fbb880a083 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 18 Sep 2025 18:13:11 +0200 Subject: [PATCH 3/5] Format --- compiler/ml/ast_mapper_to0.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index d55ca574f3..2942782b2c 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -424,7 +424,9 @@ module E = struct match finally_expr with | Some expr -> let finally_attr = - sub.attribute sub (Location.mknoloc "res.finally", Parsetree.PPat (Ast_helper.Pat.any (), Some expr)) + sub.attribute sub + ( Location.mknoloc "res.finally", + Parsetree.PPat (Ast_helper.Pat.any (), Some expr) ) in finally_attr :: attrs | None -> attrs From 25f2b860cb40359bce52c79d2083ef9b5a0e1e79 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 18 Sep 2025 19:08:31 +0200 Subject: [PATCH 4/5] Fix analysis test --- analysis/reanalyze/src/Arnold.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index 51e9635c8f..34e78e860e 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -970,9 +970,11 @@ module Compile = struct | Texp_try (e, cases, finally_expr) -> let cE = e |> expression ~ctx in let cCases = cases |> List.map (case ~ctx) |> Command.nondet in - let cFinally = finally_expr |> expressionOpt ~ctx in let open Command in - cE +++ cCases +++ cFinally + begin match finally_expr with + | Some finally -> cE +++ cCases +++ (finally |> expression ~ctx) + | None -> cE +++ cCases + end | Texp_variant (_label, eOpt) -> eOpt |> expressionOpt ~ctx | Texp_while _ -> notImplemented "Texp_while"; From 4eb58f65dc4977f8d7e75dc05ee19b0acf1b4df8 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 18 Sep 2025 19:14:48 +0200 Subject: [PATCH 5/5] Format --- analysis/reanalyze/src/Arnold.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index 34e78e860e..02c2c7ec7f 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -967,14 +967,13 @@ module Compile = struct | Texp_tuple expressions | Texp_array expressions -> expressions |> List.map (expression ~ctx) |> Command.unorderedSequence | Texp_assert _ -> Command.nothing - | Texp_try (e, cases, finally_expr) -> + | Texp_try (e, cases, finally_expr) -> ( let cE = e |> expression ~ctx in let cCases = cases |> List.map (case ~ctx) |> Command.nondet in let open Command in - begin match finally_expr with + match finally_expr with | Some finally -> cE +++ cCases +++ (finally |> expression ~ctx) - | None -> cE +++ cCases - end + | None -> cE +++ cCases) | Texp_variant (_label, eOpt) -> eOpt |> expressionOpt ~ctx | Texp_while _ -> notImplemented "Texp_while";