Protect the interpreter against exceptions from custom code

CatalaLang · Apr 13, 2024 · e261854 · e261854
1 parent 5634961
commit e261854
Show file tree

Hide file tree

Showing 7 changed files with 22 additions and 19 deletions.
diff --git 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
@@ -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
@@ -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(@[<hov 0>SourcePosition(@[<hov 0>filename=\"%s\",@ \

diff --git 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(@[<hov 0>catala_position(@[<hov \
@@ -279,7 +279,7 @@ let format_exception_name (fmt : Format.formatter) (exc : except) : unit =
   match exc with
   | ConflictError _ -> 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
@@ -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
@@ -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)))
+          "@[<hv 2>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
@@ -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 =