CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Unify runtime error handling

Browse Source 
- 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
This commit is contained in:
Louis Gesbert 2024-04-26 18:31:26 +02:00
parent 791ae3229b
commit 9d07015864
44 changed files with 602 additions and 616 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
compiler/dcalc/from_scopelang.ml
View File

@ -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

2
compiler/desugared/ast.ml
View File

@ -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)))

12
compiler/desugared/from_surface.ml
View File

@ -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")

7
compiler/lcalc/closure_conversion.ml
View File

@ -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"
| _ -> .

6
compiler/lcalc/compile_with_exceptions.ml
View File

@ -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
| _ -> .

10
compiler/lcalc/compile_without_exceptions.ml
View File

@ -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
| _ -> .

86
compiler/lcalc/to_ocaml.ml
View File

@ -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 "@[<hov 2>[%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
"@[<hov 1>{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 "@[<hov 2>[%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@ @[<hov 2>{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@ @[<hov 2>{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
"@[<hov 2>%s@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a@]"
Format.fprintf fmt "@[<hov 2>%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) :
"@[<hov 2> if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@]"
format_with_parens cond format_with_parens etrue format_with_parens efalse
| EAppOp { op; args; _ } ->
Format.fprintf fmt "@[<hov 2>%s@ %a@]" (Operator.name op)
Format.fprintf fmt "@[<hov 2>%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
"@[<hov 2>if@ %a@ then@ ()@ else@ raise (AssertionFailed @[<hov \
2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ end_line=%d; \
end_column=%d;@ law_headings=%a}@])@]"
"@[<hov 2>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 "@[<hv>@[<hov 2>try@ %a@]@ with@]@ @[<hov 2>%a@ ->@ %a@]"
format_with_parens body format_exception
(exn, Expr.pos e)
(Empty, Expr.pos e)
format_with_parens handler
| _ -> .

14
compiler/plugins/explain.ml
View File

@ -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; _ } ->

12
compiler/plugins/lazy_interp.ml
View File

@ -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 "@[<hov 5>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))

5
compiler/scalc/ast.ml
View File

@ -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;

15
compiler/scalc/from_lcalc.ml
View File

@ -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 *)

11
compiler/scalc/print.ml
View File

@ -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 "@[<v 2>%a%a@ %a@]@\n@[<v 2>%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 "@[<hov 2>%a %a@]" Print.keyword "raise" Print.except
except
Empty
| SFatalError err ->
Format.fprintf fmt "@[<hov 2>%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 "@[<v 2>%a @[<hov 2>%a@]%a@ %a@ @]@[<v 2>%a%a@ %a@]"
Print.keyword "if"

16
compiler/scalc/to_c.ml
View File

@ -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 "@[<hov 2>%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 "@[<hov 2>%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 } ->

48
compiler/scalc/to_python.ml
View File

@ -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(@[<hov 0>SourcePosition(@[<hov 0>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(@[<hov 0>SourcePosition(@[<hov 0>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
"@[<hov 4>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 "@[<hov 4>%a = %a@]" format_var (Mark.remove v)
(format_expression ctx) e
| STryExcept { try_block = try_b; except; with_block = catch_b } ->
Format.fprintf fmt "@[<hov 4>try:@\n%a@]@\n@[<hov 4>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 "@[<hov 4>raise %a@]" format_exception
(except, Mark.get s)
| STryWEmpty { try_block = try_b; with_block = catch_b } ->
Format.fprintf fmt "@[<v 4>try:@,%a@]@\n@[<v 4>except Empty:@,%a@]"
(format_block ctx) try_b (format_block ctx) catch_b
| SRaiseEmpty -> Format.fprintf fmt "raise Empty"
| SFatalError err ->
Format.fprintf fmt "@[<hov 4>raise %a@]" format_error (err, Mark.get s)
| SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } ->
Format.fprintf fmt "@[<hov 4>if %a:@\n%a@]@\n@[<hov 4>else:@\n%a@]"
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2

53
compiler/scalc/to_r.ml
View File

@ -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(@[<hov 0>catala_position(@[<hov \
0>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(@[<hov 0>catala_position(@[<hov \
0>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
"@[<hov 2>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 "@[<hov 2>%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*)
"@[<hov 2>tryCatch(@[<hov 2>{@;\
%a@;\
}@],@;\
%a = function(dummy__arg) @[<hov 2>{@;\
catala_empty_error() = function(dummy__arg) @[<hov 2>{@;\
%a@;\
}@])@]"
(format_block ctx) try_b format_exception_name except (format_block ctx)
catch_b
| SRaise except ->
Format.fprintf fmt "@[<hov 2>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 "@[<hov 2>stop(%a)@]" format_error (err, Mark.get s)
| SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } ->
Format.fprintf fmt
"@[<hov 2>if (%a) {@\n%a@]@\n@[<hov 2>} else {@\n%a@]@\n}"

12
compiler/scopelang/from_desugared.ml
View File

@ -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

8
compiler/shared_ast/definitions.ml
View File

@ -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

105
compiler/shared_ast/expr.ml
View File

@ -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

12
compiler/shared_ast/expr.mli
View File

@ -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 *)

126
compiler/shared_ast/interpreter.ml
View File

@ -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)

13
compiler/shared_ast/optimizations.ml
View File

@ -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

31
compiler/shared_ast/print.ml
View File

@ -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 "@{<red>%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 "@[<hov 2>%a@ %a@]" op_style "error_empty"
(rhs exprc) e'
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" keyword "assert" punctuation
"(" (rhs exprc) e' punctuation ")"
| ECatch { body; exn; handler } ->
| EFatalError err ->
Format.fprintf fmt "@[<hov 2>%a@ @{<red>%s@}@]" keyword "error"
(Runtime.error_to_string err)
| ECatchEmpty { body; handler } ->
Format.fprintf fmt
"@[<hv 0>@[<hov 2>%a@ %a@]@ @[<hov 2>%a@ %a ->@ %a@]@]" keyword "try"
expr body keyword "with" except exn (rhs exprc) handler
| ERaise exn ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except exn
expr body keyword "with" except Empty (rhs exprc) handler
| ERaiseEmpty ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except Empty
| ELocation loc -> location fmt loc
| EDStructAccess { e; field; _ } ->
Format.fprintf fmt "@[<hv 2>%a%a@,%a%a%a@]" (lhs exprc) e punctuation
@ -1130,12 +1137,12 @@ module UserFacing = struct
| EInj { name = _; cons; e } ->
Format.fprintf ppf "@[<hov 2>%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 "<function>"
| EExternal _ -> Format.pp_print_string ppf "<external>"
| 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

1
compiler/shared_ast/print.mli
View File

@ -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

11
compiler/shared_ast/typing.ml
View File

@ -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

4
compiler/verification/conditions.ml
View File

@ -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)

5
compiler/verification/z3backend.real.ml
View File

@ -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"
| _ -> .

4
doc/syntax/syntax_en.catala_en
View File

@ -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#

4
doc/syntax/syntax_fr.catala_fr
View File

@ -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#

14
runtimes/c/runtime.c
View File

@ -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

20
runtimes/jsoo/runtime.ml
View File

@ -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

124
runtimes/ocaml/runtime.ml
View File

@ -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

58
runtimes/ocaml/runtime.mli
View File

@ -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

44
tests/arithmetic/bad/division_by_zero.catala_en
View File

@ -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#
```

8
tests/backends/output/simple.c
View File

@ -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;

26
tests/backends/python_name_clash.catala_en
View File

@ -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:

72
tests/date/bad/uncomparable_duration.catala_en
View File

@ -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#

2
tests/func/good/closure_conversion_reduce.catala_en
View File

@ -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; }

2
tests/func/good/scope_call_func_struct_closure.catala_en
View File

@ -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 :

57
tests/modules/good/output/mod_def.ml
View File

@ -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"

6
tests/modules/good/prorata_external.ml
View File

@ -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

40
tests/name_resolution/good/let_in2.catala_en
View File

@ -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 () =

100
tests/name_resolution/good/toplevel_defs.catala_en
View File

@ -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)
```

2
tests/scope/good/nothing.catala_en
View File

@ -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}

4
tests/scope/good/simple.catala_en
View File

@ -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; }
```