From 9d070158640380a4b4d37fa482f38028b5a483a4 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 26 Apr 2024 18:31:26 +0200 Subject: [PATCH] Unify runtime error handling - Clearly distinguish Exceptions from Errors. The only catchable exception available in our AST is `EmptyError`, so the corresponding nodes are made less generic, and a node `FatalError` is added - Runtime errors are defined as a specific type in the OCaml runtime, with a carrier exception and printing functions. These are used throughout, and consistently by the interpreter. They always carry a position, that can be converted to be printed with the fancy compiler location printer, or in a simpler way from the backends. - All operators that might be subject to an error take a position as argument, in order to print an informative message without relying on backtraces from the backend --- compiler/dcalc/from_scopelang.ml | 6 +- compiler/desugared/ast.ml | 2 +- compiler/desugared/from_surface.ml | 12 +- compiler/lcalc/closure_conversion.ml | 7 +- compiler/lcalc/compile_with_exceptions.ml | 6 +- compiler/lcalc/compile_without_exceptions.ml | 10 +- compiler/lcalc/to_ocaml.ml | 86 ++++++------ compiler/plugins/explain.ml | 14 +- compiler/plugins/lazy_interp.ml | 12 +- compiler/scalc/ast.ml | 5 +- compiler/scalc/from_lcalc.ml | 15 ++- compiler/scalc/print.ml | 11 +- compiler/scalc/to_c.ml | 16 +-- compiler/scalc/to_python.ml | 48 +++---- compiler/scalc/to_r.ml | 53 +++----- compiler/scopelang/from_desugared.ml | 12 +- compiler/shared_ast/definitions.ml | 8 +- compiler/shared_ast/expr.ml | 105 ++++++++++----- compiler/shared_ast/expr.mli | 12 +- compiler/shared_ast/interpreter.ml | 126 +++++++++--------- compiler/shared_ast/optimizations.ml | 13 +- compiler/shared_ast/print.ml | 31 +++-- compiler/shared_ast/print.mli | 1 + compiler/shared_ast/typing.ml | 11 +- compiler/verification/conditions.ml | 4 +- compiler/verification/z3backend.real.ml | 5 +- doc/syntax/syntax_en.catala_en | 4 +- doc/syntax/syntax_fr.catala_fr | 4 +- runtimes/c/runtime.c | 14 +- runtimes/jsoo/runtime.ml | 20 +-- runtimes/ocaml/runtime.ml | 124 +++++++++-------- runtimes/ocaml/runtime.mli | 58 ++++---- .../arithmetic/bad/division_by_zero.catala_en | 44 +----- tests/backends/output/simple.c | 8 +- tests/backends/python_name_clash.catala_en | 26 ++-- .../date/bad/uncomparable_duration.catala_en | 72 ++++------ .../good/closure_conversion_reduce.catala_en | 2 +- .../scope_call_func_struct_closure.catala_en | 2 +- tests/modules/good/output/mod_def.ml | 57 ++++---- tests/modules/good/prorata_external.ml | 6 +- tests/name_resolution/good/let_in2.catala_en | 40 +++--- .../good/toplevel_defs.catala_en | 100 +++++++------- tests/scope/good/nothing.catala_en | 2 +- tests/scope/good/simple.catala_en | 4 +- 44 files changed, 602 insertions(+), 616 deletions(-) diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index 926873b8..6007c506 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -264,7 +264,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed = ( var_ctx.scope_input_name, Expr.make_abs [| Var.make "_" |] - (Expr.eemptyerror (Expr.with_ty m ty0)) + (Expr.eempty (Expr.with_ty m ty0)) [TAny, iopos] pos ) | Some var_ctx, Some e -> @@ -569,8 +569,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed = let args = List.map (translate_expr ctx) args in Expr.eappop ~op:(Add_dat_dur ctx.date_rounding) ~args ~tys m | ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _ - | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | EArray _ - | EIfThenElse _ | EAppOp _ ) as e -> + | ETupleAccess _ | EInj _ | EFatalError _ | EEmpty | EErrorOnEmpty _ + | EArray _ | EIfThenElse _ | EAppOp _ ) as e -> Expr.map ~f:(translate_expr ctx) ~op:Operator.translate (e, m) (** The result of a rule translation is a list of assignments, with variables diff --git a/compiler/desugared/ast.ml b/compiler/desugared/ast.ml index d89fdc75..9ac16a16 100644 --- a/compiler/desugared/ast.ml +++ b/compiler/desugared/ast.ml @@ -187,7 +187,7 @@ let empty_rule (parameters : (Uid.MarkedString.info * typ) list Mark.pos option) : rule = { rule_just = Expr.box (ELit (LBool false), Untyped { pos }); - rule_cons = Expr.box (EEmptyError, Untyped { pos }); + rule_cons = Expr.box (EEmpty, Untyped { pos }); rule_parameter = Option.map (Mark.map (List.map (fun (lbl, typ) -> Mark.map Var.make lbl, typ))) diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index e700503d..069a2667 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -330,12 +330,18 @@ let rec translate_expr match l with | LNumber ((Int i, _), None) -> LInt (Runtime.integer_of_string i) | LNumber ((Int i, _), Some (Percent, _)) -> - LRat Runtime.(Oper.o_div_rat_rat (decimal_of_string i) rat100) + LRat + Runtime.( + Oper.o_div_rat_rat (Expr.pos_to_runtime pos) (decimal_of_string i) + rat100) | LNumber ((Dec (i, f), _), None) -> LRat Runtime.(decimal_of_string (i ^ "." ^ f)) | LNumber ((Dec (i, f), _), Some (Percent, _)) -> LRat - Runtime.(Oper.o_div_rat_rat (decimal_of_string (i ^ "." ^ f)) rat100) + Runtime.( + Oper.o_div_rat_rat (Expr.pos_to_runtime pos) + (decimal_of_string (i ^ "." ^ f)) + rat100) | LBool b -> LBool b | LMoneyAmount i -> LMoney @@ -366,7 +372,7 @@ let rec translate_expr (try Runtime.date_of_numbers date.literal_date_year date.literal_date_month date.literal_date_day - with Runtime.ImpossibleDate -> + with Dates_calc.Dates.InvalidDate -> Message.error ~pos "There is an error in this date, it does not correspond to a \ correct calendar day") diff --git a/compiler/lcalc/closure_conversion.ml b/compiler/lcalc/closure_conversion.ml index cd382296..2962654a 100644 --- a/compiler/lcalc/closure_conversion.ml +++ b/compiler/lcalc/closure_conversion.ml @@ -38,7 +38,8 @@ let rec transform_closures_expr : let m = Mark.get e in match Mark.remove e with | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _ - | ELit _ | EExternal _ | EAssert _ | EIfThenElse _ | ERaise _ | ECatch _ -> + | ELit _ | EExternal _ | EAssert _ | EFatalError _ | EIfThenElse _ + | ERaiseEmpty | ECatchEmpty _ -> Expr.map_gather ~acc:Var.Set.empty ~join:Var.Set.union ~f:(transform_closures_expr ctx) e @@ -538,8 +539,8 @@ let rec hoist_closures_expr : ], Expr.make_var closure_var m ) | EApp _ | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ - | EArray _ | ELit _ | EAssert _ | EAppOp _ | EIfThenElse _ | ERaise _ - | ECatch _ | EVar _ -> + | EArray _ | ELit _ | EAssert _ | EFatalError _ | EAppOp _ | EIfThenElse _ + | ERaiseEmpty | ECatchEmpty _ | EVar _ -> Expr.map_gather ~acc:[] ~join:( @ ) ~f:(hoist_closures_expr name_context) e | EExternal _ -> failwith "unimplemented" | _ -> . diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml index 80621ff5..b23d6644 100644 --- a/compiler/lcalc/compile_with_exceptions.ml +++ b/compiler/lcalc/compile_with_exceptions.ml @@ -71,10 +71,10 @@ let rec translate_default and translate_expr (e : 'm D.expr) : 'm A.expr boxed = match e with - | EEmptyError, m -> Expr.eraise Empty (translate_mark m) + | EEmpty, m -> Expr.eraiseempty (translate_mark m) | EErrorOnEmpty arg, m -> let m = translate_mark m in - Expr.ecatch (translate_expr arg) Empty (Expr.eraise NoValueProvided m) m + Expr.ecatchempty (translate_expr arg) (Expr.efatalerror Runtime.NoValue m) m | EDefault { excepts; just; cons }, m -> translate_default excepts just cons (translate_mark m) | EPureDefault e, _ -> translate_expr e @@ -85,7 +85,7 @@ and translate_expr (e : 'm D.expr) : 'm A.expr boxed = (translate_mark m) | ( ( ELit _ | EArray _ | EVar _ | EAbs _ | EApp _ | EExternal _ | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _ - | EStruct _ | EStructAccess _ | EMatch _ ), + | EFatalError _ | EStruct _ | EStructAccess _ | EMatch _ ), _ ) as e -> Expr.map ~f:translate_expr ~typ:translate_typ e | _ -> . diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 8779fd50..8305b35b 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/compiler/lcalc/compile_without_exceptions.ml @@ -83,7 +83,7 @@ let rec translate_default and translate_expr (e : 'm D.expr) : 'm A.expr boxed = match e with - | EEmptyError, m -> + | EEmpty, m -> let m = translate_mark m in let pos = Expr.mark_pos m in Expr.einj @@ -97,10 +97,8 @@ and translate_expr (e : 'm D.expr) : 'm A.expr boxed = [ ( Expr.none_constr, let x = Var.make "_" in - Expr.make_abs [| x |] - (Expr.eraise NoValueProvided m) - [TAny, pos] - pos ); + Expr.make_abs [| x |] (Expr.efatalerror NoValue m) [TAny, pos] pos + ); (* | None x -> raise NoValueProvided *) Expr.some_constr, Expr.fun_id ~var_name:"arg" m (* | Some x -> x *); ] @@ -118,7 +116,7 @@ and translate_expr (e : 'm D.expr) : 'm A.expr boxed = (translate_mark m) | ( ( ELit _ | EArray _ | EVar _ | EApp _ | EAbs _ | EExternal _ | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _ - | EStruct _ | EStructAccess _ | EMatch _ ), + | EFatalError _ | EStruct _ | EStructAccess _ | EMatch _ ), _ ) as e -> Expr.map ~f:translate_expr ~typ:translate_typ e | _ -> . diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index d99312d2..f9157cd0 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -19,6 +19,24 @@ open Shared_ast open Ast module D = Dcalc.Ast +let format_string_list (fmt : Format.formatter) (uids : string list) : unit = + let sanitize_quotes = Re.compile (Re.char '"') in + Format.fprintf fmt "@[[%a]@]" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") + (fun fmt info -> + Format.fprintf fmt "\"%s\"" + (Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info))) + uids + +let format_pos ppf pos = + Format.fprintf ppf + "@[{filename=%S;@ start_line=%d; start_column=%d;@ end_line=%d; \ + end_column=%d;@ law_headings=%a}@]" + (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) + (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list + (Pos.get_law_info pos) + let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit = match Mark.remove l with | LBool b -> Print.lit fmt (LBool b) @@ -47,16 +65,6 @@ let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) Format.fprintf fmt "\"%a\"" Uid.MarkedString.format info)) uids -let format_string_list (fmt : Format.formatter) (uids : string list) : unit = - let sanitize_quotes = Re.compile (Re.char '"') in - Format.fprintf fmt "@[[%a]@]" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") - (fun fmt info -> - Format.fprintf fmt "\"%s\"" - (Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info))) - uids - (* list taken from http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#sss:keywords *) let ocaml_keywords = @@ -261,24 +269,11 @@ let needs_parens (e : 'm expr) : bool = let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = match Mark.remove exc with | ConflictError _ -> - let pos = Mark.get exc in - Format.fprintf fmt - "(ConflictError@ @[{filename = \"%s\";@\n\ - start_line=%d;@ start_column=%d;@ end_line=%d; end_column=%d;@ \ - law_headings=%a}@])" - (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list - (Pos.get_law_info pos) + Format.fprintf fmt "(ConflictError@ %a)" format_pos (Mark.get exc) | Empty -> Format.fprintf fmt "Empty" | Crash s -> Format.fprintf fmt "(Crash %S)" s | NoValueProvided -> - let pos = Mark.get exc in - Format.fprintf fmt - "(NoValueProvided@ @[{filename = \"%s\";@ start_line=%d;@ \ - start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@])" - (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list - (Pos.get_law_info pos) + Format.fprintf fmt "(NoValueProvided@ %a)" format_pos (Mark.get exc) let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : unit = @@ -424,13 +419,9 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : Format.fprintf fmt "%a" format_with_parens arg1 | EAppOp { op = (HandleDefault | HandleDefaultOpt) as op; args; _ } -> let pos = Expr.pos e in - Format.fprintf fmt - "@[%s@ @[{filename = \"%s\";@ start_line=%d;@ \ - start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a@]" + Format.fprintf fmt "@[%s@ %a@ %a@]" (Print.operator_to_string op) - (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list - (Pos.get_law_info pos) + format_pos pos (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens) @@ -446,30 +437,33 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : "@[ if@ @[%a@]@ then@ @[%a@]@ else@ @[%a@]@]" format_with_parens cond format_with_parens etrue format_with_parens efalse | EAppOp { op; args; _ } -> - Format.fprintf fmt "@[%s@ %a@]" (Operator.name op) + Format.fprintf fmt "@[%s@ %t%a@]" (Operator.name op) + (fun ppf -> + match op with + | Map2 | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat + | Div_dur_dur | Lt_dur_dur | Lte_dur_dur | Gt_dur_dur | Gte_dur_dur + | Eq_dur_dur -> + Format.fprintf ppf "%a@ " format_pos (Expr.pos e) + | _ -> ()) (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens) args | EAssert e' -> Format.fprintf fmt - "@[if@ %a@ then@ ()@ else@ raise (AssertionFailed @[{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ end_line=%d; \ - end_column=%d;@ law_headings=%a}@])@]" + "@[if@ %a@ then@ ()@ else@ raise (Error (%s, %a))@]" format_with_parens e' - (Pos.get_file (Expr.pos e')) - (Pos.get_start_line (Expr.pos e')) - (Pos.get_start_column (Expr.pos e')) - (Pos.get_end_line (Expr.pos e')) - (Pos.get_end_column (Expr.pos e')) - format_string_list - (Pos.get_law_info (Expr.pos e')) - | ERaise exc -> - Format.fprintf fmt "raise@ %a" format_exception (exc, Expr.pos e) - | ECatch { body; exn; handler } -> + Runtime.(error_to_string AssertionFailed) + format_pos (Expr.pos e') + | EFatalError er -> + Format.fprintf fmt "raise@ (Runtime_ocaml.Runtime.Error (%a, %a))" + Print.runtime_error er format_pos (Expr.pos e) + | ERaiseEmpty -> + Format.fprintf fmt "raise@ %a" format_exception (Empty, Expr.pos e) + | ECatchEmpty { body; handler } -> Format.fprintf fmt "@[@[try@ %a@]@ with@]@ @[%a@ ->@ %a@]" format_with_parens body format_exception - (exn, Expr.pos e) + (Empty, Expr.pos e) format_with_parens handler | _ -> . diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index 9cb4ba76..81dfe225 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -294,7 +294,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t log "@]}"; e, env | e, _ -> error e "Invalid apply on %a" Expr.format e) - | (EAbs _ | ELit _ | EEmptyError), _ -> e0, env (* these are values *) + | (EAbs _ | ELit _ | EEmpty), _ -> e0, env (* these are values *) | (EStruct _ | ETuple _ | EInj _ | EArray _), _ -> if not llevel.eval_struct then e0, env else @@ -348,7 +348,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t List.filter_map (fun e -> match eval_to_value env e ~eval_default:false with - | (EEmptyError, _), _ -> None + | (EEmpty, _), _ -> None | e -> Some e) excepts in @@ -359,7 +359,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t let condition = just, env in let e, env = lazy_eval ctx env llevel cons in add_condition ~condition e, env - | (ELit (LBool false), _), _ -> (EEmptyError, m), env + | (ELit (LBool false), _), _ -> (EEmpty, m), env (* Note: conditions for empty are skipped *) | e, _ -> error e "Invalid exception justification %a" Expr.format e) | [(e, env)] -> @@ -387,7 +387,7 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t | e, _ -> error e "Invalid condition %a" Expr.format e) | EErrorOnEmpty e, _ -> ( match eval_to_value env e ~eval_default:false with - | ((EEmptyError, _) as e'), _ -> + | ((EEmpty, _) as e'), _ -> (* This does _not_ match the eager semantics ! *) error e' "This value is undefined %a" Expr.format e | e, env -> lazy_eval ctx env llevel e) @@ -400,6 +400,8 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t error e "Assert failure (%a)" Expr.format e error e "Assert failure (%a)" Expr.format e | _ -> error e "Invalid assertion condition %a" Expr.format e) + | EFatalError err, _ -> + error e0 "%a" Format.pp_print_text (Runtime.error_message err) | EExternal _, _ -> assert false (* todo *) | _ -> . @@ -1072,8 +1074,8 @@ let expr_to_dot_label0 : let bypass : type a t. Format.formatter -> (a, t) gexpr -> bool = fun ppf e -> match Mark.remove e with - | ELit _ | EArray _ | ETuple _ | EStruct _ | EInj _ | EEmptyError - | EAbs _ | EExternal _ -> + | ELit _ | EArray _ | ETuple _ | EStruct _ | EInj _ | EEmpty | EAbs _ + | EExternal _ -> aux_value ppf e; true | EMatch { e; cases; _ } -> diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index a0b22e66..8ae7826e 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -142,7 +142,7 @@ let rec lazy_eval : log "@]}"; e, env | e, _ -> error e "Invalid apply on %a" Expr.format e) - | (EAbs _ | ELit _ | EEmptyError), _ -> e0, env (* these are values *) + | (EAbs _ | ELit _ | EEmpty), _ -> e0, env (* these are values *) | (EStruct _ | ETuple _ | EInj _ | EArray _), _ -> if not llevel.eval_struct then e0, env else @@ -183,7 +183,7 @@ let rec lazy_eval : List.filter_map (fun e -> match eval_to_value env e ~eval_default:false with - | (EEmptyError, _), _ -> None + | (EEmpty, _), _ -> None | e -> Some e) excepts in @@ -191,7 +191,7 @@ let rec lazy_eval : | [] -> ( match eval_to_value env just with | (ELit (LBool true), _), _ -> lazy_eval ctx env llevel cons - | (ELit (LBool false), _), _ -> (EEmptyError, m), env + | (ELit (LBool false), _), _ -> (EEmpty, m), env | e, _ -> error e "Invalid exception justification %a" Expr.format e) | [(e, env)] -> log "@[EVAL %a@]" Expr.format e; @@ -208,7 +208,7 @@ let rec lazy_eval : | e, _ -> error e "Invalid condition %a" Expr.format e) | EErrorOnEmpty e, _ -> ( match eval_to_value env e ~eval_default:false with - | ((EEmptyError, _) as e'), _ -> + | ((EEmpty, _) as e'), _ -> (* This does _not_ match the eager semantics ! *) error e' "This value is undefined %a" Expr.format e | e, env -> lazy_eval ctx env llevel e) @@ -220,6 +220,8 @@ let rec lazy_eval : | (ELit (LBool false), _), _ -> error e "Assert failure (%a)" Expr.format e | _ -> error e "Invalid assertion condition %a" Expr.format e) + | EFatalError err, m -> + error e0 "%a" Format.pp_print_text (Runtime.error_message err) | EExternal _, _ -> assert false (* todo *) | _ -> . @@ -251,7 +253,7 @@ let interpret_program (prg : ('dcalc, 'm) gexpr program) (scope : ScopeName.t) : | TArrow (ty_in, ty_out), _ -> Expr.make_abs [| Var.make "_" |] - (Bindlib.box EEmptyError, Expr.with_ty m ty_out) + (Bindlib.box EEmpty, Expr.with_ty m ty_out) ty_in (Expr.mark_pos m) | ty -> Expr.evar (Var.make "undefined_input") (Expr.with_ty m ty)) (StructName.Map.find scope_arg_struct ctx.ctx_structs)) diff --git a/compiler/scalc/ast.ml b/compiler/scalc/ast.ml index 9d023772..b605f7d3 100644 --- a/compiler/scalc/ast.ml +++ b/compiler/scalc/ast.ml @@ -69,8 +69,9 @@ type stmt = | SLocalDecl of { name : VarName.t Mark.pos; typ : typ } | SLocalInit of { name : VarName.t Mark.pos; typ : typ; expr : expr } | SLocalDef of { name : VarName.t Mark.pos; expr : expr; typ : typ } - | STryExcept of { try_block : block; except : except; with_block : block } - | SRaise of except + | STryWEmpty of { try_block : block; with_block : block } + | SRaiseEmpty + | SFatalError of Runtime.error | SIfThenElse of { if_expr : expr; then_block : block; else_block : block } | SSwitch of { switch_expr : expr; diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index a36d8f9e..f4b0aa57 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -227,7 +227,8 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr = Expr.pos expr ) in RevBlock.empty, (EExternal { modname; name }, Expr.pos expr) - | ECatch _ | EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ | ERaise _ -> + | ECatchEmpty _ | EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ + | EFatalError _ | ERaiseEmpty -> raise (NotAnExpr { needs_a_local_decl = true }) | _ -> . with NotAnExpr { needs_a_local_decl } -> @@ -272,6 +273,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block = RevBlock.rebuild ~tail:[A.SAssert (Mark.remove new_e), Expr.pos block_expr] e_stmts + | EFatalError err -> [SFatalError err, Expr.pos block_expr] | EAppOp { op = Op.HandleDefaultOpt; tys = _; args = [exceptions; just; cons] } when ctxt.config.keep_special_ops -> @@ -481,15 +483,14 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block = }, Expr.pos block_expr ); ] - | ECatch { body; exn; handler } -> + | ECatchEmpty { body; handler } -> let s_e_try = translate_statements ctxt body in let s_e_catch = translate_statements ctxt handler in [ - ( A.STryExcept - { try_block = s_e_try; except = exn; with_block = s_e_catch }, + ( A.STryWEmpty { try_block = s_e_try; with_block = s_e_catch }, Expr.pos block_expr ); ] - | ERaise except -> + | ERaiseEmpty -> (* Before raising the exception, we still give a dummy definition to the current variable so that tools like mypy don't complain. *) (match ctxt.inside_definition_of with @@ -504,7 +505,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block = Expr.pos block_expr ); ] | _ -> []) - @ [A.SRaise except, Expr.pos block_expr] + @ [A.SRaiseEmpty, Expr.pos block_expr] | EInj { e = e1; cons; name } when ctxt.config.no_struct_literals -> let e1_stmts, new_e1 = translate_expr ctxt e1 in let tmp_struct_var_name = @@ -572,7 +573,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block = let e_stmts, new_e = translate_expr ctxt block_expr in let tail = match (e_stmts :> (A.stmt * Pos.t) list) with - | (A.SRaise _, _) :: _ -> + | (A.SRaiseEmpty, _) :: _ -> (* if the last statement raises an exception, then we don't need to return or to define the current variable since this code will be unreachable *) diff --git a/compiler/scalc/print.ml b/compiler/scalc/print.ml index 6c0c9069..1a8a6e89 100644 --- a/compiler/scalc/print.ml +++ b/compiler/scalc/print.ml @@ -137,16 +137,19 @@ let rec format_statement Print.punctuation "=" (format_expr decl_ctx ~debug) naked_expr - | STryExcept { try_block = b_try; except; with_block = b_with } -> + | STryWEmpty { try_block = b_try; with_block = b_with } -> Format.fprintf fmt "@[%a%a@ %a@]@\n@[%a %a%a@ %a@]" Print.keyword "try" Print.punctuation ":" (format_block decl_ctx ~debug) - b_try Print.keyword "with" Print.except except Print.punctuation ":" + b_try Print.keyword "with" Print.except Empty Print.punctuation ":" (format_block decl_ctx ~debug) b_with - | SRaise except -> + | SRaiseEmpty -> Format.fprintf fmt "@[%a %a@]" Print.keyword "raise" Print.except - except + Empty + | SFatalError err -> + Format.fprintf fmt "@[%a %a@]" Print.keyword "fatal" + Print.runtime_error err | SIfThenElse { if_expr = e_if; then_block = b_true; else_block = b_false } -> Format.fprintf fmt "@[%a @[%a@]%a@ %a@ @]@[%a%a@ %a@]" Print.keyword "if" diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 3b8266ff..a308e88c 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -402,8 +402,8 @@ let rec format_statement (s : stmt Mark.pos) : unit = match Mark.remove s with | SInnerFuncDef _ -> - Message.error ~pos:(Mark.get s) - "Internal error: this inner functions should have been hoisted in Scalc" + Message.error ~pos:(Mark.get s) ~internal:true + "This inner functions should have been hoisted in Scalc" | SLocalDecl { name = v; typ = ty } -> Format.fprintf fmt "@[%a@];" (format_typ ctx (fun fmt -> format_var fmt (Mark.remove v))) @@ -440,22 +440,18 @@ let rec format_statement | SLocalDef { name = v; expr = e; _ } -> Format.fprintf fmt "@[%a = %a;@]" format_var (Mark.remove v) (format_expression ctx) e - | STryExcept _ -> failwith "should not happen" - | SRaise e -> + | SRaiseEmpty | STryWEmpty _ -> assert false + | SFatalError err -> let pos = Mark.get s in Format.fprintf fmt - "catala_fatal_error_raised.code = %s;@,\ + "catala_fatal_error_raised.code = catala_%s;@,\ catala_fatal_error_raised.position.filename = \"%s\";@,\ catala_fatal_error_raised.position.start_line = %d;@,\ catala_fatal_error_raised.position.start_column = %d;@,\ catala_fatal_error_raised.position.end_line = %d;@,\ catala_fatal_error_raised.position.end_column = %d;@,\ longjmp(catala_fatal_error_jump_buffer, 0);" - (match e with - | ConflictError _ -> "catala_conflict" - | Empty -> "catala_empty" - | NoValueProvided -> "catala_no_value_provided" - | Crash _ -> "catala_crash") + (String.to_snake_case (Runtime.error_to_string err)) (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 4c33a124..168f4d9c 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -247,27 +247,20 @@ let format_func_name (fmt : Format.formatter) (v : FuncName.t) : unit = let v_str = Mark.remove (FuncName.get_info v) in format_name_cleaned fmt v_str -let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = - let pos = Mark.get exc in - match Mark.remove exc with - | ConflictError _ -> - Format.fprintf fmt - "ConflictError(@[SourcePosition(@[filename=\"%s\",@ \ - start_line=%d,@ start_column=%d,@ end_line=%d,@ end_column=%d,@ \ - law_headings=%a)@])@]" - (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list - (Pos.get_law_info pos) - | Empty -> Format.fprintf fmt "Empty" - | Crash _ -> Format.fprintf fmt "Crash" - | NoValueProvided -> - Format.fprintf fmt - "NoValueProvided(@[SourcePosition(@[filename=\"%s\",@ \ - start_line=%d,@ start_column=%d,@ end_line=%d,@ end_column=%d,@ \ - law_headings=%a)@])@]" - (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list - (Pos.get_law_info pos) +let format_position ppf pos = + Format.fprintf ppf + "@[SourcePosition(@,\ + filename=\"%s\",@ start_line=%d, start_column=%d,@ end_line=%d, \ + end_column=%d,@ law_headings=%a@;\ + <0 -4>)@]" (Pos.get_file pos) (Pos.get_start_line pos) + (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) + format_string_list (Pos.get_law_info pos) + +let format_error (ppf : Format.formatter) (err : Runtime.error Mark.pos) : unit + = + let pos = Mark.get err in + let tag = Runtime.error_to_string (Mark.remove err) in + Format.fprintf ppf "%s(%a)" tag format_position pos let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit = match Mark.remove e with @@ -423,13 +416,12 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit -> Format.fprintf fmt "@[%a = %a@]" format_var (Mark.remove v) (format_expression ctx) e - | STryExcept { try_block = try_b; except; with_block = catch_b } -> - Format.fprintf fmt "@[try:@\n%a@]@\n@[except %a:@\n%a@]" - (format_block ctx) try_b format_exception (except, Pos.no_pos) - (format_block ctx) catch_b - | SRaise except -> - Format.fprintf fmt "@[raise %a@]" format_exception - (except, Mark.get s) + | STryWEmpty { try_block = try_b; with_block = catch_b } -> + Format.fprintf fmt "@[try:@,%a@]@\n@[except Empty:@,%a@]" + (format_block ctx) try_b (format_block ctx) catch_b + | SRaiseEmpty -> Format.fprintf fmt "raise Empty" + | SFatalError err -> + Format.fprintf fmt "@[raise %a@]" format_error (err, Mark.get s) | SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } -> Format.fprintf fmt "@[if %a:@\n%a@]@\n@[else:@\n%a@]" (format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2 diff --git a/compiler/scalc/to_r.ml b/compiler/scalc/to_r.ml index 17760f84..00224a81 100644 --- a/compiler/scalc/to_r.ml +++ b/compiler/scalc/to_r.ml @@ -253,34 +253,20 @@ let format_func_name (fmt : Format.formatter) (v : FuncName.t) : unit = let v_str = Mark.remove (FuncName.get_info v) in format_name_cleaned fmt v_str -let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit = - let pos = Mark.get exc in - match Mark.remove exc with - | ConflictError _ -> - Format.fprintf fmt - "catala_conflict_error(@[catala_position(@[filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \ - end_column=%d,@ law_headings=%a)@])@]" - (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list - (Pos.get_law_info pos) - | Empty -> Format.fprintf fmt "catala_empty_error()" - | Crash _ -> Format.fprintf fmt "catala_crash()" - | NoValueProvided -> - Format.fprintf fmt - "catala_no_value_provided_error(@[catala_position(@[filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \ - end_column=%d,@ law_headings=%a)@])@]" - (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list - (Pos.get_law_info pos) +let format_position ppf pos = + Format.fprintf ppf + "@[catala_position(@,\ + filename=\"%s\",@ start_line=%d, start_column=%d,@ end_line=%d, \ + end_column=%d,@ law_headings=%a@;\ + <0 -2>)@]" (Pos.get_file pos) (Pos.get_start_line pos) + (Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos) + format_string_list (Pos.get_law_info pos) -let format_exception_name (fmt : Format.formatter) (exc : except) : unit = - match exc with - | ConflictError _ -> Format.fprintf fmt "catala_conflict_error" - | Empty -> Format.fprintf fmt "catala_empty" - | Crash _ -> Format.fprintf fmt "catala_crash" - | NoValueProvided -> Format.fprintf fmt "catala_no_value_provided_error" +let format_error (ppf : Format.formatter) (err : Runtime.error Mark.pos) : unit + = + let pos = Mark.get err in + let tag = String.to_snake_case (Runtime.error_to_string (Mark.remove err)) in + Format.fprintf ppf "%s(%a)" tag format_position pos let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : unit = @@ -409,20 +395,19 @@ let rec format_statement -> Format.fprintf fmt "@[%a <- %a@]" format_var (Mark.remove v) (format_expression ctx) e - | STryExcept { try_block = try_b; except; with_block = catch_b } -> + | STryWEmpty { try_block = try_b; with_block = catch_b } -> Format.fprintf fmt (* TODO escape dummy__arg*) "@[tryCatch(@[{@;\ %a@;\ }@],@;\ - %a = function(dummy__arg) @[{@;\ + catala_empty_error() = function(dummy__arg) @[{@;\ %a@;\ }@])@]" - (format_block ctx) try_b format_exception_name except (format_block ctx) - catch_b - | SRaise except -> - Format.fprintf fmt "@[stop(%a)@]" format_exception - (except, Mark.get s) + (format_block ctx) try_b (format_block ctx) catch_b + | SRaiseEmpty -> Format.pp_print_string fmt "stop(catala_empty_error())" + | SFatalError err -> + Format.fprintf fmt "@[stop(%a)@]" format_error (err, Mark.get s) | SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } -> Format.fprintf fmt "@[if (%a) {@\n%a@]@\n@[} else {@\n%a@]@\n}" diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index e8d468bf..c9f94079 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -207,8 +207,8 @@ let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed = | op, `Reversed -> Expr.eappop ~op ~tys:(List.rev tys) ~args:(List.rev args) m) | ( EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ - | EMatch _ | ELit _ | EDefault _ | EPureDefault _ | EIfThenElse _ | EArray _ - | EEmptyError | EErrorOnEmpty _ ) as e -> + | EMatch _ | ELit _ | EDefault _ | EPureDefault _ | EFatalError _ + | EIfThenElse _ | EArray _ | EEmpty | EErrorOnEmpty _ ) as e -> Expr.map ~f:(translate_expr ctx) (e, m) (** {1 Rule tree construction} *) @@ -462,7 +462,7 @@ let rec rule_tree_to_expr (translate_and_unbox_list base_cons_list) []) ~just:(Expr.elit (LBool false) emark) - ~cons:(Expr.eemptyerror emark) emark + ~cons:(Expr.eempty emark) emark in let exceptions = List.map @@ -561,15 +561,15 @@ let translate_def caller. *) then let m = Untyped { pos = D.ScopeDef.get_position def_info } in - let empty_error = Expr.eemptyerror m in + let empty = Expr.eempty m in match params with | Some (ps, _) -> let labels, tys = List.split ps in Expr.make_abs (Array.of_list (List.map (fun lbl -> Var.make (Mark.remove lbl)) labels)) - empty_error tys (Expr.mark_pos m) - | _ -> empty_error + empty tys (Expr.mark_pos m) + | _ -> empty else rule_tree_to_expr ~toplevel:true ~is_reentrant_var:is_reentrant ~subscope:is_subscope_var ctx diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index c3c43565..3747374b 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -553,6 +553,7 @@ and ('a, 'b, 'm) base_gexpr = } -> ('a, < explicitScopes : no ; .. >, 't) base_gexpr | EAssert : ('a, 'm) gexpr -> ('a, < assertions : yes ; .. >, 'm) base_gexpr + | EFatalError : Runtime.error -> ('a, < .. >, 'm) base_gexpr (* Default terms *) | EDefault : { excepts : ('a, 'm) gexpr list; @@ -564,15 +565,14 @@ and ('a, 'b, 'm) base_gexpr = ('a, 'm) gexpr -> ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr (** "return" of a pure term, so that it can be typed as [default] *) - | EEmptyError : ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr + | EEmpty : ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr | EErrorOnEmpty : ('a, 'm) gexpr -> ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr (* Lambda calculus with exceptions *) - | ERaise : except -> ('a, < exceptions : yes ; .. >, 'm) base_gexpr - | ECatch : { + | ERaiseEmpty : ('a, < exceptions : yes ; .. >, 'm) base_gexpr + | ECatchEmpty : { body : ('a, 'm) gexpr; - exn : except; handler : ('a, 'm) gexpr; } -> ('a, < exceptions : yes ; .. >, 'm) base_gexpr diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index 20766e46..a2e27309 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -128,6 +128,7 @@ let eabs binder tys mark = let eapp ~f ~args ~tys = Box.app1n f args @@ fun f args -> EApp { f; args; tys } let eassert e1 = Box.app1 e1 @@ fun e1 -> EAssert e1 +let efatalerror e1 = Box.app0 @@ EFatalError e1 let eappop ~op ~args ~tys = Box.appn args @@ fun args -> EAppOp { op; args; tys } @@ -143,11 +144,11 @@ let eifthenelse cond etrue efalse = @@ fun cond etrue efalse -> EIfThenElse { cond; etrue; efalse } let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> EErrorOnEmpty e1 -let eemptyerror mark = Mark.add mark (Bindlib.box EEmptyError) -let eraise e1 = Box.app0 @@ ERaise e1 +let eempty mark = Mark.add mark (Bindlib.box EEmpty) +let eraiseempty mark = Mark.add mark (Bindlib.box ERaiseEmpty) -let ecatch body exn handler = - Box.app2 body handler @@ fun body handler -> ECatch { body; exn; handler } +let ecatchempty body handler = + Box.app2 body handler @@ fun body handler -> ECatchEmpty { body; handler } let ecustom obj targs tret mark = Mark.add mark (Bindlib.box (ECustom { obj; targs; tret })) @@ -275,6 +276,24 @@ let option_enum_config = EnumConstructor.Map.of_list [none_constr, (TLit TUnit, Pos.no_pos); some_constr, (TAny, Pos.no_pos)] +let pos_to_runtime pos = + { + Runtime.filename = Pos.get_file pos; + start_line = Pos.get_start_line pos; + start_column = Pos.get_start_column pos; + end_line = Pos.get_end_line pos; + end_column = Pos.get_end_column pos; + law_headings = Pos.get_law_info pos; + } + +let runtime_to_pos rpos = + let pos = + let open Runtime in + Pos.from_info rpos.filename rpos.start_line rpos.start_column rpos.end_line + rpos.end_column + in + Pos.overwrite_law_info pos rpos.law_headings + (* - Traversal functions - *) (* shallow map *) @@ -306,13 +325,14 @@ let map | ETupleAccess { e; index; size } -> etupleaccess ~e:(f e) ~index ~size m | EInj { name; cons; e } -> einj ~name ~cons ~e:(f e) m | EAssert e1 -> eassert (f e1) m + | EFatalError e1 -> efatalerror e1 m | EDefault { excepts; just; cons } -> edefault ~excepts:(List.map f excepts) ~just:(f just) ~cons:(f cons) m | EPureDefault e1 -> epuredefault (f e1) m - | EEmptyError -> eemptyerror m + | EEmpty -> eempty m | EErrorOnEmpty e1 -> eerroronempty (f e1) m - | ECatch { body; exn; handler } -> ecatch (f body) exn (f handler) m - | ERaise exn -> eraise exn m + | ECatchEmpty { body; handler } -> ecatchempty (f body) (f handler) m + | ERaiseEmpty -> eraiseempty m | ELocation loc -> elocation loc m | EStruct { name; fields } -> let fields = StructField.Map.map f fields in @@ -343,7 +363,9 @@ let shallow_fold (acc : 'acc) : 'acc = let lfold x acc = List.fold_left (fun acc x -> f x acc) acc x in match Mark.remove e with - | ELit _ | EVar _ | EExternal _ | ERaise _ | ELocation _ | EEmptyError -> acc + | ELit _ | EVar _ | EFatalError _ | EExternal _ | ERaiseEmpty | ELocation _ + | EEmpty -> + acc | EApp { f = e; args; _ } -> acc |> f e |> lfold args | EAppOp { args; _ } -> acc |> lfold args | EArray args -> acc |> lfold args @@ -358,7 +380,7 @@ let shallow_fold | EDefault { excepts; just; cons } -> acc |> lfold excepts |> f just |> f cons | EPureDefault e -> acc |> f e | EErrorOnEmpty e -> acc |> f e - | ECatch { body; handler; _ } -> acc |> f body |> f handler + | ECatchEmpty { body; handler } -> acc |> f body |> f handler | EStruct { fields; _ } -> acc |> StructField.Map.fold (fun _ -> f) fields | EDStructAmend { e; fields; _ } -> acc |> f e |> Ident.Map.fold (fun _ -> f) fields @@ -423,6 +445,7 @@ let map_gather | EAssert e -> let acc, e = f e in acc, eassert e m + | EFatalError e -> acc, efatalerror e m | EDefault { excepts; just; cons } -> let acc1, excepts = lfoldmap excepts in let acc2, just = f just in @@ -431,15 +454,15 @@ let map_gather | EPureDefault e -> let acc, e = f e in acc, epuredefault e m - | EEmptyError -> acc, eemptyerror m + | EEmpty -> acc, eempty m | EErrorOnEmpty e -> let acc, e = f e in acc, eerroronempty e m - | ECatch { body; exn; handler } -> + | ECatchEmpty { body; handler } -> let acc1, body = f body in let acc2, handler = f handler in - join acc1 acc2, ecatch body exn handler m - | ERaise exn -> acc, eraise exn m + join acc1 acc2, ecatchempty body handler m + | ERaiseEmpty -> acc, eraiseempty m | ELocation loc -> acc, elocation loc m | EStruct { name; fields } -> let acc, fields = @@ -507,7 +530,7 @@ let untype e = map_marks ~f:(fun m -> Untyped { pos = mark_pos m }) e let is_value (type a) (e : (a, _) gexpr) = match Mark.remove e with - | ELit _ | EAbs _ | ERaise _ | ECustom _ | EExternal _ -> true + | ELit _ | EAbs _ | ERaiseEmpty | ECustom _ | EExternal _ -> true | _ -> false let equal_lit (l1 : lit) (l2 : lit) = @@ -519,7 +542,9 @@ let equal_lit (l1 : lit) (l2 : lit) = | LMoney m1, LMoney m2 -> o_eq_mon_mon m1 m2 | LUnit, LUnit -> true | LDate d1, LDate d2 -> o_eq_dat_dat d1 d2 - | LDuration d1, LDuration d2 -> o_eq_dur_dur d1 d2 + | LDuration d1, LDuration d2 -> ( + try o_eq_dur_dur (pos_to_runtime Pos.no_pos) d1 d2 + with Runtime.(Error (UncomparableDurations, _)) -> false) | (LBool _ | LInt _ | LRat _ | LMoney _ | LUnit | LDate _ | LDuration _), _ -> false @@ -583,6 +608,8 @@ let compare_location let equal_location a b = compare_location a b = 0 let equal_except ex1 ex2 = ex1 = ex2 let compare_except ex1 ex2 = Stdlib.compare ex1 ex2 +let equal_error er1 er2 = er1 = er2 +let compare_error er1 er2 = Stdlib.compare er1 er2 let equal_external_ref ref1 ref2 = match ref1, ref2 with @@ -627,6 +654,7 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool = && equal_list args1 args2 && Type.equal_list tys1 tys2 | EAssert e1, EAssert e2 -> equal e1 e2 + | EFatalError e1, EFatalError e2 -> equal_error e1 e2 | ( EDefault { excepts = exc1; just = def1; cons = cons1 }, EDefault { excepts = exc2; just = def2; cons = cons2 } ) -> equal def1 def2 && equal cons1 cons2 && equal_list exc1 exc2 @@ -634,12 +662,12 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool = | ( EIfThenElse { cond = if1; etrue = then1; efalse = else1 }, EIfThenElse { cond = if2; etrue = then2; efalse = else2 } ) -> equal if1 if2 && equal then1 then2 && equal else1 else2 - | EEmptyError, EEmptyError -> true + | EEmpty, EEmpty -> true | EErrorOnEmpty e1, EErrorOnEmpty e2 -> equal e1 e2 - | ERaise ex1, ERaise ex2 -> equal_except ex1 ex2 - | ( ECatch { body = etry1; exn = ex1; handler = ewith1 }, - ECatch { body = etry2; exn = ex2; handler = ewith2 } ) -> - equal etry1 etry2 && equal_except ex1 ex2 && equal ewith1 ewith2 + | ERaiseEmpty, ERaiseEmpty -> true + | ( ECatchEmpty { body = etry1; handler = ewith1 }, + ECatchEmpty { body = etry2; handler = ewith2 } ) -> + equal etry1 etry2 && equal ewith1 ewith2 | ELocation l1, ELocation l2 -> equal_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2) | ( EStruct { name = s1; fields = fields1 }, @@ -671,10 +699,11 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool = ECustom { obj = obj2; targs = targs2; tret = tret2 } ) -> Type.equal_list targs1 targs2 && Type.equal tret1 tret2 && obj1 == obj2 | ( ( EVar _ | EExternal _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _ - | EAbs _ | EApp _ | EAppOp _ | EAssert _ | EDefault _ | EPureDefault _ - | EIfThenElse _ | EEmptyError | EErrorOnEmpty _ | ERaise _ | ECatch _ - | ELocation _ | EStruct _ | EDStructAmend _ | EDStructAccess _ - | EStructAccess _ | EInj _ | EMatch _ | EScopeCall _ | ECustom _ ), + | EAbs _ | EApp _ | EAppOp _ | EAssert _ | EFatalError _ | EDefault _ + | EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ERaiseEmpty + | ECatchEmpty _ | ELocation _ | EStruct _ | EDStructAmend _ + | EDStructAccess _ | EStructAccess _ | EInj _ | EMatch _ | EScopeCall _ + | ECustom _ ), _ ) -> false @@ -755,6 +784,8 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = compare e1 e2 | EAssert e1, EAssert e2 -> compare e1 e2 + | EFatalError e1, EFatalError e2 -> + compare_error e1 e2 | EDefault {excepts=exs1; just=just1; cons=cons1}, EDefault {excepts=exs2; just=just2; cons=cons2} -> compare just1 just2 @@< fun () -> @@ -762,14 +793,12 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = List.compare compare exs1 exs2 | EPureDefault e1, EPureDefault e2 -> compare e1 e2 - | EEmptyError, EEmptyError -> 0 + | EEmpty, EEmpty -> 0 | EErrorOnEmpty e1, EErrorOnEmpty e2 -> compare e1 e2 - | ERaise ex1, ERaise ex2 -> - compare_except ex1 ex2 - | ECatch {body=etry1; exn=ex1; handler=ewith1}, - ECatch {body=etry2; exn=ex2; handler=ewith2} -> - compare_except ex1 ex2 @@< fun () -> + | ERaiseEmpty, ERaiseEmpty -> 0 + | ECatchEmpty {body=etry1; handler=ewith1}, + ECatchEmpty {body=etry2; handler=ewith2} -> compare etry1 etry2 @@< fun () -> compare ewith1 ewith2 | ECustom _, _ | _, ECustom _ -> @@ -794,12 +823,13 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int = | ETupleAccess _, _ -> -1 | _, ETupleAccess _ -> 1 | EInj _, _ -> -1 | _, EInj _ -> 1 | EAssert _, _ -> -1 | _, EAssert _ -> 1 + | EFatalError _, _ -> -1 | _, EFatalError _ -> 1 | EDefault _, _ -> -1 | _, EDefault _ -> 1 | EPureDefault _, _ -> -1 | _, EPureDefault _ -> 1 - | EEmptyError , _ -> -1 | _, EEmptyError -> 1 + | EEmpty , _ -> -1 | _, EEmpty -> 1 | EErrorOnEmpty _, _ -> -1 | _, EErrorOnEmpty _ -> 1 - | ERaise _, _ -> -1 | _, ERaise _ -> 1 - | ECatch _, _ -> . | _, ECatch _ -> . + | ERaiseEmpty, _ -> -1 | _, ERaiseEmpty -> 1 + | ECatchEmpty _, _ -> . | _, ECatchEmpty _ -> . let rec free_vars : ('a, 't) gexpr -> ('a, 't) gexpr Var.Set.t = function | EVar v, _ -> Var.Set.singleton v @@ -907,12 +937,13 @@ let format ppf e = Print.expr ~debug:false () ppf e let rec size : type a. (a, 't) gexpr -> int = fun e -> match Mark.remove e with - | EVar _ | EExternal _ | ELit _ | EEmptyError | ECustom _ -> 1 + | EVar _ | EExternal _ | ELit _ | EEmpty | ECustom _ -> 1 | ETuple args -> List.fold_left (fun acc arg -> acc + size arg) 1 args | EArray args -> List.fold_left (fun acc arg -> acc + size arg) 1 args | ETupleAccess { e; _ } -> size e + 1 | EInj { e; _ } -> size e + 1 | EAssert e -> size e + 1 + | EFatalError _ -> 1 | EErrorOnEmpty e -> size e + 1 | EPureDefault e -> size e + 1 | EApp { f; args; _ } -> @@ -928,8 +959,8 @@ let rec size : type a. (a, 't) gexpr -> int = (fun acc except -> acc + size except) (1 + size just + size cons) excepts - | ERaise _ -> 1 - | ECatch { body; handler; _ } -> 1 + size body + size handler + | ERaiseEmpty -> 1 + | ECatchEmpty { body; handler } -> 1 + size body + size handler | ELocation _ -> 1 | EStruct { fields; _ } -> StructField.Map.fold (fun _ e acc -> acc + 1 + size e) fields 0 @@ -1024,7 +1055,7 @@ let thunk_term term = let pos = mark_pos (Mark.get term) in make_abs [| silent |] term [TLit TUnit, pos] pos -let empty_thunked_term mark = thunk_term (Bindlib.box EEmptyError, mark) +let empty_thunked_term mark = thunk_term (Bindlib.box EEmpty, mark) let unthunk_term_nobox term mark = Mark.add mark diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index d11e9183..bdb20868 100644 --- a/compiler/shared_ast/expr.mli +++ b/compiler/shared_ast/expr.mli @@ -82,6 +82,8 @@ val eassert : 'm mark -> ((< assertions : yes ; .. > as 'a), 'm) boxed_gexpr +val efatalerror : Runtime.error -> 'm mark -> (< .. >, 'm) boxed_gexpr + val eappop : op:'a operator -> args:('a, 'm) boxed_gexpr list -> @@ -108,22 +110,20 @@ val eifthenelse : 'm mark -> ('a any, 'm) boxed_gexpr -val eemptyerror : - 'm mark -> ((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr +val eempty : 'm mark -> ((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr val eerroronempty : ('a, 'm) boxed_gexpr -> 'm mark -> ((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr -val ecatch : +val ecatchempty : ('a, 'm) boxed_gexpr -> - except -> ('a, 'm) boxed_gexpr -> 'm mark -> ((< exceptions : yes ; .. > as 'a), 'm) boxed_gexpr -val eraise : except -> 'm mark -> (< exceptions : yes ; .. >, 'm) boxed_gexpr +val eraiseempty : 'm mark -> (< exceptions : yes ; .. >, 'm) boxed_gexpr val elocation : 'a glocation -> 'm mark -> ((< .. > as 'a), 'm) boxed_gexpr val estruct : @@ -229,6 +229,8 @@ val option_enum : EnumName.t val none_constr : EnumConstructor.t val some_constr : EnumConstructor.t val option_enum_config : typ EnumConstructor.Map.t +val pos_to_runtime : Pos.t -> Runtime.source_position +val runtime_to_pos : Runtime.source_position -> Pos.t (** Manipulation of marked expressions *) diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 870bfd08..18c7c6b0 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -26,7 +26,7 @@ module Runtime = Runtime_ocaml.Runtime (** {1 Helpers} *) let is_empty_error : type a. (a, 'm) gexpr -> bool = - fun e -> match Mark.remove e with EEmptyError -> true | _ -> false + fun e -> match Mark.remove e with EEmpty -> true | _ -> false (* TODO: we should provide a generic way to print logs, that work across the different backends: python, ocaml, javascript, and interpreter *) @@ -72,7 +72,7 @@ let () = (* Todo: this should be handled early when resolving overloads. Here we have proper structural equality, but the OCaml backend for example uses the builtin equality function instead of this. *) -let handle_eq evaluate_operator pos lang e1 e2 = +let handle_eq evaluate_operator m lang e1 e2 = let open Runtime.Oper in match e1, e2 with | ELit LUnit, ELit LUnit -> true @@ -80,13 +80,14 @@ let handle_eq evaluate_operator pos lang e1 e2 = | ELit (LInt x1), ELit (LInt x2) -> o_eq_int_int x1 x2 | ELit (LRat x1), ELit (LRat x2) -> o_eq_rat_rat x1 x2 | ELit (LMoney x1), ELit (LMoney x2) -> o_eq_mon_mon x1 x2 - | ELit (LDuration x1), ELit (LDuration x2) -> o_eq_dur_dur x1 x2 + | ELit (LDuration x1), ELit (LDuration x2) -> + o_eq_dur_dur (Expr.pos_to_runtime (Expr.mark_pos m)) x1 x2 | ELit (LDate x1), ELit (LDate x2) -> o_eq_dat_dat x1 x2 | EArray es1, EArray es2 -> ( try List.for_all2 (fun e1 e2 -> - match Mark.remove (evaluate_operator Eq pos lang [e1; e2]) with + match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with | ELit (LBool b) -> b | _ -> assert false (* should not happen *)) @@ -96,7 +97,7 @@ let handle_eq evaluate_operator pos lang e1 e2 = StructName.equal s1 s2 && StructField.Map.equal (fun e1 e2 -> - match Mark.remove (evaluate_operator Eq pos lang [e1; e2]) with + match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with | ELit (LBool b) -> b | _ -> assert false (* should not happen *)) @@ -107,7 +108,7 @@ let handle_eq evaluate_operator pos lang e1 e2 = EnumName.equal en1 en2 && EnumConstructor.equal i1 i2 && - match Mark.remove (evaluate_operator Eq pos lang [e1; e2]) with + match Mark.remove (evaluate_operator Eq m lang [e1; e2]) with | ELit (LBool b) -> b | _ -> assert false (* should not happen *) @@ -122,27 +123,7 @@ let rec evaluate_operator lang args = let pos = Expr.mark_pos m in - let protect f x y = - let get_binop_args_pos = function - | (arg0 :: arg1 :: _ : ('t, 'm) gexpr list) -> - ["", Expr.pos arg0; "", Expr.pos arg1] - | _ -> assert false - in - try f x y with - | Runtime.Division_by_zero -> - Message.error - ~extra_pos: - [ - "The division operator:", pos; - "The null denominator:", Expr.pos (List.nth args 1); - ] - "division by zero at runtime" - | Runtime.UncomparableDurations -> - Message.error ~extra_pos:(get_binop_args_pos args) "%a" - Format.pp_print_text - "Cannot compare together durations that cannot be converted to a \ - precise number of days" - in + let rpos = Expr.pos_to_runtime pos in let err () = Message.error ~extra_pos: @@ -315,15 +296,15 @@ let rec evaluate_operator | Mult_dur_int, [(ELit (LDuration x), _); (ELit (LInt y), _)] -> ELit (LDuration (o_mult_dur_int x y)) | Div_int_int, [(ELit (LInt x), _); (ELit (LInt y), _)] -> - ELit (LRat (protect o_div_int_int x y)) + ELit (LRat (o_div_int_int rpos x y)) | Div_rat_rat, [(ELit (LRat x), _); (ELit (LRat y), _)] -> - ELit (LRat (protect o_div_rat_rat x y)) + ELit (LRat (o_div_rat_rat rpos x y)) | Div_mon_mon, [(ELit (LMoney x), _); (ELit (LMoney y), _)] -> - ELit (LRat (protect o_div_mon_mon x y)) + ELit (LRat (o_div_mon_mon rpos x y)) | Div_mon_rat, [(ELit (LMoney x), _); (ELit (LRat y), _)] -> - ELit (LMoney (protect o_div_mon_rat x y)) + ELit (LMoney (o_div_mon_rat rpos x y)) | Div_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] -> - ELit (LRat (protect o_div_dur_dur x y)) + ELit (LRat (o_div_dur_dur rpos x y)) | Lt_int_int, [(ELit (LInt x), _); (ELit (LInt y), _)] -> ELit (LBool (o_lt_int_int x y)) | Lt_rat_rat, [(ELit (LRat x), _); (ELit (LRat y), _)] -> @@ -333,7 +314,7 @@ let rec evaluate_operator | Lt_dat_dat, [(ELit (LDate x), _); (ELit (LDate y), _)] -> ELit (LBool (o_lt_dat_dat x y)) | Lt_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] -> - ELit (LBool (protect o_lt_dur_dur x y)) + ELit (LBool (o_lt_dur_dur rpos x y)) | Lte_int_int, [(ELit (LInt x), _); (ELit (LInt y), _)] -> ELit (LBool (o_lte_int_int x y)) | Lte_rat_rat, [(ELit (LRat x), _); (ELit (LRat y), _)] -> @@ -343,7 +324,7 @@ let rec evaluate_operator | Lte_dat_dat, [(ELit (LDate x), _); (ELit (LDate y), _)] -> ELit (LBool (o_lte_dat_dat x y)) | Lte_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] -> - ELit (LBool (protect o_lte_dur_dur x y)) + ELit (LBool (o_lte_dur_dur rpos x y)) | Gt_int_int, [(ELit (LInt x), _); (ELit (LInt y), _)] -> ELit (LBool (o_gt_int_int x y)) | Gt_rat_rat, [(ELit (LRat x), _); (ELit (LRat y), _)] -> @@ -353,7 +334,7 @@ let rec evaluate_operator | Gt_dat_dat, [(ELit (LDate x), _); (ELit (LDate y), _)] -> ELit (LBool (o_gt_dat_dat x y)) | Gt_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] -> - ELit (LBool (protect o_gt_dur_dur x y)) + ELit (LBool (o_gt_dur_dur rpos x y)) | Gte_int_int, [(ELit (LInt x), _); (ELit (LInt y), _)] -> ELit (LBool (o_gte_int_int x y)) | Gte_rat_rat, [(ELit (LRat x), _); (ELit (LRat y), _)] -> @@ -363,7 +344,7 @@ let rec evaluate_operator | Gte_dat_dat, [(ELit (LDate x), _); (ELit (LDate y), _)] -> ELit (LBool (o_gte_dat_dat x y)) | Gte_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] -> - ELit (LBool (protect o_gte_dur_dur x y)) + ELit (LBool (o_gte_dur_dur rpos x y)) | Eq_int_int, [(ELit (LInt x), _); (ELit (LInt y), _)] -> ELit (LBool (o_eq_int_int x y)) | Eq_rat_rat, [(ELit (LRat x), _); (ELit (LRat y), _)] -> @@ -373,7 +354,7 @@ let rec evaluate_operator | Eq_dat_dat, [(ELit (LDate x), _); (ELit (LDate y), _)] -> ELit (LBool (o_eq_dat_dat x y)) | Eq_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] -> - ELit (LBool (protect o_eq_dur_dur x y)) + ELit (LBool (o_eq_dur_dur rpos x y)) | HandleDefault, [(EArray excepts, _); just; cons] -> ( (* This case is for lcalc with exceptions: we rely OCaml exception handling here *) @@ -533,7 +514,7 @@ and val_to_runtime : Obj.t = fun eval_expr ctx ty v -> match Mark.remove ty, Mark.remove v with - | _, EEmptyError -> raise Runtime.EmptyError + | _, EEmpty -> raise Runtime.Empty | TLit TBool, ELit (LBool b) -> Obj.repr b | TLit TUnit, ELit LUnit -> Obj.repr () | TLit TInt, ELit (LInt i) -> Obj.repr i @@ -595,7 +576,7 @@ and val_to_runtime : let tys = List.map (fun a -> Expr.maybe_ty (Mark.get a)) args in val_to_runtime eval_expr ctx tret (try eval_expr ctx (EApp { f = v; args; tys }, m) - with CatalaException (Empty, _) -> raise Runtime.EmptyError) + with CatalaException (Empty, _) -> raise Runtime.Empty) | targ :: targs -> Obj.repr (fun x -> curry (runtime_to_val eval_expr ctx m targ x :: acc) targs) @@ -685,7 +666,7 @@ let rec evaluate_expr : | EAppOp { op; args; _ } -> let args = List.map (evaluate_expr ctx lang) args in evaluate_operator (evaluate_expr ctx lang) op m lang args - | EAbs _ | ELit _ | ECustom _ | EEmptyError -> e (* these are values *) + | EAbs _ | ELit _ | ECustom _ | EEmpty -> e (* these are values *) | EStruct { fields = es; name } -> let fields, es = List.split (StructField.Map.bindings es) in let es = List.map (evaluate_expr ctx lang) es in @@ -785,9 +766,10 @@ let rec evaluate_expr : Message.error ~pos:(Expr.pos e') "%a" Format.pp_print_text "Expected a boolean literal for the result of this assertion (should \ not happen if the term was well-typed)") + | EFatalError err -> raise (Runtime.Error (err, Expr.pos_to_runtime pos)) | EErrorOnEmpty e' -> ( match evaluate_expr ctx lang e' with - | EEmptyError, _ -> + | EEmpty, _ -> Message.error ~pos:(Expr.pos e') "%a" Format.pp_print_text "This variable evaluated to an empty term (no rule that defined it \ applied in this situation)" @@ -800,7 +782,7 @@ let rec evaluate_expr : let just = evaluate_expr ctx lang just in match Mark.remove just with | ELit (LBool true) -> evaluate_expr ctx lang cons - | ELit (LBool false) -> Mark.copy e EEmptyError + | ELit (LBool false) -> Mark.copy e EEmpty | _ -> Message.error ~pos:(Expr.pos e) "%a" Format.pp_print_text "Default justification has not been reduced to a boolean at \ @@ -814,11 +796,10 @@ let rec evaluate_expr : in raise (CatalaException (ConflictError poslist, pos))) | EPureDefault e -> evaluate_expr ctx lang e - | ERaise exn -> raise (CatalaException (exn, pos)) - | ECatch { body; exn; handler } -> ( + | ERaiseEmpty -> raise (CatalaException (Empty, pos)) + | ECatchEmpty { body; handler } -> ( try evaluate_expr ctx lang body - with CatalaException (caught, _) when Expr.equal_except caught exn -> - evaluate_expr ctx lang handler) + with CatalaException (Empty, _) -> evaluate_expr ctx lang handler) | _ -> . and partially_evaluate_expr_for_assertion_failure_message : @@ -859,6 +840,19 @@ and partially_evaluate_expr_for_assertion_failure_message : Mark.get e ) | _ -> evaluate_expr ctx lang e +let evaluate_expr_safe : + type d e. + decl_ctx -> + Global.backend_lang -> + ((d, e, yes) interpr_kind, 't) gexpr -> + ((d, e, yes) interpr_kind, 't) gexpr = + fun ctx lang e -> + try evaluate_expr ctx lang e + with Runtime.Error (err, rpos) -> + Message.error ~pos:(Expr.runtime_to_pos rpos) "Error during evaluation: %a." + Format.pp_print_text + (Runtime.error_message err) + (* Typing shenanigan to add custom terms to the AST type. *) let addcustom e = let rec f : @@ -870,13 +864,13 @@ let addcustom e = Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) m | (EDefault _, _) as e -> Expr.map ~f e | (EPureDefault _, _) as e -> Expr.map ~f e - | (EEmptyError, _) as e -> Expr.map ~f e + | (EEmpty, _) as e -> Expr.map ~f e | (EErrorOnEmpty _, _) as e -> Expr.map ~f e - | (ECatch _, _) as e -> Expr.map ~f e - | (ERaise _, _) as e -> Expr.map ~f e - | ( ( EAssert _ | ELit _ | EApp _ | EArray _ | EVar _ | EExternal _ | EAbs _ - | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EStruct _ - | EStructAccess _ | EMatch _ ), + | (ECatchEmpty _, _) as e -> Expr.map ~f e + | (ERaiseEmpty, _) as e -> Expr.map ~f e + | ( ( EAssert _ | EFatalError _ | ELit _ | EApp _ | EArray _ | EVar _ + | EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _ + | EInj _ | EStruct _ | EStructAccess _ | EMatch _ ), _ ) as e -> Expr.map ~f e | _ -> . @@ -902,13 +896,13 @@ let delcustom e = Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) m | (EDefault _, _) as e -> Expr.map ~f e | (EPureDefault _, _) as e -> Expr.map ~f e - | (EEmptyError, _) as e -> Expr.map ~f e + | (EEmpty, _) as e -> Expr.map ~f e | (EErrorOnEmpty _, _) as e -> Expr.map ~f e - | (ECatch _, _) as e -> Expr.map ~f e - | (ERaise _, _) as e -> Expr.map ~f e - | ( ( EAssert _ | ELit _ | EApp _ | EArray _ | EVar _ | EExternal _ | EAbs _ - | EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EStruct _ - | EStructAccess _ | EMatch _ ), + | (ECatchEmpty _, _) as e -> Expr.map ~f e + | (ERaiseEmpty, _) as e -> Expr.map ~f e + | ( ( EAssert _ | EFatalError _ | ELit _ | EApp _ | EArray _ | EVar _ + | EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _ + | EInj _ | EStruct _ | EStructAccess _ | EMatch _ ), _ ) as e -> Expr.map ~f e | _ -> . @@ -941,7 +935,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list = let e = Expr.unbox @@ Program.to_expr p s in let ctx = p.decl_ctx in - match evaluate_expr ctx p.lang (addcustom e) with + match evaluate_expr_safe ctx p.lang (addcustom e) with | (EAbs { tys = [((TStruct s_in, _) as _targs)]; _ }, mark_e) as e -> begin (* At this point, the interpreter seeks to execute the scope but does not have a way to retrieve input values from the command line. [taus] contain @@ -969,7 +963,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list tell with just this info. *) Expr.make_abs (Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in) - (Expr.eraise Empty (Expr.with_ty mark_e ty_out)) + (Expr.eraiseempty (Expr.with_ty mark_e ty_out)) ty_in (Expr.mark_pos mark_e) | TTuple ((TArrow (ty_in, (TOption _, _)), _) :: _) -> (* ... or a closure if closure conversion is enabled *) @@ -1006,7 +1000,9 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list [TStruct s_in, Expr.pos e] (Expr.pos e) in - match Mark.remove (evaluate_expr ctx p.lang (Expr.unbox to_interpret)) with + match + Mark.remove (evaluate_expr_safe ctx p.lang (Expr.unbox to_interpret)) + with | EStruct { fields; _ } -> List.map (fun (fld, e) -> StructField.get_info fld, e) @@ -1028,7 +1024,7 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list = let ctx = p.decl_ctx in let e = Expr.unbox (Program.to_expr p s) in - match evaluate_expr p.decl_ctx p.lang (addcustom e) with + match evaluate_expr_safe p.decl_ctx p.lang (addcustom e) with | (EAbs { tys = [((TStruct s_in, _) as _targs)]; _ }, mark_e) as e -> begin (* At this point, the interpreter seeks to execute the scope but does not have a way to retrieve input values from the command line. [taus] contain @@ -1043,7 +1039,7 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list | TArrow (ty_in, ty_out) -> Expr.make_abs (Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in) - (Bindlib.box EEmptyError, Expr.with_ty mark_e ty_out) + (Bindlib.box EEmpty, Expr.with_ty mark_e ty_out) ty_in (Expr.mark_pos mark_e) | _ -> Message.error ~pos:(Mark.get ty) "%a" Format.pp_print_text @@ -1063,7 +1059,9 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list [TStruct s_in, Expr.pos e] (Expr.pos e) in - match Mark.remove (evaluate_expr ctx p.lang (Expr.unbox to_interpret)) with + match + Mark.remove (evaluate_expr_safe ctx p.lang (Expr.unbox to_interpret)) + with | EStruct { fields; _ } -> List.map (fun (fld, e) -> StructField.get_info fld, e) diff --git a/compiler/shared_ast/optimizations.ml b/compiler/shared_ast/optimizations.ml index c1a6ff59..6d3bbe0a 100644 --- a/compiler/shared_ast/optimizations.ml +++ b/compiler/shared_ast/optimizations.ml @@ -171,7 +171,7 @@ let rec optimize_expr : | EDefault { excepts; just; cons } -> ( (* TODO: mechanically prove each of these optimizations correct *) let excepts = - List.filter (fun except -> Mark.remove except <> EEmptyError) excepts + List.filter (fun except -> Mark.remove except <> EEmpty) excepts (* we can discard the exceptions that are always empty error *) in let value_except_count = @@ -201,7 +201,7 @@ let rec optimize_expr : | EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ), _ ) ) -> (* No exceptions and condition false *) - EEmptyError + EEmpty | ( [except], ( ( ELit (LBool false) | EAppOp { op = Log _; args = [(ELit (LBool false), _)]; _ } ), @@ -363,13 +363,12 @@ let rec optimize_expr : el) -> (* identity tuple reconstruction *) Mark.remove e - | ECatch { body; exn; handler } -> ( + | ECatchEmpty { body; handler } -> ( (* peephole exception catching reductions *) match Mark.remove body, Mark.remove handler with - | ERaise exn', ERaise exn'' when exn' = exn && exn = exn'' -> ERaise exn - | ERaise exn', _ when exn' = exn -> Mark.remove handler - | _, ERaise exn' when exn' = exn -> Mark.remove body - | _ -> ECatch { body; exn; handler }) + | ERaiseEmpty, _ -> Mark.remove handler + | _, ERaiseEmpty -> Mark.remove body + | _ -> ECatchEmpty { body; handler }) | e -> e in Expr.Box.app1 e reduce mark diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index 20910be5..ac8a0e5f 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -345,6 +345,9 @@ let operator : type a. ?debug:bool -> Format.formatter -> a operator -> unit = op_style fmt (if debug then operator_to_string op else operator_to_shorter_string op) +let runtime_error ppf err = + Format.fprintf ppf "@{%s@}" (Runtime.error_to_string err) + let except (fmt : Format.formatter) (exn : except) : unit = op_style fmt (match exn with @@ -426,12 +429,13 @@ module Precedence = struct | EDStructAmend _ -> App | EDStructAccess _ | EStructAccess _ -> Dot | EAssert _ -> App + | EFatalError _ -> App | EDefault _ -> Contained | EPureDefault _ -> Contained - | EEmptyError -> Contained + | EEmpty -> Contained | EErrorOnEmpty _ -> App - | ERaise _ -> App - | ECatch _ -> App + | ERaiseEmpty -> App + | ECatchEmpty _ -> App | ECustom _ -> Contained let needs_parens ~context ?(rhs = false) e = @@ -665,19 +669,22 @@ module ExprGen (C : EXPR_PARAM) = struct "⟨" expr e (default_punct (List.hd colors)) "⟩" - | EEmptyError -> lit_style fmt "∅" + | EEmpty -> lit_style fmt "∅" | EErrorOnEmpty e' -> Format.fprintf fmt "@[%a@ %a@]" op_style "error_empty" (rhs exprc) e' | EAssert e' -> Format.fprintf fmt "@[%a@ %a%a%a@]" keyword "assert" punctuation "(" (rhs exprc) e' punctuation ")" - | ECatch { body; exn; handler } -> + | EFatalError err -> + Format.fprintf fmt "@[%a@ @{%s@}@]" keyword "error" + (Runtime.error_to_string err) + | ECatchEmpty { body; handler } -> Format.fprintf fmt "@[@[%a@ %a@]@ @[%a@ %a ->@ %a@]@]" keyword "try" - expr body keyword "with" except exn (rhs exprc) handler - | ERaise exn -> - Format.fprintf fmt "@[%a@ %a@]" keyword "raise" except exn + expr body keyword "with" except Empty (rhs exprc) handler + | ERaiseEmpty -> + Format.fprintf fmt "@[%a@ %a@]" keyword "raise" except Empty | ELocation loc -> location fmt loc | EDStructAccess { e; field; _ } -> Format.fprintf fmt "@[%a%a@,%a%a%a@]" (lhs exprc) e punctuation @@ -1130,12 +1137,12 @@ module UserFacing = struct | EInj { name = _; cons; e } -> Format.fprintf ppf "@[%a@ %a@]" EnumConstructor.format cons (value ~fallback lang) e - | EEmptyError -> Format.pp_print_string ppf "ø" + | EEmpty -> Format.pp_print_string ppf "ø" | EAbs _ -> Format.pp_print_string ppf "" | EExternal _ -> Format.pp_print_string ppf "" | EApp _ | EAppOp _ | EVar _ | EIfThenElse _ | EMatch _ | ETupleAccess _ - | EStructAccess _ | EAssert _ | EDefault _ | EPureDefault _ - | EErrorOnEmpty _ | ERaise _ | ECatch _ | ELocation _ | EScopeCall _ + | EStructAccess _ | EAssert _ | EFatalError _ | EDefault _ | EPureDefault _ + | EErrorOnEmpty _ | ERaiseEmpty | ECatchEmpty _ | ELocation _ | EScopeCall _ | EDStructAmend _ | EDStructAccess _ | ECustom _ -> fallback ppf e @@ -1150,7 +1157,7 @@ module UserFacing = struct let bypass : type a t. Format.formatter -> (a, t) gexpr -> bool = fun ppf e -> match Mark.remove e with - | EArray _ | ETuple _ | EStruct _ | EInj _ | EEmptyError | EAbs _ + | EArray _ | ETuple _ | EStruct _ | EInj _ | EEmpty | EAbs _ | EExternal _ -> aux_value ppf e; true diff --git a/compiler/shared_ast/print.mli b/compiler/shared_ast/print.mli index dc8d9b21..a36c7af2 100644 --- a/compiler/shared_ast/print.mli +++ b/compiler/shared_ast/print.mli @@ -48,6 +48,7 @@ val lit : Format.formatter -> lit -> unit val operator : ?debug:bool -> Format.formatter -> 'a operator -> unit val log_entry : Format.formatter -> log_entry -> unit val except : Format.formatter -> except -> unit +val runtime_error : Format.formatter -> Runtime.error -> unit val var : Format.formatter -> 'e Var.t -> unit val var_debug : Format.formatter -> 'e Var.t -> unit diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 075d81af..d05d9206 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -754,11 +754,11 @@ and typecheck_expr_top_down : args in Expr.escopecall ~scope ~args:args' mark - | A.ERaise ex -> Expr.eraise ex context_mark - | A.ECatch { body; exn; handler } -> + | A.ERaiseEmpty -> Expr.eraiseempty context_mark + | A.ECatchEmpty { body; handler } -> let body' = typecheck_expr_top_down ctx env tau body in let handler' = typecheck_expr_top_down ctx env tau handler in - Expr.ecatch body' exn handler' context_mark + Expr.ecatchempty body' handler' context_mark | A.EVar v -> let tau' = match Env.get env v with @@ -949,8 +949,9 @@ and typecheck_expr_top_down : typecheck_expr_top_down ctx env (unionfind ~pos:e1 (TLit TBool)) e1 in Expr.eassert e1' mark - | A.EEmptyError -> - Expr.eemptyerror (ty_mark (TDefault (unionfind (TAny (Any.fresh ()))))) + | A.EFatalError err -> Expr.efatalerror err context_mark + | A.EEmpty -> + Expr.eempty (ty_mark (TDefault (unionfind (TAny (Any.fresh ()))))) | A.EErrorOnEmpty e1 -> let tau' = unionfind (TDefault tau) in let e1' = typecheck_expr_top_down ctx env tau' e1 in diff --git a/compiler/verification/conditions.ml b/compiler/verification/conditions.ml index 7f8390f9..5d0b6f4a 100644 --- a/compiler/verification/conditions.ml +++ b/compiler/verification/conditions.ml @@ -171,7 +171,7 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) : (Mark.get e); ]) (Mark.get e) - | EEmptyError -> Mark.copy e (ELit (LBool false)) + | EEmpty -> Mark.copy e (ELit (LBool false)) | EVar _ (* Per default calculus semantics, you cannot call a function with an argument that evaluates to the empty error. Thus, all variable evaluate to @@ -202,7 +202,7 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) : can be ignored *) let _vars, body = Bindlib.unmbind binder in match Mark.remove body with - | EEmptyError -> Mark.copy field (ELit (LBool true)) + | EEmpty -> Mark.copy field (ELit (LBool true)) | _ -> (* same as basic [EAbs case]*) generate_vc_must_not_return_empty ctx field) diff --git a/compiler/verification/z3backend.real.ml b/compiler/verification/z3backend.real.ml index 80c07afd..6bd1b7b1 100644 --- a/compiler/verification/z3backend.real.ml +++ b/compiler/verification/z3backend.real.ml @@ -19,7 +19,7 @@ open Shared_ast open Dcalc open Ast open Z3 -module StringMap : Map.S with type key = String.t = Map.Make (String) +module StringMap = String.Map module Runtime = Runtime_ocaml.Runtime type context = { @@ -746,6 +746,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr = "[Z3 encoding] EApp node: Catala function calls should only include \ operators or function names") | EAssert e -> translate_expr ctx e + | EFatalError _ -> failwith "[Z3 encoding] EFatalError unsupported" | EDefault _ -> failwith "[Z3 encoding] EDefault unsupported" | EPureDefault _ -> failwith "[Z3 encoding] EPureDefault unsupported" | EIfThenElse { cond = e_if; etrue = e_then; efalse = e_else } -> @@ -756,7 +757,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr = let ctx, z3_then = translate_expr ctx e_then in let ctx, z3_else = translate_expr ctx e_else in ctx, Boolean.mk_ite ctx.ctx_z3 z3_if z3_then z3_else - | EEmptyError -> failwith "[Z3 encoding] LEmptyError literals not supported" + | EEmpty -> failwith "[Z3 encoding] 'Empty' literals not supported" | EErrorOnEmpty _ -> failwith "[Z3 encoding] ErrorOnEmpty unsupported" | _ -> . diff --git a/doc/syntax/syntax_en.catala_en b/doc/syntax/syntax_en.catala_en index 01e3a174..37ad6db7 100644 --- a/doc/syntax/syntax_en.catala_en +++ b/doc/syntax/syntax_en.catala_en @@ -254,9 +254,9 @@ to ensure that the *syntax* is correct. $ catala typecheck [ERROR] No scope named Scope0 found -┌─⯈ doc/syntax/syntax_en.catala_en:95.14-95.20: +┌─⯈ doc/syntax/syntax_en.catala_en:94.14-94.20: └──┐ -95 │ sub1 scope Scope0 +94 │ sub1 scope Scope0 │ ‾‾‾‾‾‾ └─ Metadata declaration #return code 123# diff --git a/doc/syntax/syntax_fr.catala_fr b/doc/syntax/syntax_fr.catala_fr index 50bbc70a..15fafdf4 100644 --- a/doc/syntax/syntax_fr.catala_fr +++ b/doc/syntax/syntax_fr.catala_fr @@ -252,9 +252,9 @@ to ensure that the *syntax* is correct. $ catala typecheck [ERROR] No scope named Scope0 found -┌─⯈ doc/syntax/syntax_fr.catala_fr:93.28-93.34: +┌─⯈ doc/syntax/syntax_fr.catala_fr:92.28-92.34: └──┐ -93 │ sub1 champ d'application Scope0 +92 │ sub1 champ d'application Scope0 │ ‾‾‾‾‾‾ └─ Déclaration des métadonnées #return code 123# diff --git a/runtimes/c/runtime.c b/runtimes/c/runtime.c index 4d0435de..845da46a 100644 --- a/runtimes/c/runtime.c +++ b/runtimes/c/runtime.c @@ -4,12 +4,14 @@ typedef enum catala_fatal_error_code { - catala_no_value_provided, - catala_conflict, - catala_crash, - catala_empty, - catala_assertion_failure, - catala_malloc_error, + catala_assertion_failed, + catala_no_value, + catala_conflict, + catala_division_by_zero, + catala_not_same_length, + catala_uncomparable_durations, + catala_indivisible_durations, + catala_malloc_error, } catala_fatal_error_code; typedef struct catala_code_position diff --git a/runtimes/jsoo/runtime.ml b/runtimes/jsoo/runtime.ml index 21b44d21..53399c55 100644 --- a/runtimes/jsoo/runtime.ml +++ b/runtimes/jsoo/runtime.ml @@ -147,13 +147,9 @@ let event_manager : event_manager Js.t = end let execute_or_throw_error f = - let throw_error (descr : string) (pos : R_ocaml.source_position) = - let msg = - Js.string - (Format.asprintf "%s in file %s, position %d:%d--%d:%d." descr - pos.filename pos.start_line pos.start_column pos.end_line - pos.end_column) - in + try f () + with R_ocaml.Error _ as exc -> + let msg = Js.string (Printexc.to_string exc) in Js.Js_error.raise_ (Js.Js_error.of_error (object%js @@ -162,16 +158,6 @@ let execute_or_throw_error f = val mutable stack = Js.Optdef.empty method toString = msg end)) - in - try f () with - | R_ocaml.NoValueProvided pos -> - throw_error - "No rule applies in the given context to give a value to the variable" pos - | R_ocaml.ConflictError pos -> - throw_error - "A conflict happened between two rules giving a value to the variable" pos - | R_ocaml.AssertionFailed pos -> - throw_error "A failure happened in the assertion" pos let () = Js.export_all diff --git a/runtimes/ocaml/runtime.ml b/runtimes/ocaml/runtime.ml index 84fdef53..f7b1eeb4 100644 --- a/runtimes/ocaml/runtime.ml +++ b/runtimes/ocaml/runtime.ml @@ -45,35 +45,49 @@ type source_position = { law_headings : string list; } -exception EmptyError -exception AssertionFailed of source_position -exception ConflictError of source_position -exception UncomparableDurations -exception IndivisibleDurations -exception ImpossibleDate -exception NoValueProvided of source_position -exception NotSameLength -exception Division_by_zero (* Shadows the stdlib definition *) +type error = + | AssertionFailed + | NoValue + | Conflict + | DivisionByZero + | NotSameLength + | UncomparableDurations + | IndivisibleDurations -(* Register exceptions printers *) +let error_to_string = function + | AssertionFailed -> "AssertionFailed" + | NoValue -> "NoValue" + | Conflict -> "Conflict" + | DivisionByZero -> "DivisionByZero" + | NotSameLength -> "NotSameLength" + | UncomparableDurations -> "UncomparableDurations" + | IndivisibleDurations -> "IndivisibleDurations" + +let error_message = function + | AssertionFailed -> "this assertion doesn't hold" + | NoValue -> "no computation with valid conditions found" + | Conflict -> "two or more concurring valid computations" + | DivisionByZero -> "division by zero" + | NotSameLength -> "traversing multiple lists of different lengths" + | UncomparableDurations -> + "comparing durations in different units (e.g. months vs. days)" + | IndivisibleDurations -> "dividing durations that are not in days" + +exception Error of error * source_position +exception Empty + +let error err pos = raise (Error (err, pos)) + +(* Register (fallback) exception printers *) let () = - let pos () p = + let ppos () p = Printf.sprintf "%s:%d.%d-%d.%d" p.filename p.start_line p.start_column p.end_line p.end_column in - let pr fmt = Printf.ksprintf (fun s -> Some s) fmt in Printexc.register_printer @@ function - | EmptyError -> pr "A variable couldn't be resolved" - | AssertionFailed p -> pr "At %a: Assertion failed" pos p - | ConflictError p -> pr "At %a: Conflicting exceptions" pos p - | UncomparableDurations -> pr "Ambiguous comparison between durations" - | IndivisibleDurations -> pr "Ambiguous division between durations" - | ImpossibleDate -> pr "Invalid date" - | NoValueProvided p -> - pr "At %a: No definition applied to this variable" pos p - | NotSameLength -> pr "Attempt to traverse lists of different lengths" - | Division_by_zero -> pr "Division by zero" + | Error (err, pos) -> + Some (Printf.sprintf "At %a: %s" ppos pos (error_message err)) | _ -> None let () = @@ -81,6 +95,9 @@ let () = @@ fun exc bt -> Printf.eprintf "[ERROR] %s\n%!" (Printexc.to_string exc); if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt +(* TODO: the backtrace will point to the OCaml code; but we could make it point + to the Catala code if we add #line directives everywhere in the generated + code. *) let round (q : Q.t) : Z.t = (* The mathematical formula is [round(q) = sgn(q) * floor(abs(q) + 0.5)]. @@ -185,9 +202,10 @@ let day_of_month_of_date (d : date) : integer = let _, _, d = Dates_calc.Dates.date_to_ymd d in Z.of_int d +(* This could fail, but is expected to only be called with known, already + validated arguments by the generated code *) let date_of_numbers (year : int) (month : int) (day : int) : date = - try Dates_calc.Dates.make_date ~year ~month ~day - with _ -> raise ImpossibleDate + Dates_calc.Dates.make_date ~year ~month ~day let date_to_string (d : date) : string = Format.asprintf "%a" Dates_calc.Dates.format_date d @@ -712,16 +730,16 @@ let handle_default : let except = Array.fold_left (fun acc except -> - let new_val = try Some (except ()) with EmptyError -> None in + let new_val = try Some (except ()) with Empty -> None in match acc, new_val with | None, _ -> new_val | Some _, None -> acc - | Some _, Some _ -> raise (ConflictError pos)) + | Some _, Some _ -> error Conflict pos) None exceptions in match except with | Some x -> x - | None -> if just () then cons () else raise EmptyError + | None -> if just () then cons () else raise Empty let handle_default_opt (pos : source_position) @@ -734,30 +752,30 @@ let handle_default_opt match acc, except with | Eoption.ENone _, _ -> except | Eoption.ESome _, Eoption.ENone _ -> acc - | Eoption.ESome _, Eoption.ESome _ -> raise (ConflictError pos)) + | Eoption.ESome _, Eoption.ESome _ -> error Conflict pos) (Eoption.ENone ()) exceptions in match except with | Eoption.ESome _ -> except | Eoption.ENone _ -> if just () then cons () else Eoption.ENone () -let no_input : unit -> 'a = fun _ -> raise EmptyError - (* TODO: add a compare built-in to dates_calc. At the moment this fails on e.g. [3 months, 4 months] *) -let compare_periods (p1 : duration) (p2 : duration) : int = +let compare_periods pos (p1 : duration) (p2 : duration) : int = try let p1_days = Dates_calc.Dates.period_to_days p1 in let p2_days = Dates_calc.Dates.period_to_days p2 in compare p1_days p2_days - with Dates_calc.Dates.AmbiguousComputation -> raise UncomparableDurations + with Dates_calc.Dates.AmbiguousComputation -> + error UncomparableDurations pos (* TODO: same here, although it was tweaked to never fail on equal dates. Comparing the difference to duration_0 is not a good idea because we still want to fail on [1 month, 30 days] rather than return [false] *) -let equal_periods (p1 : duration) (p2 : duration) : bool = +let equal_periods pos (p1 : duration) (p2 : duration) : bool = try Dates_calc.Dates.period_to_days (Dates_calc.Dates.sub_periods p1 p2) = 0 - with Dates_calc.Dates.AmbiguousComputation -> raise UncomparableDurations + with Dates_calc.Dates.AmbiguousComputation -> + error UncomparableDurations pos module Oper = struct let o_not = Stdlib.not @@ -782,8 +800,8 @@ module Oper = struct let o_eq = ( = ) let o_map = Array.map - let o_map2 f a b = - try Array.map2 f a b with Invalid_argument _ -> raise NotSameLength + let o_map2 pos f a b = + try Array.map2 f a b with Invalid_argument _ -> error NotSameLength pos let o_reduce f dft a = let len = Array.length a in @@ -818,54 +836,56 @@ module Oper = struct let o_mult_dur_int d m = Dates_calc.Dates.mul_period d (Z.to_int m) - let o_div_int_int i1 i2 = + let o_div_int_int pos i1 i2 = (* It's not on the ocamldoc, but Q.div likely already raises this ? *) - if Z.zero = i2 then raise Division_by_zero + if Z.zero = i2 then error DivisionByZero pos else Q.div (Q.of_bigint i1) (Q.of_bigint i2) - let o_div_rat_rat i1 i2 = - if Q.zero = i2 then raise Division_by_zero else Q.div i1 i2 + let o_div_rat_rat pos i1 i2 = + if Q.zero = i2 then error DivisionByZero pos else Q.div i1 i2 - let o_div_mon_mon m1 m2 = - if Z.zero = m2 then raise Division_by_zero + let o_div_mon_mon pos m1 m2 = + if Z.zero = m2 then error DivisionByZero pos else Q.div (Q.of_bigint m1) (Q.of_bigint m2) - let o_div_mon_rat m1 r1 = - if Q.zero = r1 then raise Division_by_zero else o_mult_mon_rat m1 (Q.inv r1) + let o_div_mon_rat pos m1 r1 = + if Q.zero = r1 then error DivisionByZero pos + else o_mult_mon_rat m1 (Q.inv r1) - let o_div_dur_dur d1 d2 = + let o_div_dur_dur pos d1 d2 = let i1, i2 = try ( integer_of_int (Dates_calc.Dates.period_to_days d1), integer_of_int (Dates_calc.Dates.period_to_days d2) ) - with Dates_calc.Dates.AmbiguousComputation -> raise IndivisibleDurations + with Dates_calc.Dates.AmbiguousComputation -> + error IndivisibleDurations pos in - o_div_int_int i1 i2 + o_div_int_int pos i1 i2 let o_lt_int_int i1 i2 = Z.compare i1 i2 < 0 let o_lt_rat_rat i1 i2 = Q.compare i1 i2 < 0 let o_lt_mon_mon m1 m2 = Z.compare m1 m2 < 0 - let o_lt_dur_dur d1 d2 = compare_periods d1 d2 < 0 + let o_lt_dur_dur pos d1 d2 = compare_periods pos d1 d2 < 0 let o_lt_dat_dat d1 d2 = Dates_calc.Dates.compare_dates d1 d2 < 0 let o_lte_int_int i1 i2 = Z.compare i1 i2 <= 0 let o_lte_rat_rat i1 i2 = Q.compare i1 i2 <= 0 let o_lte_mon_mon m1 m2 = Z.compare m1 m2 <= 0 - let o_lte_dur_dur d1 d2 = compare_periods d1 d2 <= 0 + let o_lte_dur_dur pos d1 d2 = compare_periods pos d1 d2 <= 0 let o_lte_dat_dat d1 d2 = Dates_calc.Dates.compare_dates d1 d2 <= 0 let o_gt_int_int i1 i2 = Z.compare i1 i2 > 0 let o_gt_rat_rat i1 i2 = Q.compare i1 i2 > 0 let o_gt_mon_mon m1 m2 = Z.compare m1 m2 > 0 - let o_gt_dur_dur d1 d2 = compare_periods d1 d2 > 0 + let o_gt_dur_dur pos d1 d2 = compare_periods pos d1 d2 > 0 let o_gt_dat_dat d1 d2 = Dates_calc.Dates.compare_dates d1 d2 > 0 let o_gte_int_int i1 i2 = Z.compare i1 i2 >= 0 let o_gte_rat_rat i1 i2 = Q.compare i1 i2 >= 0 let o_gte_mon_mon m1 m2 = Z.compare m1 m2 >= 0 - let o_gte_dur_dur d1 d2 = compare_periods d1 d2 >= 0 + let o_gte_dur_dur pos d1 d2 = compare_periods pos d1 d2 >= 0 let o_gte_dat_dat d1 d2 = Dates_calc.Dates.compare_dates d1 d2 >= 0 let o_eq_int_int i1 i2 = Z.equal i1 i2 let o_eq_rat_rat i1 i2 = Q.equal i1 i2 let o_eq_mon_mon m1 m2 = Z.equal m1 m2 - let o_eq_dur_dur d1 d2 = equal_periods d1 d2 + let o_eq_dur_dur pos d1 d2 = equal_periods pos d1 d2 let o_eq_dat_dat d1 d2 = Dates_calc.Dates.compare_dates d1 d2 = 0 let o_fold = Array.fold_left end diff --git a/runtimes/ocaml/runtime.mli b/runtimes/ocaml/runtime.mli index 1864d45a..dcb90f2c 100644 --- a/runtimes/ocaml/runtime.mli +++ b/runtimes/ocaml/runtime.mli @@ -69,14 +69,24 @@ type io_log = { (** {1 Exceptions} *) -exception EmptyError -exception AssertionFailed of source_position -exception ConflictError of source_position -exception UncomparableDurations -exception IndivisibleDurations -exception ImpossibleDate -exception NoValueProvided of source_position -exception Division_by_zero (* Shadows the stdlib definition *) +type error = + | AssertionFailed (** An assertion in the program doesn't hold *) + | NoValue (** No computation with valid conditions found *) + | Conflict (** Two different valid computations at that point *) + | DivisionByZero (** The denominator happened to be 0 here *) + | NotSameLength (** Traversing multiple lists of different lengths *) + | UncomparableDurations + (** Comparing durations in different units (e.g. months vs. days) *) + | IndivisibleDurations (** Dividing durations that are not in days *) + +val error_to_string : error -> string +(** Returns the capitalized tag of the error as a string *) + +val error_message : error -> string +(** Returns a short explanation message about the error *) + +exception Error of error * source_position +exception Empty (** {1 Value Embedding} *) @@ -305,9 +315,7 @@ val year_of_date : date -> integer val date_to_string : date -> string val date_of_numbers : int -> int -> int -> date -(** Usage: [date_of_numbers year month day] - - @raise ImpossibleDate *) +(** Usage: [date_of_numbers year month day] *) val first_day_of_month : date -> date val last_day_of_month : date -> date @@ -337,12 +345,11 @@ val handle_default_opt : 'a Eoption.t (** @raise ConflictError *) -val no_input : unit -> 'a - (**{1 Operators} *) module Oper : sig - (* The types **must** match with Shared_ast.Operator.*_type *) + (* The types **must** match with Shared_ast.Operator.*_type ; but for the + added first argument [pos] for any operator that might trigger an error. *) val o_not : bool -> bool val o_length : 'a array -> integer val o_torat_int : integer -> decimal @@ -365,7 +372,8 @@ module Oper : sig val o_eq : 'a -> 'a -> bool val o_map : ('a -> 'b) -> 'a array -> 'b array - val o_map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array + val o_map2 : + source_position -> ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array (** @raise [NotSameLength] *) val o_reduce : ('a -> 'a -> 'a) -> 'a -> 'a array -> 'a @@ -386,35 +394,35 @@ module Oper : sig val o_mult_rat_rat : decimal -> decimal -> decimal val o_mult_mon_rat : money -> decimal -> money val o_mult_dur_int : duration -> integer -> duration - val o_div_int_int : integer -> integer -> decimal - val o_div_rat_rat : decimal -> decimal -> decimal - val o_div_mon_mon : money -> money -> decimal - val o_div_mon_rat : money -> decimal -> money - val o_div_dur_dur : duration -> duration -> decimal + val o_div_int_int : source_position -> integer -> integer -> decimal + val o_div_rat_rat : source_position -> decimal -> decimal -> decimal + val o_div_mon_mon : source_position -> money -> money -> decimal + val o_div_mon_rat : source_position -> money -> decimal -> money + val o_div_dur_dur : source_position -> duration -> duration -> decimal val o_lt_int_int : integer -> integer -> bool val o_lt_rat_rat : decimal -> decimal -> bool val o_lt_mon_mon : money -> money -> bool - val o_lt_dur_dur : duration -> duration -> bool + val o_lt_dur_dur : source_position -> duration -> duration -> bool val o_lt_dat_dat : date -> date -> bool val o_lte_int_int : integer -> integer -> bool val o_lte_rat_rat : decimal -> decimal -> bool val o_lte_mon_mon : money -> money -> bool - val o_lte_dur_dur : duration -> duration -> bool + val o_lte_dur_dur : source_position -> duration -> duration -> bool val o_lte_dat_dat : date -> date -> bool val o_gt_int_int : integer -> integer -> bool val o_gt_rat_rat : decimal -> decimal -> bool val o_gt_mon_mon : money -> money -> bool - val o_gt_dur_dur : duration -> duration -> bool + val o_gt_dur_dur : source_position -> duration -> duration -> bool val o_gt_dat_dat : date -> date -> bool val o_gte_int_int : integer -> integer -> bool val o_gte_rat_rat : decimal -> decimal -> bool val o_gte_mon_mon : money -> money -> bool - val o_gte_dur_dur : duration -> duration -> bool + val o_gte_dur_dur : source_position -> duration -> duration -> bool val o_gte_dat_dat : date -> date -> bool val o_eq_int_int : integer -> integer -> bool val o_eq_rat_rat : decimal -> decimal -> bool val o_eq_mon_mon : money -> money -> bool - val o_eq_dur_dur : duration -> duration -> bool + val o_eq_dur_dur : source_position -> duration -> duration -> bool val o_eq_dat_dat : date -> date -> bool val o_fold : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a end diff --git a/tests/arithmetic/bad/division_by_zero.catala_en b/tests/arithmetic/bad/division_by_zero.catala_en index 9f5e85ec..4022c9cc 100644 --- a/tests/arithmetic/bad/division_by_zero.catala_en +++ b/tests/arithmetic/bad/division_by_zero.catala_en @@ -33,23 +33,14 @@ scope Money: ```catala-test-inline $ catala Interpret -s Dec -[ERROR] division by zero at runtime +[ERROR] Error during evaluation: division by zero. -The division operator: ┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:20.23-20.30: └──┐ 20 │ definition i equals 1. / 0. │ ‾‾‾‾‾‾‾ └┬ `Division_by_zero` exception management └─ with decimals - -The null denominator: -┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:20.28-20.30: -└──┐ -20 │ definition i equals 1. / 0. - │ ‾‾ - └┬ `Division_by_zero` exception management - └─ with decimals #return code 123# ``` @@ -57,66 +48,39 @@ The null denominator: Fixme: the following should give the same result as above, but the optimisation pass propagates the position surrounding the `ErrorOnEmpty` and loses the position of the actual division expression which was in the `cons` of the default term. Unfortunately this is non-trivial due to the bindlib boxing tricks. ```catala-test-inline $ catala Interpret -O -s Dec -[ERROR] division by zero at runtime +[ERROR] Error during evaluation: division by zero. -The division operator: ┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:17.10-17.11: └──┐ 17 │ output i content decimal │ ‾ └┬ `Division_by_zero` exception management └─ with decimals - -The null denominator: -┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:20.28-20.30: -└──┐ -20 │ definition i equals 1. / 0. - │ ‾‾ - └┬ `Division_by_zero` exception management - └─ with decimals #return code 123# ``` ```catala-test-inline $ catala interpret -s Int -[ERROR] division by zero at runtime +[ERROR] Error during evaluation: division by zero. -The division operator: ┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:10.23-10.28: └──┐ 10 │ definition i equals 1 / 0 │ ‾‾‾‾‾ └┬ `Division_by_zero` exception management └─ with integers - -The null denominator: -┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:10.27-10.28: -└──┐ -10 │ definition i equals 1 / 0 - │ ‾ - └┬ `Division_by_zero` exception management - └─ with integers #return code 123# ``` ```catala-test-inline $ catala Interpret -s Money -[ERROR] division by zero at runtime +[ERROR] Error during evaluation: division by zero. -The division operator: ┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:30.23-30.35: └──┐ 30 │ definition i equals $10.0 / $0.0 │ ‾‾‾‾‾‾‾‾‾‾‾‾ └┬ `Division_by_zero` exception management └─ with money - -The null denominator: -┌─⯈ tests/arithmetic/bad/division_by_zero.catala_en:30.31-30.35: -└──┐ -30 │ definition i equals $10.0 / $0.0 - │ ‾‾‾‾ - └┬ `Division_by_zero` exception management - └─ with money #return code 123# ``` diff --git a/tests/backends/output/simple.c b/tests/backends/output/simple.c index 95aab2b5..b67e47d9 100644 --- a/tests/backends/output/simple.c +++ b/tests/backends/output/simple.c @@ -180,7 +180,7 @@ baz_struct baz_func(baz_in_struct baz_in) { option_1_enum match_arg = temp_a_3; if (match_arg.code == option_1_enum_none_1_cons) { void* /* unit */ dummy_var = match_arg.payload.none_1_cons; - catala_fatal_error_raised.code = catala_no_value_provided; + catala_fatal_error_raised.code = catala_no_value; catala_fatal_error_raised.position.filename = "tests/backends/simple.catala_en"; catala_fatal_error_raised.position.start_line = 11; catala_fatal_error_raised.position.start_column = 11; @@ -202,7 +202,7 @@ baz_struct baz_func(baz_in_struct baz_in) { option_1_enum match_arg_1 = temp_a_1; if (match_arg_1.code == option_1_enum_none_1_cons) { void* /* unit */ dummy_var = match_arg_1.payload.none_1_cons; - catala_fatal_error_raised.code = catala_no_value_provided; + catala_fatal_error_raised.code = catala_no_value; catala_fatal_error_raised.position.filename = "tests/backends/simple.catala_en"; catala_fatal_error_raised.position.start_line = 11; catala_fatal_error_raised.position.start_column = 11; @@ -360,7 +360,7 @@ baz_struct baz_func(baz_in_struct baz_in) { option_2_enum match_arg_4 = temp_b_1; if (match_arg_4.code == option_2_enum_none_2_cons) { void* /* unit */ dummy_var = match_arg_4.payload.none_2_cons; - catala_fatal_error_raised.code = catala_no_value_provided; + catala_fatal_error_raised.code = catala_no_value; catala_fatal_error_raised.position.filename = "tests/backends/simple.catala_en"; catala_fatal_error_raised.position.start_line = 12; catala_fatal_error_raised.position.start_column = 10; @@ -424,7 +424,7 @@ baz_struct baz_func(baz_in_struct baz_in) { option_3_enum match_arg_5 = temp_c_1; if (match_arg_5.code == option_3_enum_none_3_cons) { void* /* unit */ dummy_var = match_arg_5.payload.none_3_cons; - catala_fatal_error_raised.code = catala_no_value_provided; + catala_fatal_error_raised.code = catala_no_value; catala_fatal_error_raised.position.filename = "tests/backends/simple.catala_en"; catala_fatal_error_raised.position.start_line = 13; catala_fatal_error_raised.position.start_column = 10; diff --git a/tests/backends/python_name_clash.catala_en b/tests/backends/python_name_clash.catala_en index 013233b8..a121edea 100644 --- a/tests/backends/python_name_clash.catala_en +++ b/tests/backends/python_name_clash.catala_en @@ -104,18 +104,17 @@ def some_name(some_name_in:SomeNameIn): def temp_o_3(_:Unit): return False def temp_o_4(_:Unit): - raise EmptyError + raise Empty temp_o_5 = handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en", start_line=7, start_column=10, end_line=7, end_column=11, law_headings=[]), [temp_o], temp_o_3, temp_o_4) - except EmptyError: - temp_o_5 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/backends/python_name_clash.catala_en", - start_line=7, start_column=10, - end_line=7, end_column=11, - law_headings=[])) + except Empty: + raise NoValue(SourcePosition( + filename="tests/backends/python_name_clash.catala_en", + start_line=7, start_column=10, + end_line=7, end_column=11, law_headings=[])) o = temp_o_5 return SomeName(o = o) @@ -134,18 +133,17 @@ def b(b_in:BIn): def temp_result_3(_:Unit): return False def temp_result_4(_:Unit): - raise EmptyError + raise Empty temp_result_5 = handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en", start_line=16, start_column=14, end_line=16, end_column=25, law_headings=[]), [temp_result], temp_result_3, temp_result_4) - except EmptyError: - temp_result_5 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/backends/python_name_clash.catala_en", - start_line=16, start_column=14, - end_line=16, end_column=25, - law_headings=[])) + except Empty: + raise NoValue(SourcePosition( + filename="tests/backends/python_name_clash.catala_en", + start_line=16, start_column=14, + end_line=16, end_column=25, law_headings=[])) result = some_name(SomeNameIn(i_in = temp_result_5)) result_1 = SomeName(o = result.o) if True: diff --git a/tests/date/bad/uncomparable_duration.catala_en b/tests/date/bad/uncomparable_duration.catala_en index b1a6afb3..9169310d 100644 --- a/tests/date/bad/uncomparable_duration.catala_en +++ b/tests/date/bad/uncomparable_duration.catala_en @@ -40,85 +40,61 @@ scope Ge: definition d equals 1 month >= 2 day ``` +*Fixme*: these tests should use `test-scope` rather than `interpret` ; however, +compiling with optimisations enabled changes the positions at the moment, so +they are restricted until that is fixed (see the same issue in division by 0 tests) + ```catala-test-inline -$ catala test-scope Ge -[ERROR] Cannot compare together durations that cannot be converted to a - precise number of days +$ catala interpret -s Ge +[ERROR] Error during evaluation: comparing durations in different units (e.g. + months vs. days). -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:40.23-40.30: +┌─⯈ tests/date/bad/uncomparable_duration.catala_en:40.23-40.39: └──┐ 40 │ definition d equals 1 month >= 2 day - │ ‾‾‾‾‾‾‾ - └┬ `UncomparableDurations` exception management - └─ `>=` operator - -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:40.34-40.39: -└──┐ -40 │ definition d equals 1 month >= 2 day - │ ‾‾‾‾‾ + │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `>=` operator #return code 123# ``` ```catala-test-inline -$ catala test-scope Gt -[ERROR] Cannot compare together durations that cannot be converted to a - precise number of days +$ catala interpret -s Gt +[ERROR] Error during evaluation: comparing durations in different units (e.g. + months vs. days). -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:30.23-30.30: +┌─⯈ tests/date/bad/uncomparable_duration.catala_en:30.23-30.38: └──┐ 30 │ definition d equals 1 month > 2 day - │ ‾‾‾‾‾‾‾ - └┬ `UncomparableDurations` exception management - └─ `<=` operator - -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:30.33-30.38: -└──┐ -30 │ definition d equals 1 month > 2 day - │ ‾‾‾‾‾ + │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<=` operator #return code 123# ``` ```catala-test-inline -$ catala test-scope Le -[ERROR] Cannot compare together durations that cannot be converted to a - precise number of days +$ catala interpret -s Le +[ERROR] Error during evaluation: comparing durations in different units (e.g. + months vs. days). -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:20.23-20.30: +┌─⯈ tests/date/bad/uncomparable_duration.catala_en:20.23-20.39: └──┐ 20 │ definition d equals 1 month <= 2 day - │ ‾‾‾‾‾‾‾ - └┬ `UncomparableDurations` exception management - └─ `<=` operator - -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:20.34-20.39: -└──┐ -20 │ definition d equals 1 month <= 2 day - │ ‾‾‾‾‾ + │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<=` operator #return code 123# ``` ```catala-test-inline -$ catala test-scope Lt -[ERROR] Cannot compare together durations that cannot be converted to a - precise number of days +$ catala interpret -s Lt +[ERROR] Error during evaluation: comparing durations in different units (e.g. + months vs. days). -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:10.23-10.30: +┌─⯈ tests/date/bad/uncomparable_duration.catala_en:10.23-10.38: └──┐ 10 │ definition d equals 1 month < 2 day - │ ‾‾‾‾‾‾‾ - └┬ `UncomparableDurations` exception management - └─ `<` operator - -┌─⯈ tests/date/bad/uncomparable_duration.catala_en:10.33-10.38: -└──┐ -10 │ definition d equals 1 month < 2 day - │ ‾‾‾‾‾ + │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ └┬ `UncomparableDurations` exception management └─ `<` operator #return code 123# diff --git a/tests/func/good/closure_conversion_reduce.catala_en b/tests/func/good/closure_conversion_reduce.catala_en index 35f76fa4..74adfd01 100644 --- a/tests/func/good/closure_conversion_reduce.catala_en +++ b/tests/func/good/closure_conversion_reduce.catala_en @@ -75,7 +75,7 @@ let scope S (S_in: S_in {x_in: list of integer}): S {y: integer} = (λ () → false) (λ () → ENone ())) with - | ENone → raise NoValueProvided + | ENone → error NoValue | ESome arg → arg in return { S y = y; } diff --git a/tests/func/good/scope_call_func_struct_closure.catala_en b/tests/func/good/scope_call_func_struct_closure.catala_en index 9096a8bb..0236d836 100644 --- a/tests/func/good/scope_call_func_struct_closure.catala_en +++ b/tests/func/good/scope_call_func_struct_closure.catala_en @@ -124,7 +124,7 @@ let scope Foo match (handle_default_opt [b.0 b.1 ()] (λ () → true) (λ () → ESome true)) with - | ENone → raise NoValueProvided + | ENone → error NoValue | ESome arg → arg in let set r : diff --git a/tests/modules/good/output/mod_def.ml b/tests/modules/good/output/mod_def.ml index b1a3b8df..c1ebe0b5 100644 --- a/tests/modules/good/output/mod_def.ml +++ b/tests/modules/good/output/mod_def.ml @@ -29,46 +29,53 @@ let s (s_in: S_in.t) : S.t = let sr_: money = try (handle_default - {filename = "tests/modules/good/mod_def.catala_en"; start_line=16; - start_column=10; end_line=16; end_column=12; - law_headings=["Test modules + inclusions 1"]} + {filename="tests/modules/good/mod_def.catala_en"; + start_line=16; start_column=10; end_line=16; end_column=12; + law_headings=["Test modules + inclusions 1"]} ([|(fun (_: unit) -> handle_default - {filename = "tests/modules/good/mod_def.catala_en"; - start_line=16; start_column=10; - end_line=16; end_column=12; - law_headings=["Test modules + inclusions 1"]} ([||]) + {filename="tests/modules/good/mod_def.catala_en"; + start_line=16; start_column=10; end_line=16; end_column=12; + law_headings=["Test modules + inclusions 1"]} ([||]) (fun (_: unit) -> true) (fun (_: unit) -> money_of_cents_string "100000"))|]) - (fun (_: unit) -> false) (fun (_: unit) -> raise EmptyError)) + (fun (_: unit) -> false) (fun (_: unit) -> raise Empty)) with - EmptyError -> (raise (NoValueProvided - {filename = "tests/modules/good/mod_def.catala_en"; start_line=16; - start_column=10; end_line=16; end_column=12; - law_headings=["Test modules + inclusions 1"]})) in + Empty -> (raise + (Runtime_ocaml.Runtime.Error (NoValue, {filename="tests/modules/good/mod_def.catala_en"; + start_line=16; start_column=10; + end_line=16; end_column=12; + law_headings=["Test modules + inclusions 1"]}))) + in let e1_: Enum1.t = try (handle_default - {filename = "tests/modules/good/mod_def.catala_en"; start_line=17; - start_column=10; end_line=17; end_column=12; - law_headings=["Test modules + inclusions 1"]} + {filename="tests/modules/good/mod_def.catala_en"; + start_line=17; start_column=10; end_line=17; end_column=12; + law_headings=["Test modules + inclusions 1"]} ([|(fun (_: unit) -> handle_default - {filename = "tests/modules/good/mod_def.catala_en"; - start_line=17; start_column=10; - end_line=17; end_column=12; - law_headings=["Test modules + inclusions 1"]} ([||]) + {filename="tests/modules/good/mod_def.catala_en"; + start_line=17; start_column=10; end_line=17; end_column=12; + law_headings=["Test modules + inclusions 1"]} ([||]) (fun (_: unit) -> true) (fun (_: unit) -> Enum1.Maybe ()))|]) - (fun (_: unit) -> false) (fun (_: unit) -> raise EmptyError)) + (fun (_: unit) -> false) (fun (_: unit) -> raise Empty)) with - EmptyError -> (raise (NoValueProvided - {filename = "tests/modules/good/mod_def.catala_en"; start_line=17; - start_column=10; end_line=17; end_column=12; - law_headings=["Test modules + inclusions 1"]})) in + Empty -> (raise + (Runtime_ocaml.Runtime.Error (NoValue, {filename="tests/modules/good/mod_def.catala_en"; + start_line=17; start_column=10; + end_line=17; end_column=12; + law_headings=["Test modules + inclusions 1"]}))) + in {S.sr = sr_; S.e1 = e1_} let half_ : integer -> decimal = - fun (x_: integer) -> o_div_int_int x_ (integer_of_string "2") + fun (x_: integer) -> + o_div_int_int + {filename="tests/modules/good/mod_def.catala_en"; + start_line=21; start_column=10; end_line=21; end_column=15; + law_headings=["Test modules + inclusions 1"]} x_ (integer_of_string + "2") let () = Runtime_ocaml.Runtime.register_module "Mod_def" diff --git a/tests/modules/good/prorata_external.ml b/tests/modules/good/prorata_external.ml index 043bcbde..528e1f16 100644 --- a/tests/modules/good/prorata_external.ml +++ b/tests/modules/good/prorata_external.ml @@ -5,12 +5,14 @@ open Oper let mzero = money_of_units_int 0 +let pos = {filename=__FILE__; start_line=0; start_column=0; end_line=0; end_column=0; law_headings=[]} + let prorata_ : money -> (money array) -> (money array) = fun (amount: money) (weights: money array) -> let w_total = Array.fold_left o_add_mon_mon mzero weights in let rem, a = Array.fold_left_map (fun rem w -> - let r = o_mult_mon_rat amount (o_div_mon_mon w w_total) in + let r = o_mult_mon_rat amount (o_div_mon_mon pos w w_total) in o_sub_mon_mon rem r, r) amount weights in @@ -25,7 +27,7 @@ let prorata2_ : money -> (money array) -> (money array) = let r = o_mult_mon_rat rem_amount - (o_div_mon_mon w rem_weights) in + (o_div_mon_mon pos w rem_weights) in (o_sub_mon_mon rem_amount r, o_sub_mon_mon rem_weights w), r) (amount, w_total) weights in diff --git a/tests/name_resolution/good/let_in2.catala_en b/tests/name_resolution/good/let_in2.catala_en index 00ccae83..890b8604 100644 --- a/tests/name_resolution/good/let_in2.catala_en +++ b/tests/name_resolution/good/let_in2.catala_en @@ -51,38 +51,40 @@ let s (s_in: S_in.t) : S.t = let a_: bool = try (handle_default - {filename = "tests/name_resolution/good/let_in2.catala_en"; - start_line=7; start_column=18; end_line=7; end_column=19; - law_headings=["Article"]} ([|(fun (_: unit) -> a_ ())|]) + {filename="tests/name_resolution/good/let_in2.catala_en"; + start_line=7; start_column=18; end_line=7; end_column=19; + law_headings=["Article"]} ([|(fun (_: unit) -> a_ ())|]) (fun (_: unit) -> true) (fun (_: unit) -> try (handle_default - {filename = "tests/name_resolution/good/let_in2.catala_en"; - start_line=7; start_column=18; end_line=7; end_column=19; - law_headings=["Article"]} + {filename="tests/name_resolution/good/let_in2.catala_en"; + start_line=7; start_column=18; end_line=7; end_column=19; + law_headings=["Article"]} ([|(fun (_: unit) -> handle_default - {filename = "tests/name_resolution/good/let_in2.catala_en"; - start_line=7; start_column=18; - end_line=7; end_column=19; - law_headings=["Article"]} ([||]) + {filename="tests/name_resolution/good/let_in2.catala_en"; + start_line=7; start_column=18; + end_line=7; end_column=19; + law_headings=["Article"]} ([||]) (fun (_: unit) -> true) (fun (_: unit) -> (let a_ : bool = false in (let a_ : bool = (o_or a_ true) in a_))))|]) (fun (_: unit) -> false) - (fun (_: unit) -> raise EmptyError)) + (fun (_: unit) -> raise Empty)) with - EmptyError -> (raise (NoValueProvided - {filename = "tests/name_resolution/good/let_in2.catala_en"; - start_line=7; start_column=18; end_line=7; end_column=19; - law_headings=["Article"]})))) + Empty -> (raise + (Runtime_ocaml.Runtime.Error (NoValue, {filename="tests/name_resolution/good/let_in2.catala_en"; + start_line=7; start_column=18; + end_line=7; end_column=19; + law_headings=["Article"]}))))) with - EmptyError -> (raise (NoValueProvided - {filename = "tests/name_resolution/good/let_in2.catala_en"; - start_line=7; start_column=18; end_line=7; end_column=19; - law_headings=["Article"]})) in + Empty -> (raise + (Runtime_ocaml.Runtime.Error (NoValue, {filename="tests/name_resolution/good/let_in2.catala_en"; + start_line=7; start_column=18; + end_line=7; end_column=19; + law_headings=["Article"]}))) in {S.a = a_} let () = diff --git a/tests/name_resolution/good/toplevel_defs.catala_en b/tests/name_resolution/good/toplevel_defs.catala_en index 4cf36c7b..236b3375 100644 --- a/tests/name_resolution/good/toplevel_defs.catala_en +++ b/tests/name_resolution/good/toplevel_defs.catala_en @@ -133,10 +133,10 @@ let S2_6 (S2_in_10: S2_in) = return false; decl temp_a_21 : unit → decimal; let func temp_a_21 (__22 : unit) = - raise EmptyError; + raise Empty; temp_a_12 = handle_default [temp_a_13] temp_a_19 temp_a_21 - with EmptyError: - raise NoValueProvided; + with Empty: + fatal NoValue; decl a_11 : decimal; a_11 = temp_a_12; return S2 {"a": a_11} @@ -158,10 +158,10 @@ let S3_7 (S3_in_23: S3_in) = return false; decl temp_a_34 : unit → decimal; let func temp_a_34 (__35 : unit) = - raise EmptyError; + raise Empty; temp_a_25 = handle_default [temp_a_26] temp_a_32 temp_a_34 - with EmptyError: - raise NoValueProvided; + with Empty: + fatal NoValue; decl a_24 : decimal; a_24 = temp_a_25; return S3 {"a": a_24} @@ -183,10 +183,10 @@ let S4_8 (S4_in_36: S4_in) = return false; decl temp_a_47 : unit → decimal; let func temp_a_47 (__48 : unit) = - raise EmptyError; + raise Empty; temp_a_38 = handle_default [temp_a_39] temp_a_45 temp_a_47 - with EmptyError: - raise NoValueProvided; + with Empty: + fatal NoValue; decl a_37 : decimal; a_37 = temp_a_38; return S4 {"a": a_37} @@ -208,10 +208,10 @@ let S_9 (S_in_49: S_in) = return false; decl temp_a_72 : unit → decimal; let func temp_a_72 (__73 : unit) = - raise EmptyError; + raise Empty; temp_a_63 = handle_default [temp_a_64] temp_a_70 temp_a_72 - with EmptyError: - raise NoValueProvided; + with Empty: + fatal NoValue; decl a_50 : decimal; a_50 = temp_a_63; decl temp_b_52 : A {y: bool; z: decimal}; @@ -230,10 +230,10 @@ let S_9 (S_in_49: S_in) = return false; decl temp_b_61 : unit → A {y: bool; z: decimal}; let func temp_b_61 (__62 : unit) = - raise EmptyError; + raise Empty; temp_b_52 = handle_default [temp_b_53] temp_b_59 temp_b_61 - with EmptyError: - raise NoValueProvided; + with Empty: + fatal NoValue; decl b_51 : A {y: bool; z: decimal}; b_51 = temp_b_52; return S {"a": a_50, "b": b_51} @@ -433,18 +433,18 @@ def s2(s2_in:S2In): def temp_a_3(_:Unit): return False def temp_a_4(_:Unit): - raise EmptyError + raise Empty temp_a_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=45, start_column=10, end_line=45, end_column=11, law_headings=["Test toplevel function defs"]), [temp_a], temp_a_3, temp_a_4) - except EmptyError: - temp_a_5 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=45, start_column=10, - end_line=45, end_column=11, - law_headings=["Test toplevel function defs"])) + except Empty: + raise NoValue(SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", + start_line=45, start_column=10, + end_line=45, end_column=11, + law_headings=["Test toplevel function defs"])) a = temp_a_5 return S2(a = a) @@ -465,18 +465,18 @@ def s3(s3_in:S3In): def temp_a_9(_:Unit): return False def temp_a_10(_:Unit): - raise EmptyError + raise Empty temp_a_11 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=65, start_column=10, end_line=65, end_column=11, law_headings=["Test function def with two args"]), [temp_a_6], temp_a_9, temp_a_10) - except EmptyError: - temp_a_11 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=65, start_column=10, - end_line=65, end_column=11, - law_headings=["Test function def with two args"])) + except Empty: + raise NoValue(SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", + start_line=65, start_column=10, + end_line=65, end_column=11, + law_headings=["Test function def with two args"])) a_1 = temp_a_11 return S3(a = a_1) @@ -495,18 +495,18 @@ def s4(s4_in:S4In): def temp_a_15(_:Unit): return False def temp_a_16(_:Unit): - raise EmptyError + raise Empty temp_a_17 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=88, start_column=10, end_line=88, end_column=11, law_headings=["Test inline defs in toplevel defs"]), [temp_a_12], temp_a_15, temp_a_16) - except EmptyError: - temp_a_17 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=88, start_column=10, - end_line=88, end_column=11, - law_headings=["Test inline defs in toplevel defs"])) + except Empty: + raise NoValue(SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", + start_line=88, start_column=10, + end_line=88, end_column=11, + law_headings=["Test inline defs in toplevel defs"])) a_2 = temp_a_17 return S4(a = a_2) @@ -525,18 +525,18 @@ def s(s_in:SIn): def temp_a_21(_:Unit): return False def temp_a_22(_:Unit): - raise EmptyError + raise Empty temp_a_23 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=7, start_column=10, end_line=7, end_column=11, law_headings=["Test basic toplevel values defs"]), [temp_a_18], temp_a_21, temp_a_22) - except EmptyError: - temp_a_23 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=7, start_column=10, - end_line=7, end_column=11, - law_headings=["Test basic toplevel values defs"])) + except Empty: + raise NoValue(SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", + start_line=7, start_column=10, + end_line=7, end_column=11, + law_headings=["Test basic toplevel values defs"])) a_3 = temp_a_23 try: def temp_b(_:Unit): @@ -552,18 +552,18 @@ def s(s_in:SIn): def temp_b_3(_:Unit): return False def temp_b_4(_:Unit): - raise EmptyError + raise Empty temp_b_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", start_line=8, start_column=10, end_line=8, end_column=11, law_headings=["Test basic toplevel values defs"]), [temp_b], temp_b_3, temp_b_4) - except EmptyError: - temp_b_5 = dead_value - raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en", - start_line=8, start_column=10, - end_line=8, end_column=11, - law_headings=["Test basic toplevel values defs"])) + except Empty: + raise NoValue(SourcePosition( + filename="tests/name_resolution/good/toplevel_defs.catala_en", + start_line=8, start_column=10, + end_line=8, end_column=11, + law_headings=["Test basic toplevel values defs"])) b = temp_b_5 return S(a = a_3, b = b) ``` diff --git a/tests/scope/good/nothing.catala_en b/tests/scope/good/nothing.catala_en index ebc10356..f4643a8a 100644 --- a/tests/scope/good/nothing.catala_en +++ b/tests/scope/good/nothing.catala_en @@ -33,7 +33,7 @@ $ catala Scalc -s Foo2 -O -t └─ Test let Foo2_3 (Foo2_in_2: Foo2_in) = decl temp_bar_4 : integer; - raise NoValueProvided; + fatal NoValue; decl bar_3 : integer; bar_3 = temp_bar_4; return Foo2 {"bar": bar_3} diff --git a/tests/scope/good/simple.catala_en b/tests/scope/good/simple.catala_en index 1c7d722a..9907718b 100644 --- a/tests/scope/good/simple.catala_en +++ b/tests/scope/good/simple.catala_en @@ -24,8 +24,8 @@ let scope Foo (Foo_in: Foo_in): Foo {bar: integer} = handle_default [λ () → handle_default [] (λ () → true) (λ () → 0)] (λ () → false) - (λ () → raise EmptyError) - with EmptyError -> raise NoValueProvided + (λ () → raise Empty) + with Empty -> error NoValue in return { Foo bar = bar; } ```