From 20288bcb260600684f996035f97f936636f8847a Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Sat, 13 Apr 2024 11:02:14 +0200 Subject: [PATCH] Protect the interpreter against exceptions from custom code --- compiler/lcalc/to_ocaml.ml | 2 +- compiler/scalc/to_c.ml | 2 +- compiler/scalc/to_python.ml | 2 +- compiler/scalc/to_r.ml | 4 ++-- compiler/shared_ast/definitions.ml | 2 +- compiler/shared_ast/interpreter.ml | 27 +++++++++++++++------------ compiler/shared_ast/print.ml | 2 +- 7 files changed, 22 insertions(+), 19 deletions(-) diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 2b99f283..79d75451 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -270,7 +270,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) | EmptyError -> Format.fprintf fmt "EmptyError" - | Crash -> Format.fprintf fmt "Crash" + | Crash s -> Format.fprintf fmt "(Crash %S)" s | NoValueProvided -> let pos = Mark.get exc in Format.fprintf fmt diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 83a53429..85db04b7 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -455,7 +455,7 @@ let rec format_statement | ConflictError _ -> "catala_conflict" | EmptyError -> "catala_empty" | NoValueProvided -> "catala_no_value_provided" - | Crash -> "catala_crash") + | Crash _ -> "catala_crash") (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) | SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } -> diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index 0e9f4c97..4d404581 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -259,7 +259,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) | EmptyError -> Format.fprintf fmt "EmptyError" - | Crash -> Format.fprintf fmt "Crash" + | Crash _ -> Format.fprintf fmt "Crash" | NoValueProvided -> Format.fprintf fmt "NoValueProvided(@[SourcePosition(@[filename=\"%s\",@ \ diff --git a/compiler/scalc/to_r.ml b/compiler/scalc/to_r.ml index 1b13f883..b7f1bc98 100644 --- a/compiler/scalc/to_r.ml +++ b/compiler/scalc/to_r.ml @@ -265,7 +265,7 @@ let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) | EmptyError -> Format.fprintf fmt "catala_empty_error()" - | Crash -> Format.fprintf fmt "catala_crash()" + | Crash _ -> Format.fprintf fmt "catala_crash()" | NoValueProvided -> Format.fprintf fmt "catala_no_value_provided_error(@[catala_position(@[ Format.fprintf fmt "catala_conflict_error" | EmptyError -> Format.fprintf fmt "catala_empty_error" - | Crash -> Format.fprintf fmt "catala_crash" + | Crash _ -> Format.fprintf fmt "catala_crash" | NoValueProvided -> Format.fprintf fmt "catala_no_value_provided_error" let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index 20d8142f..7e07b224 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -382,7 +382,7 @@ type except = | ConflictError of Pos.t list | EmptyError | NoValueProvided - | Crash + | Crash of string (** {2 Markings} *) diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 7eee0559..ae011b4f 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -663,16 +663,21 @@ let rec evaluate_expr : Message.error ~pos "wrong function call, expected %d arguments, got %d" (Bindlib.mbinder_arity binder) (List.length args) - | ECustom { obj; targs; tret } -> + | ECustom { obj; targs; tret } -> ( (* Applies the arguments one by one to the curried form *) - List.fold_left2 - (fun fobj targ arg -> - (Obj.obj fobj : Obj.t -> Obj.t) - (val_to_runtime (fun ctx -> evaluate_expr ctx lang) ctx targ arg)) - obj targs args - |> Obj.obj - |> fun o -> - runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o + match + List.fold_left2 + (fun fobj targ arg -> + (Obj.obj fobj : Obj.t -> Obj.t) + (val_to_runtime (fun ctx -> evaluate_expr ctx lang) ctx targ arg)) + obj targs args + with + | exception e -> + Format.ksprintf + (fun s -> raise (CatalaException (Crash s, pos))) + "@[This call to code from a module failed with:@ %s@]" + (Printexc.to_string e) + | o -> runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o) | _ -> Message.error ~pos "%a" Format.pp_print_text "function has not been reduced to a lambda at evaluation (should not \ @@ -927,9 +932,7 @@ let interp_failure_message ~pos = function "%a" Format.pp_print_text "There is a conflict between multiple valid consequences for assigning \ the same variable." - | Crash -> - (* This constructor seems to be never used *) - Message.error ~pos ~internal:true "The interpreter crashed" + | Crash s -> Message.error ~pos "%s" s | EmptyError -> Message.error ~pos ~internal:true "A variable without valid definition escaped" diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index d819c236..bdbe23c6 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -350,7 +350,7 @@ let except (fmt : Format.formatter) (exn : except) : unit = (match exn with | EmptyError -> "EmptyError" | ConflictError _ -> "ConflictError" - | Crash -> "Crash" + | Crash s -> Printf.sprintf "Crash %S" s | NoValueProvided -> "NoValueProvided") let var_debug fmt v =