CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-07-25 04:50:34 +03:00
Code Issues Projects Releases Wiki Activity

Remove the "with-exceptions" backend from the compiler (#641)

Browse Source
This commit is contained in:
Louis Gesbert 2024-07-08 15:31:26 +02:00 committed by GitHub
commit a7eec8fd72
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
61 changed files with 1506 additions and 1727 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -217,7 +217,7 @@ tests: test
TEST_FLAGS_LIST = ""\
-O \
--lcalc \
--lcalc,--avoid-exceptions,-O
--lcalc,--closure-conversion,-O
# Does not include running dune (to avoid duplication when run among bigger rules)
testsuite-base: .FORCE

12
build_system/clerk_driver.ml
View File

@ -75,8 +75,8 @@ module Cli = struct
tests. Comma-separated list. A subset may also be applied to the \
compilation of modules, as needed.\n\
WARNING: flag shortcuts are not allowed here (i.e. don't use \
non-ambiguous prefixes such as $(b,--avoid-ex) for \
$(b,--avoid-exceptions))\n\
non-ambiguous prefixes such as $(b,--closure) for \
$(b,--closure-conversion))\n\
NOTE: if this is set, all inline tests that are $(i,not) \
$(b,catala test-scope) are skipped to avoid redundant testing.")
@ -481,17 +481,13 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
let catala_flags_ocaml =
List.filter
(function
| "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" ->
true
| _ -> false)
| "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false)
test_flags
in
let catala_flags_python =
List.filter
(function
| "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" ->
true
| _ -> false)
| "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false)
test_flags
in
let ocaml_flags = Lazy.force Poll.ocaml_include_flags in

78
build_system/clerk_report.ml
View File

@ -69,16 +69,68 @@ let has_command cmd =
let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in
Sys.command check_cmd = 0
let longuest_common_prefix_length s1 s2 =
let len = min (String.length s1) (String.length s2) in
let rec aux i =
if i >= len then i
else
let c1 = String.get_utf_8_uchar s1 i in
let c2 = String.get_utf_8_uchar s2 i in
if c1 = c2 then aux (i + Uchar.utf_decode_length c1) else i
type 'a diff = Eq of 'a | Subs of 'a * 'a | Del of 'a | Add of 'a
let colordiff_str s1 s2 =
let split_re =
Re.(compile (alt [set "=()[]{};-,"; rep1 space; rep1 digit]))
in
aux 0
let split s =
Re.Seq.split_full split_re s
|> Seq.map (function `Text t -> t | `Delim g -> Re.Group.get g 0)
in
let a1 = Array.of_seq (split s1) in
let n1 = Array.length a1 in
let a2 = Array.of_seq (split s2) in
let n2 = Array.length a2 in
let d = Array.make_matrix n1 n2 (0, []) in
let get i1 i2 =
if i1 < 0 then
( i2 + 1,
Array.fold_left (fun acc c -> Add c :: acc) [] (Array.sub a2 0 (i2 + 1))
)
else if i2 < 0 then
( i1 + 1,
Array.fold_left (fun acc c -> Del c :: acc) [] (Array.sub a1 0 (i1 + 1))
)
else d.(i1).(i2)
in
for i1 = 0 to n1 - 1 do
for i2 = 0 to n2 - 1 do
if a1.(i1) = a2.(i2) then
let eq, eqops = get (i1 - 1) (i2 - 1) in
d.(i1).(i2) <- eq, Eq a1.(i1) :: eqops
else
let del, delops = get (i1 - 1) i2 in
let add, addops = get i1 (i2 - 1) in
let subs, subsops = get (i1 - 1) (i2 - 1) in
if subs <= del && subs <= add then
d.(i1).(i2) <- subs + 1, Subs (a1.(i1), a2.(i2)) :: subsops
else if del <= add then d.(i1).(i2) <- del + 1, Del a1.(i1) :: delops
else d.(i1).(i2) <- add + 1, Add a2.(i2) :: addops
done
done;
let _, rops = get (n1 - 1) (n2 - 1) in
let ops = List.rev rops in
let pr_left ppf () =
Format.pp_print_list
~pp_sep:(fun _ () -> ())
(fun ppf -> function
| Eq w -> Format.fprintf ppf "%s" w
| Subs (w, _) | Del w -> Format.fprintf ppf "@{<green>%s@}" w
| Add _ -> ())
ppf ops
in
let pr_right ppf () =
Format.pp_print_list
~pp_sep:(fun _ () -> ())
(fun ppf -> function
| Eq w -> Format.fprintf ppf "%s" w
| Subs (_, w) | Add w -> Format.fprintf ppf "@{<red>%s@}" w
| Del _ -> ())
ppf ops
in
pr_left, pr_right
let diff_command =
let has_gnu_diff () =
@ -139,10 +191,8 @@ let diff_command =
else Format.fprintf ppf "%s@{<blue>│@}@{<red>%s@}" l r
| '<' -> Format.fprintf ppf "%s@{<blue>│@}@{<red>-@}" l
| '|' ->
let w = longuest_common_prefix_length (" " ^ l) r in
Format.fprintf ppf "%s@{<blue>│@}%s@{<red>%s@}" l
(String.sub r 0 w)
(String.sub r w (String.length r - w))
let ppleft, ppright = colordiff_str l r in
Format.fprintf ppf "%a@{<blue>│@}%a" ppleft () ppright ()
| _ -> Format.pp_print_string ppf li))
ppf )
| Some cmd_opt | (None as cmd_opt) ->
@ -287,7 +337,7 @@ let print_box tcolor ppf title (pcontents : box -> unit) =
(fun ppf ->
Format.pp_print_tab ppf ();
Format.fprintf ppf "%t┃@}@," tcolor)
ppf ("%t@<1>%s@} " ^^ fmt) tcolor "┃");
ppf ("%t@<1>%s@} " ^^ fmt) tcolor "┃");
}
in
pcontents box;

11
compiler/catala_utils/cli.ml
View File

@ -334,13 +334,6 @@ module Flags = struct
~env:(Cmd.Env.info "CATALA_OPTIMIZE")
~doc:"Run compiler optimizations."
let avoid_exceptions =
value
& flag
& info ["avoid-exceptions"]
~env:(Cmd.Env.info "CATALA_AVOID_EXCEPTIONS")
~doc:"Compiles the default calculus without exceptions."
let keep_special_ops =
value
& flag
@ -381,9 +374,7 @@ module Flags = struct
value
& flag
& info ["closure-conversion"]
~doc:
"Performs closure conversion on the lambda calculus. Implies \
$(b,--avoid-exceptions)."
~doc:"Performs closure conversion on the lambda calculus."
let disable_counterexamples =
value

1
compiler/catala_utils/cli.mli
View File

@ -55,7 +55,6 @@ module Flags : sig
val ex_variable : string Term.t
val output : raw_file option Term.t
val optimize : bool Term.t
val avoid_exceptions : bool Term.t
val closure_conversion : bool Term.t
val keep_special_ops : bool Term.t
val monomorphize_types : bool Term.t

12
compiler/catala_utils/hash.ml
View File

@ -36,22 +36,16 @@ module Flags : sig
type nonrec t = private t
val pass :
(t -> 'a) ->
avoid_exceptions:bool ->
closure_conversion:bool ->
monomorphize_types:bool ->
'a
(t -> 'a) -> closure_conversion:bool -> monomorphize_types:bool -> 'a
val of_t : int -> t
end = struct
type nonrec t = t
let pass k ~avoid_exceptions ~closure_conversion ~monomorphize_types =
let avoid_exceptions = avoid_exceptions || closure_conversion in
let pass k ~closure_conversion ~monomorphize_types =
(* Should not affect the call convention or actual interfaces: include,
optimize, check_invariants, typed *)
!(avoid_exceptions : bool)
% !(closure_conversion : bool)
!(closure_conversion : bool)
% !(monomorphize_types : bool)
% (* The following may not affect the call convention, but we want it set in
an homogeneous way *)

7
compiler/catala_utils/hash.mli
View File

@ -58,12 +58,7 @@ val map :
first argument is expected to be a [Foo.Map.fold] function. The result is
independent of the ordering of the map. *)
val finalise :
t ->
avoid_exceptions:bool ->
closure_conversion:bool ->
monomorphize_types:bool ->
full
val finalise : t -> closure_conversion:bool -> monomorphize_types:bool -> full
(** Turns a raw interface hash into a full hash, ready for printing *)
val to_string : full -> string

7
compiler/catala_utils/message.ml
View File

@ -111,8 +111,7 @@ let print_time_marker =
let old_time = !time in
time := new_time;
let delta = (new_time -. old_time) *. 1000. in
if delta > 50. then
Format.fprintf ppf "@{<bold;black>[TIME] %.0fms@}@\n" delta
if delta > 50. then Format.fprintf ppf " @{<bold;black>%.0fms@}" delta
let pp_marker ?extra_label target ppf =
let open Ocolor_types in
@ -129,10 +128,10 @@ let pp_marker ?extra_label target ppf =
| None -> str
| Some lbl -> Printf.sprintf "%s %s" str lbl
in
if target = Debug then print_time_marker ppf ();
Format.pp_open_stag ppf (Ocolor_format.Ocolor_styles_tag tags);
Format.pp_print_string ppf str;
Format.pp_close_stag ppf ()
Format.pp_close_stag ppf ();
if target = Debug then print_time_marker ppf ()
(**{2 Printers}*)

88
compiler/driver.ml
View File

@ -227,7 +227,6 @@ module Passes = struct
~optimize
~check_invariants
~(typed : ty mark)
~avoid_exceptions
~closure_conversion
~monomorphize_types :
typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
@ -235,23 +234,11 @@ module Passes = struct
dcalc options ~includes ~optimize ~check_invariants ~typed
in
debug_pass_name "lcalc";
let avoid_exceptions = avoid_exceptions || closure_conversion in
(* --closure-conversion implies --avoid-exceptions *)
let prg =
if avoid_exceptions && options.trace then
Message.warning
"It is discouraged to use option @{<yellow>--avoid-exceptions@} if \
you@ also@ need@ @{<yellow>--trace@},@ the@ resulting@ trace@ may@ \
be@ unreliable@ at@ the@ moment.";
match avoid_exceptions, typed with
| true, Untyped _ ->
Lcalc.From_dcalc.translate_program_without_exceptions prg
| true, Typed _ ->
Lcalc.From_dcalc.translate_program_without_exceptions prg
| false, Typed _ -> Lcalc.From_dcalc.translate_program_with_exceptions prg
| false, Untyped _ ->
Lcalc.From_dcalc.translate_program_with_exceptions prg
| _, Custom _ -> invalid_arg "Driver.Passes.lcalc"
match typed with
| Untyped _ -> Lcalc.From_dcalc.translate_program prg
| Typed _ -> Lcalc.From_dcalc.translate_program prg
| Custom _ -> invalid_arg "Driver.Passes.lcalc"
in
let prg =
if optimize then begin
@ -295,7 +282,6 @@ module Passes = struct
~includes
~optimize
~check_invariants
~avoid_exceptions
~closure_conversion
~keep_special_ops
~dead_value_assignment
@ -304,7 +290,7 @@ module Passes = struct
Scalc.Ast.program * Scopelang.Dependency.TVertex.t list =
let prg, type_ordering =
lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed
~avoid_exceptions ~closure_conversion ~monomorphize_types
~closure_conversion ~monomorphize_types
in
debug_pass_name "scalc";
( Scalc.From_lcalc.translate_program
@ -710,10 +696,7 @@ module Commands = struct
Passes.dcalc options ~includes ~optimize ~check_invariants ~typed
in
Interpreter.load_runtime_modules
~hashf:
Hash.(
finalise ~avoid_exceptions:false ~closure_conversion:false
~monomorphize_types:false)
~hashf:Hash.(finalise ~closure_conversion:false ~monomorphize_types:false)
prg;
print_interpretation_results options Interpreter.interpret_program_dcalc prg
(get_scopeopt_uid prg.decl_ctx ex_scope_opt)
@ -725,13 +708,12 @@ module Commands = struct
output
optimize
check_invariants
avoid_exceptions
closure_conversion
monomorphize_types
ex_scope_opt =
let prg, _ =
Passes.lcalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion ~typed ~monomorphize_types
~closure_conversion ~typed ~monomorphize_types
in
let _output_file, with_output = get_output_format options output in
with_output
@ -764,14 +746,12 @@ module Commands = struct
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion
$ Cli.Flags.monomorphize_types
$ Cli.Flags.ex_scope_opt)
let interpret_lcalc
typed
avoid_exceptions
closure_conversion
monomorphize_types
options
@ -781,32 +761,27 @@ module Commands = struct
ex_scope_opt =
let prg, _ =
Passes.lcalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion ~monomorphize_types ~typed
~closure_conversion ~monomorphize_types ~typed
in
Interpreter.load_runtime_modules
~hashf:
(Hash.finalise ~avoid_exceptions ~closure_conversion ~monomorphize_types)
~hashf:(Hash.finalise ~closure_conversion ~monomorphize_types)
prg;
print_interpretation_results options Interpreter.interpret_program_lcalc prg
(get_scopeopt_uid prg.decl_ctx ex_scope_opt)
let interpret_cmd =
let f lcalc avoid_exceptions closure_conversion monomorphize_types no_typing
=
let f lcalc closure_conversion monomorphize_types no_typing =
if not lcalc then
if avoid_exceptions || closure_conversion || monomorphize_types then
if closure_conversion || monomorphize_types then
Message.error
"The flags @{<bold>--avoid-exceptions@}, \
@{<bold>--closure-conversion@} and @{<bold>--monomorphize-types@} \
only make sense with the @{<bold>--lcalc@} option"
"The flags @{<bold>--closure-conversion@} and \
@{<bold>--monomorphize-types@} only make sense with the \
@{<bold>--lcalc@} option"
else if no_typing then interpret_dcalc Expr.untyped
else interpret_dcalc Expr.typed
else if no_typing then
interpret_lcalc Expr.untyped avoid_exceptions closure_conversion
monomorphize_types
else
interpret_lcalc Expr.typed avoid_exceptions closure_conversion
monomorphize_types
interpret_lcalc Expr.untyped closure_conversion monomorphize_types
else interpret_lcalc Expr.typed closure_conversion monomorphize_types
in
Cmd.v
(Cmd.info "interpret"
@ -817,7 +792,6 @@ module Commands = struct
Term.(
const f
$ Cli.Flags.lcalc
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion
$ Cli.Flags.monomorphize_types
$ Cli.Flags.no_typing
@ -833,13 +807,11 @@ module Commands = struct
output
optimize
check_invariants
avoid_exceptions
closure_conversion
ex_scope_opt =
let prg, type_ordering =
Passes.lcalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~typed:Expr.typed ~closure_conversion
~monomorphize_types:false
~typed:Expr.typed ~closure_conversion ~monomorphize_types:false
in
let output_file, with_output =
get_output_format options ~ext:".ml" output
@ -850,10 +822,7 @@ module Commands = struct
Message.debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in
let hashf =
Hash.finalise ~avoid_exceptions ~closure_conversion
~monomorphize_types:false
in
let hashf = Hash.finalise ~closure_conversion ~monomorphize_types:false in
Lcalc.To_ocaml.format_program fmt prg ?exec_scope ~hashf type_ordering
let ocaml_cmd =
@ -867,7 +836,6 @@ module Commands = struct
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion
$ Cli.Flags.ex_scope_opt)
@ -877,7 +845,6 @@ module Commands = struct
output
optimize
check_invariants
avoid_exceptions
closure_conversion
keep_special_ops
dead_value_assignment
@ -886,8 +853,8 @@ module Commands = struct
ex_scope_opt =
let prg, _ =
Passes.scalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion ~keep_special_ops
~dead_value_assignment ~no_struct_literals ~monomorphize_types
~closure_conversion ~keep_special_ops ~dead_value_assignment
~no_struct_literals ~monomorphize_types
in
let _output_file, with_output = get_output_format options output in
with_output
@ -919,7 +886,6 @@ module Commands = struct
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion
$ Cli.Flags.keep_special_ops
$ Cli.Flags.dead_value_assignment
@ -933,13 +899,11 @@ module Commands = struct
output
optimize
check_invariants
avoid_exceptions
closure_conversion =
let prg, type_ordering =
Passes.scalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion ~keep_special_ops:false
~dead_value_assignment:true ~no_struct_literals:false
~monomorphize_types:false
~closure_conversion ~keep_special_ops:false ~dead_value_assignment:true
~no_struct_literals:false ~monomorphize_types:false
in
let output_file, with_output =
@ -962,15 +926,13 @@ module Commands = struct
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion)
let r options includes output optimize check_invariants closure_conversion =
let prg, type_ordering =
Passes.scalc options ~includes ~optimize ~check_invariants
~avoid_exceptions:false ~closure_conversion ~keep_special_ops:false
~dead_value_assignment:false ~no_struct_literals:false
~monomorphize_types:false
~closure_conversion ~keep_special_ops:false ~dead_value_assignment:false
~no_struct_literals:false ~monomorphize_types:false
in
let output_file, with_output = get_output_format options ~ext:".r" output in
@ -994,7 +956,7 @@ module Commands = struct
let c options includes output optimize check_invariants =
let prg, type_ordering =
Passes.scalc options ~includes ~optimize ~check_invariants
~avoid_exceptions:true ~closure_conversion:true ~keep_special_ops:true
~closure_conversion:true ~keep_special_ops:true
~dead_value_assignment:false ~no_struct_literals:true
~monomorphize_types:true
in

2
compiler/driver.mli
View File

@ -51,7 +51,6 @@ module Passes : sig
optimize:bool ->
check_invariants:bool ->
typed:'m Shared_ast.mark ->
avoid_exceptions:bool ->
closure_conversion:bool ->
monomorphize_types:bool ->
Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
@ -61,7 +60,6 @@ module Passes : sig
includes:Global.raw_file list ->
optimize:bool ->
check_invariants:bool ->
avoid_exceptions:bool ->
closure_conversion:bool ->
keep_special_ops:bool ->
dead_value_assignment:bool ->

39
compiler/lcalc/closure_conversion.ml
View File

@ -30,6 +30,10 @@ type 'm ctx = {
let new_var ?(pfx = "") name_context =
name_context.counter <- name_context.counter + 1;
Var.make (pfx ^ name_context.prefix ^ string_of_int name_context.counter)
(* TODO: Closures end up as a toplevel names. However for now we assume toplevel
names are unique, this is a temporary workaround to avoid name wrangling in
the backends. We need to have a better system for name disambiguation when
for instance printing to Dcalc/Lcalc/Scalc but also OCaml, Python, etc. *)
let new_context prefix = { prefix; counter = 0 }
@ -142,8 +146,7 @@ let rec transform_closures_expr :
let m = Mark.get e in
match Mark.remove e with
| EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _
| ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ | ERaiseEmpty
| ECatchEmpty _ ->
| ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ ->
Expr.map_gather ~acc:Var.Map.empty ~join:join_vars
~f:(transform_closures_expr ctx)
e
@ -217,7 +220,7 @@ let rec transform_closures_expr :
EnumConstructor.Map.add cons
(Expr.eabs new_binder tys (Mark.get e1))
new_cases )
| _ -> failwith "should not happen")
| _ -> assert false)
cases
(free_vars, EnumConstructor.Map.empty)
in
@ -253,7 +256,7 @@ let rec transform_closures_expr :
free_vars, build_closure ctx (Var.Map.bindings free_vars) body vars tys m
| EAppOp
{
op = ((HandleDefaultOpt | Fold | Map | Map2 | Filter | Reduce), _) as op;
op = ((HandleExceptions | Fold | Map | Map2 | Filter | Reduce), _) as op;
tys;
args;
} ->
@ -270,6 +273,9 @@ let rec transform_closures_expr :
| EAbs { binder; tys } ->
let vars, arg = Bindlib.unmbind binder in
let new_free_vars, new_arg = (transform_closures_expr ctx) arg in
let new_free_vars =
Array.fold_left (fun m v -> Var.Map.remove v m) new_free_vars vars
in
let new_arg =
Expr.make_abs vars new_arg tys (Expr.mark_pos m_arg)
in
@ -507,7 +513,7 @@ let rec hoist_closures_expr :
EnumConstructor.Map.add cons
(Expr.eabs new_binder tys (Mark.get e1))
new_cases )
| _ -> failwith "should not happen")
| _ -> assert false)
cases
(collected_closures, EnumConstructor.Map.empty)
in
@ -530,12 +536,7 @@ let rec hoist_closures_expr :
in
( collected_closures,
Expr.eapp ~f:(Expr.eabs new_binder tys e1_pos) ~args:new_args ~tys m )
| EAppOp
{
op = ((HandleDefaultOpt | Fold | Map | Filter | Reduce), _) as op;
tys;
args;
} ->
| EAppOp { op = ((Fold | Map | Filter | Reduce), _) as op; tys; args } ->
(* Special case for some operators: its arguments closures thunks because if
you want to extract it as a function you need these closures to preserve
evaluation order, but backends that don't support closures will simply
@ -562,21 +563,21 @@ let rec hoist_closures_expr :
args ([], [])
in
collected_closures, Expr.eappop ~op ~args:new_args ~tys (Mark.get e)
| EAbs { tys; _ } ->
| EAbs { binder; tys } ->
(* this is the closure we want to hoist *)
let closure_var = new_var ~pfx:"closure_" name_context in
(* TODO: This will end up as a toplevel name. However for now we assume
toplevel names are unique, but this breaks this assertions and can lead
to name wrangling in the backends. We need to have a better system for
name disambiguation when for instance printing to Dcalc/Lcalc/Scalc but
also OCaml, Python, etc. *)
let pos = Expr.mark_pos m in
let ty = Expr.maybe_ty ~typ:(TArrow (tys, (TAny, pos))) m in
( [{ name = closure_var; ty; closure = Expr.rebox e }],
let vars, body = Bindlib.unmbind binder in
let collected_closures, new_body =
(hoist_closures_expr name_context) body
in
let closure = Expr.make_abs vars new_body tys pos in
( { name = closure_var; ty; closure } :: collected_closures,
Expr.make_var closure_var m )
| EApp _ | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _
| EArray _ | ELit _ | EAssert _ | EFatalError _ | EAppOp _ | EIfThenElse _
| ERaiseEmpty | ECatchEmpty _ | EVar _ ->
| EVar _ ->
Expr.map_gather ~acc:[] ~join:( @ ) ~f:(hoist_closures_expr name_context) e
| EExternal { name } -> [], Expr.box (EExternal { name }, m)
| _ -> .

95
compiler/lcalc/compile_with_exceptions.ml
View File

@ -1,95 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
open Shared_ast
module D = Dcalc.Ast
module A = Ast
let rec translate_typ (tau : typ) : typ =
Mark.map
(function
| TDefault t -> Mark.remove (translate_typ t)
| TLit l -> TLit l
| TTuple ts -> TTuple (List.map translate_typ ts)
| TStruct s -> TStruct s
| TEnum en -> TEnum en
| TOption _ ->
Message.error ~internal:true
"The types option should not appear before the dcalc -> lcalc \
translation step."
| TClosureEnv ->
Message.error ~internal:true
"The types closure_env should not appear before the dcalc -> lcalc \
translation step."
| TAny -> TAny
| TArray ts -> TArray (translate_typ ts)
| TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2))
tau
let translate_mark m = Expr.map_ty translate_typ m
let rec translate_default
(exceptions : 'm D.expr list)
(just : 'm D.expr)
(cons : 'm D.expr)
(mark_default : 'm mark) : 'm A.expr boxed =
let pos = Expr.mark_pos mark_default in
let exceptions =
List.map (fun except -> Expr.thunk_term (translate_expr except)) exceptions
in
Expr.eappop
~op:(Op.HandleDefault, Expr.pos cons)
~tys:
[
TArray (TArrow ([TLit TUnit, pos], (TAny, pos)), pos), pos;
TArrow ([TLit TUnit, pos], (TLit TBool, pos)), pos;
TArrow ([TLit TUnit, pos], (TAny, pos)), pos;
]
~args:
[
Expr.earray exceptions
(Expr.map_ty
(fun ty -> TArray (TArrow ([TLit TUnit, pos], ty), pos), pos)
mark_default);
Expr.thunk_term (translate_expr just);
Expr.thunk_term (translate_expr cons);
]
mark_default
and translate_expr (e : 'm D.expr) : 'm A.expr boxed =
match e with
| EEmpty, m -> Expr.eraiseempty (translate_mark m)
| EErrorOnEmpty arg, m ->
let m = translate_mark m in
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
| EAppOp { op; args; tys }, m ->
Expr.eappop ~op:(Operator.translate op)
~args:(List.map translate_expr args)
~tys:(List.map translate_typ tys)
(translate_mark m)
| ( ( ELit _ | EArray _ | EVar _ | EAbs _ | EApp _ | EExternal _
| EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _
| EFatalError _ | EStruct _ | EStructAccess _ | EMatch _ ),
_ ) as e ->
Expr.map ~f:translate_expr ~typ:translate_typ e
| _ -> .
let translate_program (prg : 'm D.program) : 'm A.program =
Program.map_exprs prg ~typ:translate_typ ~varf:Var.translate ~f:translate_expr

20
compiler/lcalc/compile_with_exceptions.mli
View File

@ -1,20 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Translation from the default calculus to the lambda calculus. This
translation uses exceptions to handle empty default terms. *)
val translate_program : 'm Dcalc.Ast.program -> 'm Ast.program

126
compiler/lcalc/compile_without_exceptions.ml
View File

@ -1,126 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Alain Delaët-Tixeuil <alain.delaet--tixeuil@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
open Shared_ast
module D = Dcalc.Ast
module A = Ast
(** We make use of the strong invriants on the structure of programs:
Defaultable values can only appear in certin positions. This information is
given by the type structure of expressions. In particular this mean we don't
need to use the monadic bind while computing arithmetic opertions or
function calls. The resulting function is not more difficult than what we
had when translating without exceptions.
The typing translation is to simply trnsform default type into option types. *)
let rec translate_typ (tau : typ) : typ =
Mark.copy tau
begin
match Mark.remove tau with
| TDefault t -> TOption (translate_typ t)
| TLit l -> TLit l
| TTuple ts -> TTuple (List.map translate_typ ts)
| TStruct s -> TStruct s
| TEnum en -> TEnum en
| TOption _ ->
Message.error ~internal:true
"The types option should not appear before the dcalc -> lcalc \
translation step."
| TClosureEnv ->
Message.error ~internal:true
"The types closure_env should not appear before the dcalc -> lcalc \
translation step."
| TAny -> TAny
| TArray ts -> TArray (translate_typ ts)
| TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2)
end
let translate_mark m = Expr.map_ty translate_typ m
let rec translate_default
(exceptions : 'm D.expr list)
(just : 'm D.expr)
(cons : 'm D.expr)
(mark_default : 'm mark) : 'm A.expr boxed =
(* Since the program is well typed, all exceptions have as type [option 't] *)
let pos = Expr.mark_pos mark_default in
let exceptions = List.map translate_expr exceptions in
let exceptions_and_cons_ty = Expr.maybe_ty mark_default in
Expr.eappop
~op:(Op.HandleDefaultOpt, Expr.pos cons)
~tys:
[
TArray exceptions_and_cons_ty, pos;
TArrow ([TLit TUnit, pos], (TLit TBool, pos)), pos;
TArrow ([TLit TUnit, pos], exceptions_and_cons_ty), pos;
]
~args:
[
Expr.earray exceptions
(Expr.map_ty (fun ty -> TArray ty, pos) mark_default);
(* In call-by-value programming languages, as lcalc, arguments are
evalulated before calling the function. Since we don't want to
execute the justification and conclusion while before checking every
exceptions, we need to thunk them. *)
Expr.thunk_term (translate_expr just);
Expr.thunk_term (translate_expr cons);
]
mark_default
and translate_expr (e : 'm D.expr) : 'm A.expr boxed =
match e with
| EEmpty, m ->
let m = translate_mark m in
let pos = Expr.mark_pos m in
Expr.einj
~e:(Expr.elit LUnit (Expr.with_ty m (TLit TUnit, pos)))
~cons:Expr.none_constr ~name:Expr.option_enum m
| EErrorOnEmpty arg, m ->
let m = translate_mark m in
let pos = Expr.mark_pos m in
let cases =
EnumConstructor.Map.of_list
[
( Expr.none_constr,
let x = Var.make "_" in
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 *);
]
in
Expr.ematch ~e:(translate_expr arg) ~name:Expr.option_enum ~cases m
| EDefault { excepts; just; cons }, m ->
translate_default excepts just cons (translate_mark m)
| EPureDefault e, m ->
Expr.einj ~e:(translate_expr e) ~cons:Expr.some_constr
~name:Expr.option_enum (translate_mark m)
| EAppOp { op; tys; args }, m ->
Expr.eappop ~op:(Operator.translate op)
~tys:(List.map translate_typ tys)
~args:(List.map translate_expr args)
(translate_mark m)
| ( ( ELit _ | EArray _ | EVar _ | EApp _ | EAbs _ | EExternal _
| EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _
| EFatalError _ | EStruct _ | EStructAccess _ | EMatch _ ),
_ ) as e ->
Expr.map ~f:translate_expr ~typ:translate_typ e
| _ -> .
let translate_program (prg : 'm D.program) : 'm A.program =
Program.map_exprs prg ~typ:translate_typ ~varf:Var.translate ~f:translate_expr

22
compiler/lcalc/compile_without_exceptions.mli
View File

@ -1,22 +0,0 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Alain Delaët-Tixeuil <alain.delaet--tixeuil@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Translation from the default calculus to the lambda calculus. This
translation uses an option monad to handle empty defaults terms. This
transformation is one piece to permit to compile toward legacy languages
that does not contains exceptions. *)
val translate_program : 'm Dcalc.Ast.program -> 'm Ast.program

135
compiler/lcalc/from_dcalc.ml
View File

@ -1,6 +1,6 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Alain Delaët-Tixeuil <alain.delaet--tixeuil@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
@ -14,7 +14,130 @@
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
open Shared_ast
module D = Dcalc.Ast
module A = Ast
(** We make use of the strong invriants on the structure of programs:
Defaultable values can only appear in certin positions. This information is
given by the type structure of expressions. In particular this mean we don't
need to use the monadic bind while computing arithmetic opertions or
function calls. The resulting function is not more difficult than what we
had when translating without exceptions.
The typing translation is to simply trnsform default type into option types. *)
let rec translate_typ (tau : typ) : typ =
Mark.copy tau
begin
match Mark.remove tau with
| TDefault t -> TOption (translate_typ t)
| TLit l -> TLit l
| TTuple ts -> TTuple (List.map translate_typ ts)
| TStruct s -> TStruct s
| TEnum en -> TEnum en
| TOption _ ->
Message.error ~internal:true
"The types option should not appear before the dcalc -> lcalc \
translation step."
| TClosureEnv ->
Message.error ~internal:true
"The types closure_env should not appear before the dcalc -> lcalc \
translation step."
| TAny -> TAny
| TArray ts -> TArray (translate_typ ts)
| TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2)
end
let translate_mark m = Expr.map_ty translate_typ m
let rec translate_default
(exceptions : 'm D.expr list)
(just : 'm D.expr)
(cons : 'm D.expr)
(mark_default : 'm mark) : 'm A.expr boxed =
(* Since the program is well typed, all exceptions have as type [option 't] *)
let pos = Expr.mark_pos mark_default in
let exceptions = List.map translate_expr exceptions in
let ty_option = Expr.maybe_ty mark_default in
let ty_array = TArray ty_option, pos in
let ty_alpha =
match ty_option with
| TOption ty, _ -> ty
| (TAny, _) as ty -> ty
| _ -> assert false
in
let mark_alpha = Expr.with_ty mark_default ty_alpha in
Expr.ematch ~name:Expr.option_enum
~e:
(Expr.eappop
~op:(Op.HandleExceptions, Expr.pos cons)
~tys:[ty_array]
~args:[Expr.earray exceptions (Expr.with_ty mark_default ty_array)]
mark_default)
~cases:
(EnumConstructor.Map.of_list
[
(* Some x -> Some x *)
( Expr.some_constr,
let x = Var.make "x" in
Expr.make_abs [| x |]
(Expr.einj ~name:Expr.option_enum ~cons:Expr.some_constr
~e:(Expr.evar x mark_alpha) mark_default)
[ty_alpha] pos );
(* None -> if just then cons else None *)
( Expr.none_constr,
Expr.thunk_term
(Expr.eifthenelse (translate_expr just) (translate_expr cons)
(Expr.einj
~e:
(Expr.elit LUnit
(Expr.with_ty mark_default (TLit TUnit, pos)))
~cons:Expr.none_constr ~name:Expr.option_enum mark_default)
mark_default) );
])
mark_default
and translate_expr (e : 'm D.expr) : 'm A.expr boxed =
match e with
| EEmpty, m ->
let m = translate_mark m in
let pos = Expr.mark_pos m in
Expr.einj
~e:(Expr.elit LUnit (Expr.with_ty m (TLit TUnit, pos)))
~cons:Expr.none_constr ~name:Expr.option_enum m
| EErrorOnEmpty arg, m ->
let m = translate_mark m in
let pos = Expr.mark_pos m in
let cases =
EnumConstructor.Map.of_list
[
( Expr.none_constr,
let x = Var.make "_" in
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 *);
]
in
Expr.ematch ~e:(translate_expr arg) ~name:Expr.option_enum ~cases m
| EDefault { excepts; just; cons }, m ->
translate_default excepts just cons (translate_mark m)
| EPureDefault e, m ->
Expr.einj ~e:(translate_expr e) ~cons:Expr.some_constr
~name:Expr.option_enum (translate_mark m)
| EAppOp { op; tys; args }, m ->
Expr.eappop ~op:(Operator.translate op)
~tys:(List.map translate_typ tys)
~args:(List.map translate_expr args)
(translate_mark m)
| ( ( ELit _ | EArray _ | EVar _ | EApp _ | EAbs _ | EExternal _
| EIfThenElse _ | ETuple _ | ETupleAccess _ | EInj _ | EAssert _
| EFatalError _ | EStruct _ | EStructAccess _ | EMatch _ ),
_ ) as e ->
Expr.map ~f:translate_expr ~typ:translate_typ e
| _ -> .
let add_option_type ctx =
{
@ -26,9 +149,7 @@ let add_option_type ctx =
let add_option_type_program prg =
{ prg with decl_ctx = add_option_type prg.decl_ctx }
let translate_program_with_exceptions =
Compile_with_exceptions.translate_program
let translate_program_without_exceptions prg =
let prg = add_option_type_program prg in
Compile_without_exceptions.translate_program prg
let translate_program (prg : 'm D.program) : 'm A.program =
Program.map_exprs
(add_option_type_program prg)
~typ:translate_typ ~varf:Var.translate ~f:translate_expr

14
compiler/lcalc/from_dcalc.mli
View File

@ -1,6 +1,6 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Alain Delaët-Tixeuil <alain.delaet--tixeuil@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
@ -14,13 +14,9 @@
License for the specific language governing permissions and limitations under
the License. *)
val translate_program_with_exceptions : 'm Dcalc.Ast.program -> 'm Ast.program
(** Translation from the default calculus to the lambda calculus. This
translation uses exceptions to handle empty default terms. *)
val translate_program_without_exceptions :
'm Dcalc.Ast.program -> 'm Ast.program
(** Translation from the default calculus to the lambda calculus. This
translation uses an option monad to handle empty defaults terms. This
transformation is one piece to permit to compile toward legacy languages
that does not contains catchable exceptions. *)
that does not contains exceptions. *)
val translate_program : 'm Dcalc.Ast.program -> 'm Ast.program

30
compiler/lcalc/monomorphize.ml
View File

@ -78,7 +78,7 @@ let collect_monomorphized_instances (prg : typed program) :
args;
name =
StructName.fresh []
( "tuple_" ^ string_of_int !option_instances_counter,
( "tuple_" ^ string_of_int !tuple_instances_counter,
Pos.no_pos );
})
acc.tuples;
@ -90,7 +90,7 @@ let collect_monomorphized_instances (prg : typed program) :
{
acc with
arrays =
Type.Map.update t
Type.Map.update typ
(fun monomorphized_name ->
match monomorphized_name with
| Some e -> Some e
@ -118,7 +118,7 @@ let collect_monomorphized_instances (prg : typed program) :
{
acc with
options =
Type.Map.update t
Type.Map.update typ
(fun monomorphized_name ->
match monomorphized_name with
| Some e -> Some e
@ -173,8 +173,9 @@ let rec monomorphize_typ
(typ : typ) : typ =
match Mark.remove typ with
| TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> typ
| TArray t1 ->
TStruct (Type.Map.find t1 monomorphized_instances.arrays).name, Mark.get typ
| TArray _ ->
( TStruct (Type.Map.find typ monomorphized_instances.arrays).name,
Mark.get typ )
| TDefault t1 ->
TDefault (monomorphize_typ monomorphized_instances t1), Mark.get typ
| TArrow (t1s, t2) ->
@ -185,8 +186,8 @@ let rec monomorphize_typ
| TTuple _ ->
( TStruct (Type.Map.find typ monomorphized_instances.tuples).name,
Mark.get typ )
| TOption t1 ->
TEnum (Type.Map.find t1 monomorphized_instances.options).name, Mark.get typ
| TOption _ ->
TEnum (Type.Map.find typ monomorphized_instances.options).name, Mark.get typ
let is_some c =
EnumConstructor.equal Expr.some_constr c
@ -233,7 +234,12 @@ let rec monomorphize_expr
field = fst (List.nth tuple_instance.fields index);
}
| EMatch { name; e; cases } when EnumName.equal name Expr.option_enum ->
let option_instance = Type.Map.find ty0 monomorphized_instances.options in
let opt_ty =
match e0 with EMatch { e; _ }, _ -> Expr.ty e | _ -> assert false
in
let option_instance =
Type.Map.find opt_ty monomorphized_instances.options
in
EMatch
{
name = option_instance.name;
@ -247,11 +253,7 @@ let rec monomorphize_expr
cases EnumConstructor.Map.empty;
}
| EInj { name; e; cons } when EnumName.equal name Expr.option_enum ->
let option_instance =
Type.Map.find
(match Mark.remove ty0 with TOption t -> t | _ -> assert false)
monomorphized_instances.options
in
let option_instance = Type.Map.find ty0 monomorphized_instances.options in
EInj
{
name = option_instance.name;
@ -264,7 +266,7 @@ let rec monomorphize_expr
let elt_ty =
match Mark.remove ty0 with TArray t -> t | _ -> assert false
in
let array_instance = Type.Map.find elt_ty monomorphized_instances.arrays in
let array_instance = Type.Map.find ty0 monomorphized_instances.arrays in
EStruct
{
name = array_instance.name;

25
compiler/lcalc/to_ocaml.ml
View File

@ -409,21 +409,6 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
format_with_parens arg1
| EAppOp { op = Log _, _; args = [arg1]; _ } ->
Format.fprintf fmt "%a" format_with_parens arg1
| EAppOp
{
op = ((HandleDefault | HandleDefaultOpt) as op), _;
args = (EArray excs, _) :: _ as args;
_;
} ->
let pos = List.map Expr.pos excs in
Format.fprintf fmt "@[<hov 2>%s@ [|%a|]@ %a@]"
(Print.operator_to_string op)
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
format_pos)
pos
(Format.pp_print_list ~pp_sep:Format.pp_print_space format_with_parens)
args
| EApp { f; args; _ } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
(Format.pp_print_list
@ -443,6 +428,12 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
Format.fprintf ppf "%a@ " format_pos pos
| Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur ->
Format.fprintf ppf "%a@ " format_pos (Expr.pos (List.nth args 1))
| HandleExceptions ->
Format.fprintf ppf "[|@[<hov>%a@]|]@ "
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
format_pos)
(List.map Expr.pos args)
| _ -> ())
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
@ -457,10 +448,6 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
| 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 Empty"
| ECatchEmpty { body; handler } ->
Format.fprintf fmt "@[<hv>@[<hov 2>try@ %a@]@ with Empty ->@]@ @[%a@]"
format_with_parens body format_with_parens handler
| _ -> .
let format_struct_embedding

5
compiler/plugins/api_web.ml
View File

@ -471,15 +471,13 @@ let run
output
optimize
check_invariants
avoid_exceptions
closure_conversion
monomorphize_types
_options =
let options = Global.enforce_options ~trace:true () in
let prg, type_ordering =
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion ~typed:Expr.typed
~monomorphize_types
~closure_conversion ~typed:Expr.typed ~monomorphize_types
in
let jsoo_output_file, with_formatter =
Driver.Commands.get_output_format options ~ext:"_api_web.ml" output
@ -506,7 +504,6 @@ let term =
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion
$ Cli.Flags.monomorphize_types

7
compiler/plugins/explain.ml
View File

@ -1085,8 +1085,7 @@ let expr_to_dot_label0 :
| Reduce -> xlang () ~en:"reduce" ~fr:"réunion"
| Filter -> xlang () ~en:"filter" ~fr:"filtre"
| Fold -> xlang () ~en:"fold" ~fr:"pliage"
| HandleDefault -> ""
| HandleDefaultOpt -> ""
| HandleExceptions -> ""
| ToClosureEnv -> ""
| FromClosureEnv -> ""
in
@ -1382,9 +1381,7 @@ let run includes optimize ex_scope explain_options global_options =
~check_invariants:false ~typed:Expr.typed
in
Interpreter.load_runtime_modules prg
~hashf:
(Hash.finalise ~avoid_exceptions:false ~closure_conversion:false
~monomorphize_types:false);
~hashf:(Hash.finalise ~closure_conversion:false ~monomorphize_types:false);
let scope = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in
(* let result_expr, env = interpret_program prg scope in *)
let g, base_vars, env = program_to_graph explain_options prg scope in

5
compiler/plugins/json_schema.ml
View File

@ -210,15 +210,13 @@ let run
output
optimize
check_invariants
avoid_exceptions
closure_conversion
monomorphize_types
ex_scope
options =
let prg, _ =
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion ~typed:Expr.typed
~monomorphize_types
~closure_conversion ~typed:Expr.typed ~monomorphize_types
in
let output_file, with_output =
Driver.Commands.get_output_format options ~ext:"_schema.json" output
@ -239,7 +237,6 @@ let term =
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion
$ Cli.Flags.monomorphize_types
$ Cli.Flags.ex_scope

4
compiler/plugins/lazy_interp.ml
View File

@ -272,9 +272,7 @@ let run includes optimize check_invariants ex_scope options =
~typed:Expr.typed
in
Interpreter.load_runtime_modules prg
~hashf:
(Hash.finalise ~avoid_exceptions:false ~closure_conversion:false
~monomorphize_types:false);
~hashf:(Hash.finalise ~closure_conversion:false ~monomorphize_types:false);
let scope = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in
let result_expr, _env = interpret_program prg scope in
let fmt = Format.std_formatter in

15
compiler/plugins/python.ml
View File

@ -22,20 +22,12 @@
open Catala_utils
let run
includes
output
optimize
check_invariants
avoid_exceptions
closure_conversion
options =
let run includes output optimize check_invariants closure_conversion options =
let open Driver.Commands in
let prg, type_ordering =
Driver.Passes.scalc options ~includes ~optimize ~check_invariants
~avoid_exceptions ~closure_conversion ~keep_special_ops:false
~dead_value_assignment:true ~no_struct_literals:false
~monomorphize_types:false
~closure_conversion ~keep_special_ops:false ~dead_value_assignment:true
~no_struct_literals:false ~monomorphize_types:false
in
let output_file, with_output = get_output_format options ~ext:".py" output in
@ -50,7 +42,6 @@ let term =
$ Cli.Flags.output
$ Cli.Flags.optimize
$ Cli.Flags.check_invariants
$ Cli.Flags.avoid_exceptions
$ Cli.Flags.closure_conversion
let () =

4
compiler/scalc/ast.ml
View File

@ -33,10 +33,6 @@ module VarName =
end)
()
let dead_value = VarName.fresh ("dead_value", Pos.no_pos)
let handle_default = FuncName.fresh ("handle_default", Pos.no_pos)
let handle_default_opt = FuncName.fresh ("handle_default_opt", Pos.no_pos)
type operator = Shared_ast.lcalc Shared_ast.operator
type expr = naked_expr Mark.pos

150
compiler/scalc/from_lcalc.ml
View File

@ -35,13 +35,6 @@ type 'm ctxt = {
program_ctx : A.ctx;
}
let unthunk e =
match Mark.remove e with
| EAbs { binder; tys = [(TLit TUnit, _)] } ->
let _, e = Bindlib.unmbind binder in
e
| _ -> failwith "should not happen"
(* Expressions can spill out side effect, hence this function also returns a
list of statements to be prepended before the expression is evaluated *)
@ -138,15 +131,6 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr =
| ETupleAccess { e = e1; index; _ } ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
e1_stmts, (A.ETupleAccess { e1 = new_e1; index }, Expr.pos expr)
| EAppOp
{
op = Op.HandleDefaultOpt, _;
args = [_exceptions; _just; _cons];
tys = _;
}
when ctxt.config.keep_special_ops ->
(* This should be translated as a statement *)
raise (NotAnExpr { needs_a_local_decl = true })
| EAppOp { op; args; tys = _ } ->
let args_stmts, new_args = translate_expr_list ctxt args in
(* FIXME: what happens if [arg] is not a tuple but reduces to one ? *)
@ -227,8 +211,7 @@ 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)
| ECatchEmpty _ | EAbs _ | EIfThenElse _ | EMatch _ | EAssert _
| EFatalError _ | ERaiseEmpty ->
| EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ | EFatalError _ ->
raise (NotAnExpr { needs_a_local_decl = true })
| _ -> .
with NotAnExpr { needs_a_local_decl } ->
@ -274,60 +257,60 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
~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 ->
let exceptions =
match Mark.remove exceptions with
| EStruct { fields; _ } -> (
let _, exceptions =
List.find
(fun (field, _) ->
String.equal (Mark.remove (StructField.get_info field)) "content")
(StructField.Map.bindings fields)
in
match Mark.remove exceptions with
| EArray exceptions -> exceptions
| _ -> failwith "should not happen")
| _ -> failwith "should not happen"
in
let just = unthunk just in
let cons = unthunk cons in
let exceptions_stmts, new_exceptions =
translate_expr_list ctxt exceptions
in
let just_stmts, new_just = translate_expr ctxt just in
let cons_stmts, new_cons = translate_expr ctxt cons in
RevBlock.rebuild exceptions_stmts
~tail:
(RevBlock.rebuild just_stmts
~tail:
[
( A.SSpecialOp
(OHandleDefaultOpt
{
exceptions = new_exceptions;
just = new_just;
cons =
RevBlock.rebuild cons_stmts
~tail:
[
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Mark.remove new_cons)
| Some x ->
A.SLocalDef
{
name = Mark.copy new_cons x;
expr = new_cons;
typ =
Expr.maybe_ty (Mark.get block_expr);
}),
Expr.pos block_expr );
];
return_typ = Expr.maybe_ty (Mark.get block_expr);
}),
Expr.pos block_expr );
])
(* | EAppOp
* { op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] }
* when ctxt.config.keep_special_ops ->
* let exceptions =
* match Mark.remove exceptions with
* | EStruct { fields; _ } -> (
* let _, exceptions =
* List.find
* (fun (field, _) ->
* String.equal (Mark.remove (StructField.get_info field)) "content")
* (StructField.Map.bindings fields)
* in
* match Mark.remove exceptions with
* | EArray exceptions -> exceptions
* | _ -> failwith "should not happen")
* | _ -> failwith "should not happen"
* in
* let just = unthunk just in
* let cons = unthunk cons in
* let exceptions_stmts, new_exceptions =
* translate_expr_list ctxt exceptions
* in
* let just_stmts, new_just = translate_expr ctxt just in
* let cons_stmts, new_cons = translate_expr ctxt cons in
* RevBlock.rebuild exceptions_stmts
* ~tail:
* (RevBlock.rebuild just_stmts
* ~tail:
* [
* ( A.SSpecialOp
* (OHandleDefaultOpt
* {
* exceptions = new_exceptions;
* just = new_just;
* cons =
* RevBlock.rebuild cons_stmts
* ~tail:
* [
* ( (match ctxt.inside_definition_of with
* | None -> A.SReturn (Mark.remove new_cons)
* | Some x ->
* A.SLocalDef
* {
* name = Mark.copy new_cons x;
* expr = new_cons;
* typ =
* Expr.maybe_ty (Mark.get block_expr);
* }),
* Expr.pos block_expr );
* ];
* return_typ = Expr.maybe_ty (Mark.get block_expr);
* }),
* Expr.pos block_expr );
* ]) *)
| EApp { f = EAbs { binder; tys }, binder_mark; args; _ } ->
(* This defines multiple local variables at the time *)
let binder_pos = Expr.mark_pos binder_mark in
@ -483,29 +466,6 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
},
Expr.pos block_expr );
]
| ECatchEmpty { body; handler } ->
let s_e_try = translate_statements ctxt body in
let s_e_catch = translate_statements ctxt handler in
[
( A.STryWEmpty { try_block = s_e_try; with_block = s_e_catch },
Expr.pos block_expr );
]
| 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
| Some x when ctxt.config.dead_value_assignment ->
[
( A.SLocalDef
{
name = x, Expr.pos block_expr;
expr = Ast.EVar Ast.dead_value, Expr.pos block_expr;
typ = Expr.maybe_ty (Mark.get block_expr);
},
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 =

14
compiler/scalc/print.ml
View File

@ -53,7 +53,7 @@ let rec format_expr
(StructField.Map.bindings es)
Print.punctuation "}"
| ETuple es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" Print.punctuation "()"
Format.fprintf fmt "@[<hov 2>%a%a%a@]" Print.punctuation "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
@ -233,21 +233,11 @@ let format_item decl_ctx ?debug ppf def =
Format.pp_print_cut ppf ()
let format_program ?debug ppf prg =
let decl_ctx =
(* TODO: this is redundant with From_dcalc.add_option_type (which is already
applied in avoid_exceptions mode) *)
{
prg.ctx.decl_ctx with
ctx_enums =
EnumName.Map.add Expr.option_enum Expr.option_enum_config
prg.ctx.decl_ctx.ctx_enums;
}
in
Format.pp_open_vbox ppf 0;
ModuleName.Map.iter
(fun m var ->
Format.fprintf ppf "%a %a = %a@," Print.keyword "module" format_var_name
var ModuleName.format m)
prg.ctx.modules;
Format.pp_print_list (format_item decl_ctx ?debug) ppf prg.code_items;
Format.pp_print_list (format_item prg.ctx.decl_ctx ?debug) ppf prg.code_items;
Format.pp_close_box ppf ()

7
compiler/scalc/to_c.ml
View File

@ -313,9 +313,8 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
| Reduce -> Format.pp_print_string fmt "catala_list_reduce"
| Filter -> Format.pp_print_string fmt "catala_list_filter"
| Fold -> Format.pp_print_string fmt "catala_list_fold_left"
| HandleDefault -> Format.pp_print_string fmt "catala_handle_default"
| HandleDefaultOpt | FromClosureEnv | ToClosureEnv | Map2 ->
failwith "unimplemented"
| HandleExceptions -> Format.pp_print_string fmt "catala_handle_exceptions"
| FromClosureEnv | ToClosureEnv | Map2 -> failwith "unimplemented"
let _format_string_list (fmt : Format.formatter) (uids : string list) : unit =
let sanitize_quotes = Re.compile (Re.char '"') in
@ -368,8 +367,6 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
| EAppOp { op = (HandleDefaultOpt | HandleDefault), _; args = _ } ->
failwith "should not happen because of keep_special_ops"
| EApp { f; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
(Format.pp_print_list

162
compiler/scalc/to_python.ml
View File

@ -88,8 +88,7 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
| Reduce -> Format.pp_print_string fmt "list_reduce"
| Filter -> Format.pp_print_string fmt "list_filter"
| Fold -> Format.pp_print_string fmt "list_fold_left"
| HandleDefault -> Format.pp_print_string fmt "handle_default"
| HandleDefaultOpt -> Format.pp_print_string fmt "handle_default_opt"
| HandleExceptions -> Format.pp_print_string fmt "handle_exceptions"
| FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
@ -347,41 +346,27 @@ let rec format_expression ctx (fmt : Format.formatter) (e : expr) : unit =
args = [arg1];
} ->
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp { op = (HandleExceptions, _) as op; args = [(EArray el, _)] as args }
->
Format.fprintf fmt "@[<hv 4>%a(@,[%a],@ %a@;<0 -4>)@]" format_op op
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
format_position)
(List.map Mark.get el)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
| EAppOp { op = ((HandleDefault | HandleDefaultOpt), _) as op; args } ->
let pos = Mark.get e in
Format.fprintf fmt
"%a(@[<hov 0>SourcePosition(filename=\"%s\",@ start_line=%d,@ \
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]"
format_op 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.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EApp { f = EFunc x, pos; args }
when Ast.FuncName.compare x Ast.handle_default = 0
|| Ast.FuncName.compare x Ast.handle_default_opt = 0 ->
Format.fprintf fmt
"%a(@[<hov 0>SourcePosition(filename=\"%s\",@ start_line=%d,@ \
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]"
format_func_name x (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.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EApp { f; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
Format.fprintf fmt "%a(@[<hv 0>%a)@]" (format_expression ctx) f
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EAppOp { op; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" format_op op
Format.fprintf fmt "%a(@[<hv 0>%a)@]" format_op op
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
@ -402,10 +387,10 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit
=
match Mark.remove s with
| SInnerFuncDef { name; func = { func_params; func_body; _ } } ->
Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]" format_var
Format.fprintf fmt "@[<v 4>def %a(@[<hov>%a@]):@ %a@]" format_var
(Mark.remove name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Mark.remove var)
(format_typ ctx) typ))
@ -414,16 +399,16 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit
assert false (* We don't need to declare variables in Python *)
| SLocalDef { name = v; expr = e; _ } | SLocalInit { name = v; expr = e; _ }
->
Format.fprintf fmt "@[<hov 4>%a = %a@]" format_var (Mark.remove v)
Format.fprintf fmt "@[<hv 4>%a = %a@]" format_var (Mark.remove v)
(format_expression ctx) e
| STryWEmpty { try_block = try_b; with_block = catch_b } ->
Format.fprintf fmt "@[<v 4>try:@,%a@]@\n@[<v 4>except Empty:@,%a@]"
Format.fprintf fmt "@[<v 4>try:@ %a@]@,@[<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.fprintf fmt "@[<v 4>if %a:@ %a@]@,@[<v 4>else:@ %a@]"
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
| SSwitch
{
@ -439,11 +424,11 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit
when EnumName.equal e_name Expr.option_enum ->
(* We translate the option type with an overloading by Python's [None] *)
let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in
Format.fprintf fmt "%a = %a@\n" format_var tmp_var (format_expression ctx)
e1;
Format.fprintf fmt "@[<v 4>if %a is None:@\n%a@]@\n" format_var tmp_var
Format.fprintf fmt "@[<hv 4>%a = %a@]@," format_var tmp_var
(format_expression ctx) e1;
Format.fprintf fmt "@[<v 4>if %a is None:@ %a@]@," format_var tmp_var
(format_block ctx) case_none;
Format.fprintf fmt "@[<v 4>else:@\n%a = %a@\n%a@]" format_var case_some_var
Format.fprintf fmt "@[<v 4>else:@ %a = %a@,%a@]" format_var case_some_var
format_var tmp_var (format_block ctx) case_some
| SSwitch { switch_expr = e1; enum_name = e_name; switch_cases = cases; _ } ->
let cons_map = EnumName.Map.find e_name ctx.decl_ctx.ctx_enums in
@ -470,10 +455,10 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit
| SAssert e1 ->
let pos = Mark.get s in
Format.fprintf fmt
"@[<hov 4>if not (%a):@\n\
raise AssertionFailure(@[<hov 0>SourcePosition(@[<hov \
0>filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \
end_column=%d,@ law_headings=@[<hv>%a@])@])@]@]"
"@[<hv 4>if not (%a):@,\
raise AssertionFailure(@[<hov>SourcePosition(@[<hov 0>filename=\"%s\",@ \
start_line=%d,@ start_column=%d,@ end_line=%d,@ end_column=%d,@ \
law_headings=@[<hv>%a@])@])@]@]"
(format_expression ctx)
(e1, Mark.get s)
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
@ -482,12 +467,14 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit
| SSpecialOp _ -> failwith "should not happen"
and format_block ctx (fmt : Format.formatter) (b : block) : unit =
Format.pp_open_vbox fmt 0;
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,")
(format_statement ctx) fmt
(List.filter
(fun s -> match Mark.remove s with SLocalDecl _ -> false | _ -> true)
b)
b);
Format.pp_close_box fmt ()
let format_ctx
(type_ordering : Scopelang.Dependency.TVertex.t list)
@ -496,20 +483,20 @@ let format_ctx
let format_struct_decl fmt (struct_name, struct_fields) =
let fields = StructField.Map.bindings struct_fields in
Format.fprintf fmt
"class %a:@\n\
\ def __init__(self, %a) -> None:@\n\
%a@\n\
@\n\
\ def __eq__(self, other: object) -> bool:@\n\
\ if isinstance(other, %a):@\n\
\ return @[<hov>(%a)@]@\n\
\ else:@\n\
\ return False@\n\
@\n\
\ def __ne__(self, other: object) -> bool:@\n\
\ return not (self == other)@\n\
@\n\
\ def __str__(self) -> str:@\n\
"class %a:@,\
\ def __init__(self, %a) -> None:@,\
%a@,\
@,\
\ def __eq__(self, other: object) -> bool:@,\
\ if isinstance(other, %a):@,\
\ return @[<hov>(%a)@]@,\
\ else:@,\
\ return False@,\
@,\
\ def __ne__(self, other: object) -> bool:@,\
\ return not (self == other)@,\
@,\
\ def __str__(self) -> str:@,\
\ @[<hov 4>return \"%a(%a)\".format(%a)@]" (format_struct_name ctx)
struct_name
(Format.pp_print_list
@ -521,9 +508,7 @@ let format_ctx
(if StructField.Map.is_empty struct_fields then fun fmt _ ->
Format.fprintf fmt " pass"
else
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (struct_field, _) ->
Format.pp_print_list (fun fmt (struct_field, _) ->
Format.fprintf fmt " self.%a = %a" format_struct_field_name
struct_field format_struct_field_name struct_field))
fields (format_struct_name ctx) struct_name
@ -551,32 +536,30 @@ let format_ctx
failwith "no constructors in the enum"
else
Format.fprintf fmt
"@[<hov 4>class %a_Code(Enum):@\n\
%a@]@\n\
@\n\
class %a:@\n\
\ def __init__(self, code: %a_Code, value: Any) -> None:@\n\
\ self.code = code@\n\
\ self.value = value@\n\
@\n\
@\n\
\ def __eq__(self, other: object) -> bool:@\n\
\ if isinstance(other, %a):@\n\
"@[<v 4>class %a_Code(Enum):@,\
%a@]@,\
@,\
class %a:@,\
\ def __init__(self, code: %a_Code, value: Any) -> None:@,\
\ self.code = code@,\
\ self.value = value@,\
@,\
@,\
\ def __eq__(self, other: object) -> bool:@,\
\ if isinstance(other, %a):@,\
\ return self.code == other.code and self.value == \
other.value@\n\
\ else:@\n\
\ return False@\n\
@\n\
@\n\
\ def __ne__(self, other: object) -> bool:@\n\
\ return not (self == other)@\n\
@\n\
\ def __str__(self) -> str:@\n\
other.value@,\
\ else:@,\
\ return False@,\
@,\
@,\
\ def __ne__(self, other: object) -> bool:@,\
\ return not (self == other)@,\
@,\
\ def __str__(self) -> str:@,\
\ @[<hov 4>return \"{}({})\".format(self.code, self.value)@]"
(format_enum_name ctx) enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (i, enum_cons, _enum_cons_type) ->
(Format.pp_print_list (fun fmt (i, enum_cons, _enum_cons_type) ->
Format.fprintf fmt "%a = %d" format_enum_cons_name enum_cons i))
(List.mapi
(fun i (x, y) -> i, x, y)
@ -606,11 +589,11 @@ let format_ctx
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
if StructName.path s = [] then
Format.fprintf fmt "%a@\n@\n" format_struct_decl
Format.fprintf fmt "%a@,@," format_struct_decl
(s, StructName.Map.find s ctx.decl_ctx.ctx_structs)
| Scopelang.Dependency.TVertex.Enum e ->
if EnumName.path e = [] then
Format.fprintf fmt "%a@\n@\n" format_enum_decl
Format.fprintf fmt "%a@,@," format_enum_decl
(e, EnumName.Map.find e ctx.decl_ctx.ctx_enums))
(type_ordering @ scope_structs)
@ -626,14 +609,15 @@ let reserve_func_name = function
let format_code_item ctx fmt = function
| SVar { var; expr; typ = _ } ->
Format.fprintf fmt "@[<hv 4>%a = (@,%a@,@])@," format_var var
Format.fprintf fmt "@[<hv 4>%a = (@,%a@;<0 -4>)@]@," format_var var
(format_expression ctx) expr
| SFunc { var; func }
| SScope { scope_body_var = var; scope_body_func = func; _ } ->
let { Ast.func_params; Ast.func_body; _ } = func in
Format.fprintf fmt "@[<hv 4>def %a(%a):@\n%a@]@," format_func_name var
Format.fprintf fmt "@[<v 4>@[<hov 2>def %a(@,%a@;<0 -2>):@]@ %a@]@,"
format_func_name var
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Mark.remove var)
(format_typ ctx) typ))

43
compiler/scalc/to_r.ml
View File

@ -103,8 +103,7 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
| Reduce -> Format.pp_print_string fmt "catala_list_reduce"
| Filter -> Format.pp_print_string fmt "catala_list_filter"
| Fold -> Format.pp_print_string fmt "catala_list_fold_left"
| HandleDefault -> Format.pp_print_string fmt "catala_handle_default"
| HandleDefaultOpt | FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
| HandleExceptions | FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
let sanitize_quotes = Re.compile (Re.char '"') in
@ -319,36 +318,20 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
args = [arg1];
} ->
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
| EAppOp { op = HandleExceptions, _ as op; args = [EArray el, _] as args } ->
Format.fprintf fmt
"%a(%a, %a)@]"
format_op op
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
format_position)
(List.map Mark.get el)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EAppOp { op; args = [arg1] } ->
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) arg1
| EAppOp { op = HandleDefaultOpt, _; _ } ->
Message.error ~internal:true
"R compilation does not currently support the avoiding of exceptions"
| EAppOp { op = (HandleDefault as op), _; args; _ } ->
let pos = Mark.get e in
Format.fprintf fmt
"%a(@[<hov 0>catala_position(filename=\"%s\",@ start_line=%d,@ \
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]"
format_op (op, pos) (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.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EApp { f = EFunc x, pos; args }
when Ast.FuncName.compare x Ast.handle_default = 0
|| Ast.FuncName.compare x Ast.handle_default_opt = 0 ->
Format.fprintf fmt
"%a(@[<hov 0>catala_position(filename=\"%s\",@ start_line=%d,@ \
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]"
format_func_name x (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.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EApp { f; args } ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
(Format.pp_print_list

7
compiler/shared_ast/boundList.ml
View File

@ -20,6 +20,13 @@ type ('e, 'elt, 'last) t = ('e, 'elt, 'last) bound_list =
| Last of 'last
| Cons of 'elt * ('e, ('e, 'elt, 'last) t) binder
let rec to_seq = function
| Last () -> Seq.empty
| Cons (item, next_bind) ->
fun () ->
let v, next = Bindlib.unbind next_bind in
Seq.Cons ((v, item), to_seq next)
let rec last = function
| Last e -> e
| Cons (_, bnd) ->

1
compiler/shared_ast/boundList.mli
View File

@ -30,6 +30,7 @@ type ('e, 'elt, 'last) t = ('e, 'elt, 'last) bound_list =
| Last of 'last
| Cons of 'elt * ('e, ('e, 'elt, 'last) t) binder
val to_seq : (((_, _) gexpr as 'e), 'elt, unit) t -> ('e Var.t * 'elt) Seq.t
val last : (_, _, 'a) t -> 'a
val iter : f:('e Var.t -> 'elt -> unit) -> ('e, 'elt, 'last) t -> 'last
val find : f:('elt -> 'a option) -> (_, 'elt, _) t -> 'a

21
compiler/shared_ast/definitions.ml
View File

@ -138,7 +138,6 @@ type desugared =
; explicitScopes : yes
; assertions : no
; defaultTerms : yes
; exceptions : no
; custom : no >
(* Technically, desugared before name resolution has [syntacticNames: yes;
resolvedNames: no], and after name resolution has the opposite; but the
@ -159,7 +158,6 @@ type scopelang =
; explicitScopes : yes
; assertions : no
; defaultTerms : yes
; exceptions : no
; custom : no >
type dcalc =
@ -173,7 +171,6 @@ type dcalc =
; explicitScopes : no
; assertions : yes
; defaultTerms : yes
; exceptions : no
; custom : no >
type lcalc =
@ -187,7 +184,6 @@ type lcalc =
; explicitScopes : no
; assertions : yes
; defaultTerms : no
; exceptions : yes
; custom : no >
type 'a any = < .. > as 'a
@ -206,12 +202,11 @@ type dcalc_lcalc_features =
; assertions : yes >
(** Features that are common to Dcalc and Lcalc *)
type ('a, 'b) dcalc_lcalc =
< dcalc_lcalc_features ; defaultTerms : 'a ; exceptions : 'b ; custom : no >
type 'd dcalc_lcalc = < dcalc_lcalc_features ; defaultTerms : 'd ; custom : no >
(** This type regroups Dcalc and Lcalc ASTs. *)
type ('a, 'b, 'c) interpr_kind =
< dcalc_lcalc_features ; defaultTerms : 'a ; exceptions : 'b ; custom : 'c >
type ('d, 'c) interpr_kind =
< dcalc_lcalc_features ; defaultTerms : 'd ; custom : 'c >
(** This type corresponds to the types handled by the interpreter: it regroups
Dcalc and Lcalc ASTs and may have custom terms *)
@ -372,8 +367,7 @@ module Op = struct
(* * polymorphic *)
| Reduce : < polymorphic ; .. > t
| Fold : < polymorphic ; .. > t
| HandleDefault : < polymorphic ; .. > t
| HandleDefaultOpt : < polymorphic ; .. > t
| HandleExceptions : < polymorphic ; .. > t
end
type 'a operator = 'a Op.t
@ -563,13 +557,6 @@ and ('a, 'b, 'm) base_gexpr =
| EErrorOnEmpty :
('a, 'm) gexpr
-> ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr
(* Lambda calculus with exceptions *)
| ERaiseEmpty : ('a, < exceptions : yes ; .. >, 'm) base_gexpr
| ECatchEmpty : {
body : ('a, 'm) gexpr;
handler : ('a, 'm) gexpr;
}
-> ('a, < exceptions : yes ; .. >, 'm) base_gexpr
(* Only used during evaluation *)
| ECustom : {
obj : Obj.t;

40
compiler/shared_ast/expr.ml
View File

@ -145,10 +145,6 @@ let eifthenelse cond etrue efalse =
let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> EErrorOnEmpty e1
let eempty mark = Mark.add mark (Bindlib.box EEmpty)
let eraiseempty mark = Mark.add mark (Bindlib.box ERaiseEmpty)
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 }))
@ -333,8 +329,6 @@ let map
| EPureDefault e1 -> epuredefault (f e1) m
| EEmpty -> eempty m
| EErrorOnEmpty e1 -> eerroronempty (f e1) 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
@ -365,9 +359,7 @@ 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 _ | EFatalError _ | EExternal _ | ERaiseEmpty | ELocation _
| EEmpty ->
acc
| ELit _ | EVar _ | EFatalError _ | EExternal _ | ELocation _ | EEmpty -> acc
| EApp { f = e; args; _ } -> acc |> f e |> lfold args
| EAppOp { args; _ } -> acc |> lfold args
| EArray args -> acc |> lfold args
@ -382,7 +374,6 @@ let shallow_fold
| EDefault { excepts; just; cons } -> acc |> lfold excepts |> f just |> f cons
| EPureDefault e -> acc |> f e
| EErrorOnEmpty e -> acc |> f e
| 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
@ -460,11 +451,6 @@ let map_gather
| EErrorOnEmpty e ->
let acc, e = f e in
acc, eerroronempty e m
| ECatchEmpty { body; handler } ->
let acc1, body = f body in
let acc2, handler = f handler in
join acc1 acc2, ecatchempty body handler m
| ERaiseEmpty -> acc, eraiseempty m
| ELocation loc -> acc, elocation loc m
| EStruct { name; fields } ->
let acc, fields =
@ -532,7 +518,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 _ | ERaiseEmpty | ECustom _ | EExternal _ -> true
| ELit _ | EAbs _ | ECustom _ | EExternal _ -> true
| _ -> false
let equal_lit (l1 : lit) (l2 : lit) =
@ -664,10 +650,6 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
equal if1 if2 && equal then1 then2 && equal else1 else2
| EEmpty, EEmpty -> true
| EErrorOnEmpty e1, EErrorOnEmpty e2 -> equal e1 e2
| 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 },
@ -700,10 +682,9 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
Type.equal_list targs1 targs2 && Type.equal tret1 tret2 && obj1 == obj2
| ( ( EVar _ | EExternal _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _
| EAbs _ | EApp _ | EAppOp _ | EAssert _ | EFatalError _ | EDefault _
| EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ERaiseEmpty
| ECatchEmpty _ | ELocation _ | EStruct _ | EDStructAmend _
| EDStructAccess _ | EStructAccess _ | EInj _ | EMatch _ | EScopeCall _
| ECustom _ ),
| EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ELocation _
| EStruct _ | EDStructAmend _ | EDStructAccess _ | EStructAccess _
| EInj _ | EMatch _ | EScopeCall _ | ECustom _ ),
_ ) ->
false
@ -796,11 +777,6 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
| EEmpty, EEmpty -> 0
| EErrorOnEmpty e1, EErrorOnEmpty e2 ->
compare e1 e2
| ERaiseEmpty, ERaiseEmpty -> 0
| ECatchEmpty {body=etry1; handler=ewith1},
ECatchEmpty {body=etry2; handler=ewith2} ->
compare etry1 etry2 @@< fun () ->
compare ewith1 ewith2
| ECustom _, _ | _, ECustom _ ->
(* fixme: ideally this would be forbidden by typing *)
invalid_arg "Custom block comparison"
@ -827,9 +803,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
| EDefault _, _ -> -1 | _, EDefault _ -> 1
| EPureDefault _, _ -> -1 | _, EPureDefault _ -> 1
| EEmpty , _ -> -1 | _, EEmpty -> 1
| EErrorOnEmpty _, _ -> -1 | _, EErrorOnEmpty _ -> 1
| ERaiseEmpty, _ -> -1 | _, ERaiseEmpty -> 1
| ECatchEmpty _, _ -> . | _, ECatchEmpty _ -> .
| EErrorOnEmpty _, _ -> . | _, EErrorOnEmpty _ -> .
let rec free_vars : ('a, 't) gexpr -> ('a, 't) gexpr Var.Set.t = function
| EVar v, _ -> Var.Set.singleton v
@ -960,8 +934,6 @@ let rec size : type a. (a, 't) gexpr -> int =
(fun acc except -> acc + size except)
(1 + size just + size cons)
excepts
| 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

7
compiler/shared_ast/expr.mli
View File

@ -117,13 +117,6 @@ val eerroronempty :
'm mark ->
((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr
val ecatchempty :
('a, 'm) boxed_gexpr ->
('a, 'm) boxed_gexpr ->
'm mark ->
((< exceptions : yes ; .. > as 'a), '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 :

149
compiler/shared_ast/interpreter.ml
View File

@ -422,36 +422,7 @@ let rec evaluate_operator
ELit (LBool (o_eq_dat_dat x y))
| Eq_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration 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 *)
match
List.filter_map
(fun e ->
try Some (evaluate_expr (Expr.unthunk_term_nobox e))
with Runtime.Empty -> None)
excepts
with
| [] -> (
let just = evaluate_expr (Expr.unthunk_term_nobox just) in
match Mark.remove just with
| ELit (LBool true) ->
Mark.remove (evaluate_expr (Expr.unthunk_term_nobox cons))
| ELit (LBool false) -> raise Runtime.Empty
| _ ->
Message.error ~pos
"Default justification has not been reduced to a boolean at@ \
evaluation@ (should not happen if the term was well-typed@\n\
%a@."
Expr.format just)
| [e] -> Mark.remove e
| es ->
raise
Runtime.(
Error
(Conflict, List.map (fun e -> Expr.pos_to_runtime (Expr.pos e)) es))
)
| HandleDefaultOpt, [(EArray exps, _); justification; conclusion] -> (
| HandleExceptions, [(EArray exps, _)] -> (
let valid_exceptions =
ListLabels.filter exps ~f:(function
| EInj { name; cons; _ }, _ when EnumName.equal name Expr.option_enum ->
@ -459,28 +430,9 @@ let rec evaluate_operator
| _ -> err ())
in
match valid_exceptions with
| [] -> (
let e = evaluate_expr (Expr.unthunk_term_nobox justification) in
match Mark.remove e with
| ELit (LBool true) ->
Mark.remove (evaluate_expr (Expr.unthunk_term_nobox conclusion))
| ELit (LBool false) ->
EInj
{
name = Expr.option_enum;
cons = Expr.none_constr;
e = Mark.copy justification (ELit LUnit);
}
| EInj { name; cons; e }
when EnumName.equal name Expr.option_enum
&& EnumConstructor.equal cons Expr.none_constr ->
EInj
{
name = Expr.option_enum;
cons = Expr.none_constr;
e = Mark.copy e (ELit LUnit);
}
| _ -> err ())
| [] ->
EInj
{ name = Expr.option_enum; cons = Expr.none_constr; e = ELit LUnit, m }
| [((EInj { cons; name; _ } as e), _)]
when EnumName.equal name Expr.option_enum
&& EnumConstructor.equal cons Expr.some_constr ->
@ -501,23 +453,22 @@ let rec evaluate_operator
| Lte_mon_mon | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat
| Gt_mon_mon | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat
| Gte_mon_mon | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat
| Eq_mon_mon | Eq_dat_dat | Eq_dur_dur | HandleDefault | HandleDefaultOpt
),
| Eq_mon_mon | Eq_dat_dat | Eq_dur_dur | HandleExceptions ),
_ ) ->
err ()
(* /S\ dark magic here. This relies both on internals of [Lcalc.to_ocaml] *and*
of the OCaml runtime *)
let rec runtime_to_val :
type d e.
type d.
(decl_ctx ->
((d, e, _) interpr_kind, 'm) gexpr ->
((d, e, _) interpr_kind, 'm) gexpr) ->
((d, _) interpr_kind, 'm) gexpr ->
((d, _) interpr_kind, 'm) gexpr) ->
decl_ctx ->
'm mark ->
typ ->
Obj.t ->
(((d, e, yes) interpr_kind as 'a), 'm) gexpr =
(((d, yes) interpr_kind as 'a), 'm) gexpr =
fun eval_expr ctx m ty o ->
let m = Expr.map_ty (fun _ -> ty) m in
match Mark.remove ty with
@ -578,21 +529,26 @@ let rec runtime_to_val :
(Array.to_list (Obj.obj o))),
m )
| TArrow (targs, tret) -> ECustom { obj = o; targs; tret }, m
| TDefault ty -> runtime_to_val eval_expr ctx m ty o
| TDefault ty -> (
(* This case is only valid for ASTs including default terms; but the typer
isn't aware so we need some additional dark arts. *)
match (Obj.obj o : 'a Runtime.Eoption.t) with
| Runtime.Eoption.ENone () -> Obj.magic EEmpty, m
| Runtime.Eoption.ESome o -> Obj.magic (runtime_to_val eval_expr ctx m ty o)
)
| TAny -> assert false
and val_to_runtime :
type d e.
type d.
(decl_ctx ->
((d, e, _) interpr_kind, 'm) gexpr ->
((d, e, _) interpr_kind, 'm) gexpr) ->
((d, _) interpr_kind, 'm) gexpr ->
((d, _) interpr_kind, 'm) gexpr) ->
decl_ctx ->
typ ->
((d, e, _) interpr_kind, 'm) gexpr ->
((d, _) interpr_kind, 'm) gexpr ->
Obj.t =
fun eval_expr ctx ty v ->
match Mark.remove ty, Mark.remove v with
| _, 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
@ -659,7 +615,11 @@ and val_to_runtime :
curry (runtime_to_val eval_expr ctx m targ x :: acc) targs)
in
curry [] targs
| TDefault ty, _ -> val_to_runtime eval_expr ctx ty v
| TDefault ty, _ -> (
match v with
| EEmpty, _ -> Obj.repr (Runtime.Eoption.ENone ())
| EPureDefault e, _ | e ->
Obj.repr (Runtime.Eoption.ESome (val_to_runtime eval_expr ctx ty e)))
| TClosureEnv, v ->
(* By construction, a closure environment can only be consumed from the same
scope where it was built (compiled or not) ; for this reason, we can
@ -671,11 +631,11 @@ and val_to_runtime :
Expr.format v
let rec evaluate_expr :
type d e.
type d.
decl_ctx ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
((d, yes) interpr_kind, 't) gexpr ->
((d, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
let m = Mark.get e in
let pos = Expr.mark_pos m in
@ -875,18 +835,14 @@ let rec evaluate_expr :
in
raise Runtime.(Error (Conflict, poslist)))
| EPureDefault e -> evaluate_expr ctx lang e
| ERaiseEmpty -> raise Runtime.Empty
| ECatchEmpty { body; handler } -> (
try evaluate_expr ctx lang body
with Runtime.Empty -> evaluate_expr ctx lang handler)
| _ -> .
and partially_evaluate_expr_for_assertion_failure_message :
type d e.
type d.
decl_ctx ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
((d, yes) interpr_kind, 't) gexpr ->
((d, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
(* Here we want to print an expression that explains why an assertion has
failed. Since assertions have type [bool] and are usually constructed with
@ -921,11 +877,11 @@ and partially_evaluate_expr_for_assertion_failure_message :
| _ -> evaluate_expr ctx lang e
let evaluate_expr_trace :
type d e.
type d.
decl_ctx ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
((d, yes) interpr_kind, 't) gexpr ->
((d, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
Fun.protect
(fun () -> evaluate_expr ctx lang e)
@ -937,11 +893,11 @@ let evaluate_expr_trace :
(Runtime.EventParser.parse_raw_events trace)] fais here, check why *))
let evaluate_expr_safe :
type d e.
type d.
decl_ctx ->
Global.backend_lang ->
((d, e, yes) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr =
((d, yes) interpr_kind, 't) gexpr ->
((d, yes) interpr_kind, 't) gexpr =
fun ctx lang e ->
try evaluate_expr_trace ctx lang e
with Runtime.Error (err, rpos) ->
@ -953,9 +909,9 @@ let evaluate_expr_safe :
(* Typing shenanigan to add custom terms to the AST type. *)
let addcustom e =
let rec f :
type c d e.
((d, e, c) interpr_kind, 't) gexpr ->
((d, e, yes) interpr_kind, 't) gexpr boxed = function
type c d.
((d, c) interpr_kind, 't) gexpr -> ((d, yes) interpr_kind, 't) gexpr boxed
= function
| (ECustom _, _) as e -> Expr.map ~f e
| EAppOp { op; tys; args }, m ->
Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) m
@ -963,8 +919,6 @@ let addcustom e =
| (EPureDefault _, _) as e -> Expr.map ~f e
| (EEmpty, _) as e -> Expr.map ~f e
| (EErrorOnEmpty _, _) as e -> Expr.map ~f e
| (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 _ ),
@ -974,8 +928,8 @@ let addcustom e =
in
let open struct
external id :
(('d, 'e, 'c) interpr_kind, 't) gexpr ->
(('d, 'e, yes) interpr_kind, 't) gexpr = "%identity"
(('d, 'c) interpr_kind, 't) gexpr -> (('d, yes) interpr_kind, 't) gexpr
= "%identity"
end in
if false then Expr.unbox (f e)
(* We keep the implementation as a typing proof, but bypass the AST
@ -985,9 +939,9 @@ let addcustom e =
let delcustom e =
let rec f :
type c d e.
((d, e, c) interpr_kind, 't) gexpr ->
((d, e, no) interpr_kind, 't) gexpr boxed = function
type c d.
((d, c) interpr_kind, 't) gexpr -> ((d, no) interpr_kind, 't) gexpr boxed
= function
| ECustom _, _ -> invalid_arg "Custom term remaining in evaluated term"
| EAppOp { op; args; tys }, m ->
Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) m
@ -995,8 +949,6 @@ let delcustom e =
| (EPureDefault _, _) as e -> Expr.map ~f e
| (EEmpty, _) as e -> Expr.map ~f e
| (EErrorOnEmpty _, _) as e -> Expr.map ~f e
| (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 _ ),
@ -1027,22 +979,13 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(fun ty ->
match Mark.remove ty with
| TArrow (ty_in, (TOption _, _)) ->
(* Context args may return an option if avoid_exceptions is on *)
(* Context args should return an option *)
Expr.make_abs
(Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in)
(Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr
~name:Expr.option_enum mark_e
: (_, _) boxed_gexpr)
ty_in pos
| TArrow (ty_in, ty_out) ->
(* Or a default term (translated into a plain one if it is off) *)
(* Note: this might catch non-context args, but since the
compilation to lcalc strips the default around [ty_out] we can't
tell with just this info. *)
Expr.make_abs
(Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in)
(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 *)
Expr.make_tuple

12
compiler/shared_ast/interpreter.mli
View File

@ -21,7 +21,7 @@ open Catala_utils
open Definitions
val evaluate_operator :
((((_, _, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
((((_, _) interpr_kind as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
'a operator Mark.pos ->
'm mark ->
Global.backend_lang ->
@ -35,14 +35,14 @@ val evaluate_operator :
val evaluate_expr :
decl_ctx ->
Global.backend_lang ->
(('a, 'b, _) interpr_kind, 'm) gexpr ->
(('a, 'b, yes) interpr_kind, 'm) gexpr
(('a, _) interpr_kind, 'm) gexpr ->
(('a, yes) interpr_kind, 'm) gexpr
(** Evaluates an expression according to the semantics of the default calculus. *)
val interpret_program_dcalc :
(dcalc, 'm) gexpr program ->
ScopeName.t ->
(Uid.MarkedString.info * ((yes, no, yes) interpr_kind, 'm) gexpr) list
(Uid.MarkedString.info * ((yes, yes) interpr_kind, 'm) gexpr) list
(** Interprets a program. This function expects an expression typed as a
function whose argument are all thunked. The function is executed by
providing for each argument a thunked empty default. Returns a list of all
@ -51,14 +51,14 @@ val interpret_program_dcalc :
val interpret_program_lcalc :
(lcalc, 'm) gexpr program ->
ScopeName.t ->
(Uid.MarkedString.info * ((no, yes, yes) interpr_kind, 'm) gexpr) list
(Uid.MarkedString.info * ((no, yes) interpr_kind, 'm) gexpr) list
(** Interprets a program. This function expects an expression typed as a
function whose argument are all thunked. The function is executed by
providing for each argument a thunked empty default. Returns a list of all
the computed values for the scope variables of the executed scope. *)
val delcustom :
(('a, 'b, 'c) interpr_kind, 'm) gexpr -> (('a, 'b, no) interpr_kind, 'm) gexpr
(('a, 'b) interpr_kind, 'm) gexpr -> (('a, no) interpr_kind, 'm) gexpr
(** Runtime check that the term contains no custom terms (raises
[Invalid_argument] if that is the case *)

37
compiler/shared_ast/operator.ml
View File

@ -108,8 +108,7 @@ let name : type a. a t -> string = function
| Eq_dur_dur -> "o_eq_dur_dur"
| Eq_dat_dat -> "o_eq_dat_dat"
| Fold -> "o_fold"
| HandleDefault -> "o_handledefault"
| HandleDefaultOpt -> "o_handledefaultopt"
| HandleExceptions -> "handle_exceptions"
| ToClosureEnv -> "o_toclosureenv"
| FromClosureEnv -> "o_fromclosureenv"
@ -232,8 +231,7 @@ let compare (type a1 a2) (t1 : a1 t) (t2 : a2 t) =
| Eq_dat_dat, Eq_dat_dat
| Eq_dur_dur, Eq_dur_dur
| Fold, Fold
| HandleDefault, HandleDefault
| HandleDefaultOpt, HandleDefaultOpt
| HandleExceptions, HandleExceptions
| FromClosureEnv, FromClosureEnv | ToClosureEnv, ToClosureEnv -> 0
| Not, _ -> -1 | _, Not -> 1
| Length, _ -> -1 | _, Length -> 1
@ -318,8 +316,7 @@ let compare (type a1 a2) (t1 : a1 t) (t2 : a2 t) =
| Eq_mon_mon, _ -> -1 | _, Eq_mon_mon -> 1
| Eq_dat_dat, _ -> -1 | _, Eq_dat_dat -> 1
| Eq_dur_dur, _ -> -1 | _, Eq_dur_dur -> 1
| HandleDefault, _ -> -1 | _, HandleDefault -> 1
| HandleDefaultOpt, _ -> -1 | _, HandleDefaultOpt -> 1
| HandleExceptions, _ -> -1 | _, HandleExceptions -> 1
| FromClosureEnv, _ -> -1 | _, FromClosureEnv -> 1
| ToClosureEnv, _ -> -1 | _, ToClosureEnv -> 1
| Fold, _ | _, Fold -> .
@ -344,7 +341,7 @@ let kind_dispatch :
_ ) as op ->
monomorphic op
| ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold
| HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ),
| HandleExceptions | FromClosureEnv | ToClosureEnv ),
_ ) as op ->
polymorphic op
| ( ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt
@ -377,19 +374,19 @@ type 'a no_overloads =
let translate (t : 'a no_overloads t Mark.pos) : 'b no_overloads t Mark.pos =
match t with
| ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| And | Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq
| Map | Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat
| Minus_mon | Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat
| Round_mon | Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _
| Add_dur_dur | Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat
| Sub_dat_dur | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat
| Mult_dur_int | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat
| Div_dur_dur | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat
| Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat
| Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat
| Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat
| Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat
| Eq_dur_dur | FromClosureEnv | ToClosureEnv ),
| And | Or | Xor | HandleExceptions | Log _ | Length | Eq | Map | Map2
| Concat | Filter | Reduce | Fold | Minus_int | Minus_rat | Minus_mon
| Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat | Round_mon
| Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _ | Add_dur_dur
| Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur
| Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat | Mult_dur_int
| Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur
| Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur
| Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur
| Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur
| Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur
| Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur
| FromClosureEnv | ToClosureEnv ),
_ ) as op ->
op

25
compiler/shared_ast/optimizations.ml
View File

@ -58,14 +58,14 @@ let all_match_cases_map_to_same_constructor cases n =
let binder_vars_used_at_most_once
(binder :
( (('a, 'b) dcalc_lcalc, ('a, 'b) dcalc_lcalc, 'm) base_gexpr,
(('a, 'b) dcalc_lcalc, 'm) gexpr )
( ('a dcalc_lcalc, 'a dcalc_lcalc, 'm) base_gexpr,
('a dcalc_lcalc, 'm) gexpr )
Bindlib.mbinder) : bool =
(* fast path: variables not used at all *)
(not (Array.exists Fun.id (Bindlib.mbinder_occurs binder)))
||
let vars, body = Bindlib.unmbind binder in
let rec vars_count (e : (('a, 'b) dcalc_lcalc, 'm) gexpr) : int array =
let rec vars_count (e : ('a dcalc_lcalc, 'm) gexpr) : int array =
match e with
| EVar v, _ ->
Array.map
@ -82,8 +82,8 @@ let binder_vars_used_at_most_once
let rec optimize_expr :
type a b.
(a, b, 'm) optimizations_ctx ->
((a, b) dcalc_lcalc, 'm) gexpr ->
((a, b) dcalc_lcalc, 'm) boxed_gexpr =
(a dcalc_lcalc, 'm) gexpr ->
(a dcalc_lcalc, 'm) boxed_gexpr =
fun ctx e ->
(* We proceed bottom-up, first apply on the subterms *)
let e = Expr.map ~f:(optimize_expr ctx) ~op:Fun.id e in
@ -92,7 +92,7 @@ let rec optimize_expr :
able to keep the inner position (see the division_by_zero test) *)
(* Then reduce the parent node (this is applied through Box.apply, therefore
delayed to unbinding time: no need to be concerned about reboxing) *)
let reduce (e : ((a, b) dcalc_lcalc, 'm) gexpr) =
let reduce (e : (a dcalc_lcalc, 'm) gexpr) =
(* Todo: improve the handling of eapp(log,elit) cases here, it obfuscates
the matches and the log calls are not preserved, which would be a good
property *)
@ -365,22 +365,15 @@ let rec optimize_expr :
el) ->
(* identity tuple reconstruction *)
Mark.remove e
| ECatchEmpty { body; handler } -> (
(* peephole exception catching reductions *)
match Mark.remove body, Mark.remove handler with
| ERaiseEmpty, _ -> Mark.remove handler
| _, ERaiseEmpty -> Mark.remove body
| _ -> ECatchEmpty { body; handler })
| e -> e
in
Expr.Box.app1 e reduce mark
let optimize_expr :
'm.
decl_ctx ->
(('a, 'b) dcalc_lcalc, 'm) gexpr ->
(('a, 'b) dcalc_lcalc, 'm) boxed_gexpr =
fun (decl_ctx : decl_ctx) (e : (('a, 'b) dcalc_lcalc, 'm) gexpr) ->
decl_ctx -> ('a dcalc_lcalc, 'm) gexpr -> ('a dcalc_lcalc, 'm) boxed_gexpr
=
fun (decl_ctx : decl_ctx) (e : ('a dcalc_lcalc, 'm) gexpr) ->
optimize_expr { decl_ctx } e
let optimize_program (p : 'm program) : 'm program =

7
compiler/shared_ast/optimizations.mli
View File

@ -21,13 +21,10 @@
open Definitions
val optimize_expr :
decl_ctx ->
(('a, 'b) dcalc_lcalc, 'm) gexpr ->
(('a, 'b) dcalc_lcalc, 'm) boxed_gexpr
decl_ctx -> ('a dcalc_lcalc, 'm) gexpr -> ('a dcalc_lcalc, 'm) boxed_gexpr
val optimize_program :
(('a, 'b) dcalc_lcalc, 'm) gexpr program ->
(('a, 'b) dcalc_lcalc, 'm) gexpr program
('a dcalc_lcalc, 'm) gexpr program -> ('a dcalc_lcalc, 'm) gexpr program
(** {1 Tests}*)

54
compiler/shared_ast/print.ml
View File

@ -142,7 +142,7 @@ let rec typ_gen
mty))
def punctuation "]")
| TOption t ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "eoption" (typ ~colors) t
Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "option" (typ ~colors) t
| TArrow ([t1], t2) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" (typ_with_parens ~colors) t1
op_style "→" (typ ~colors) t2
@ -280,8 +280,7 @@ let operator_to_string : type a. a Op.t -> string =
| Eq_dur_dur -> "=^"
| Eq_dat_dat -> "=@"
| Fold -> "fold"
| HandleDefault -> "handle_default"
| HandleDefaultOpt -> "handle_default_opt"
| HandleExceptions -> "handle_exceptions"
| ToClosureEnv -> "to_closure_env"
| FromClosureEnv -> "from_closure_env"
@ -325,8 +324,7 @@ let operator_to_shorter_string : type a. a Op.t -> string =
| Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dur_dur | Gte_dat_dat | Gte ->
">="
| Fold -> "fold"
| HandleDefault -> "handle_default"
| HandleDefaultOpt -> "handle_default_opt"
| HandleExceptions -> "handle_exceptions"
| ToClosureEnv -> "to_closure_env"
| FromClosureEnv -> "from_closure_env"
@ -402,8 +400,8 @@ module Precedence = struct
| Div | Div_int_int | Div_rat_rat | Div_mon_rat | Div_mon_mon
| Div_dur_dur ->
Op Div
| HandleDefault | HandleDefaultOpt | Map | Map2 | Concat | Filter | Reduce
| Fold | ToClosureEnv | FromClosureEnv ->
| HandleExceptions | Map | Map2 | Concat | Filter | Reduce | Fold
| ToClosureEnv | FromClosureEnv ->
App)
| EApp _ -> App
| EArray _ -> Contained
@ -426,8 +424,6 @@ module Precedence = struct
| EPureDefault _ -> Contained
| EEmpty -> Contained
| EErrorOnEmpty _ -> App
| ERaiseEmpty -> App
| ECatchEmpty _ -> App
| ECustom _ -> Contained
let needs_parens ~context ?(rhs = false) e =
@ -671,12 +667,6 @@ module ExprGen (C : EXPR_PARAM) = struct
| 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" op_style "Empty" (rhs exprc) handler
| ERaiseEmpty ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" op_style "Empty"
| ELocation loc -> location fmt loc
| EDStructAccess { e; field; _ } ->
Format.fprintf fmt "@[<hv 2>%a%a@,%a%a%a@]" (lhs exprc) e punctuation
@ -712,7 +702,6 @@ module ExprGen (C : EXPR_PARAM) = struct
Format.fprintf fmt "@[<v 0>@[<hv 2>%a@ %a@;<1 -2>%a@]@ %a@]" keyword
"match" (lhs exprc) e keyword "with"
(EnumConstructor.Map.format_bindings
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt pp_cons_name case_expr ->
match case_expr with
| EAbs { binder; tys; _ }, _ ->
@ -868,13 +857,12 @@ let enum
fmt
(pp_name : Format.formatter -> unit)
(c : typ EnumConstructor.Map.t) =
Format.fprintf fmt "@[<h 0>%a %t %a@ %a@]" keyword "type" pp_name punctuation
"="
(EnumConstructor.Map.format_bindings
~pp_sep:(fun _ _ -> ())
Format.fprintf fmt "@[<h 0>%a %t %a@ %a@]@," keyword "type" pp_name
punctuation "="
(EnumConstructor.Map.format_bindings ~pp_sep:Format.pp_print_space
(fun fmt pp_n ty ->
Format.fprintf fmt "@[<hov2> %a %t %a %a@]@;" punctuation "|" pp_n
keyword "of"
Format.fprintf fmt "@[<hov2>%a %t %a %a@]" punctuation "|" pp_n keyword
"of"
(if debug then typ_debug else typ decl_ctx)
ty))
c
@ -897,14 +885,10 @@ let struct_
let decl_ctx ?(debug = false) decl_ctx (fmt : Format.formatter) (ctx : decl_ctx)
: unit =
let { ctx_enums; ctx_structs; _ } = ctx in
Format.fprintf fmt "%a@.%a@.@."
(EnumName.Map.format_bindings
~pp_sep:(fun fmt () -> Format.fprintf fmt "@.")
(enum ~debug decl_ctx))
Format.fprintf fmt "@[<v>%a@,%a@,@,@]"
(EnumName.Map.format_bindings (enum ~debug decl_ctx))
ctx_enums
(StructName.Map.format_bindings
~pp_sep:(fun fmt () -> Format.fprintf fmt "@.")
(struct_ ~debug decl_ctx))
(StructName.Map.format_bindings (struct_ ~debug decl_ctx))
ctx_structs
let scope
@ -936,11 +920,15 @@ let code_item ?(debug = false) ?name decl_ctx fmt c =
"=" (expr ~debug ()) e
let code_item_list ?(debug = false) decl_ctx fmt c =
BoundList.iter c ~f:(fun x item ->
Format.pp_open_vbox fmt 0;
Format.pp_print_seq
(fun fmt (x, item) ->
code_item ~debug
~name:(Format.asprintf "%a" var_debug x)
decl_ctx fmt item;
Format.pp_print_newline fmt ())
Format.pp_print_cut fmt ())
fmt (BoundList.to_seq c);
Format.pp_close_box fmt ()
let program ?(debug = false) fmt p =
decl_ctx ~debug p.decl_ctx fmt p.decl_ctx;
@ -1136,8 +1124,8 @@ module UserFacing = struct
| EExternal _ -> Format.pp_print_string ppf "<external>"
| EApp _ | EAppOp _ | EVar _ | EIfThenElse _ | EMatch _ | ETupleAccess _
| EStructAccess _ | EAssert _ | EFatalError _ | EDefault _ | EPureDefault _
| EErrorOnEmpty _ | ERaiseEmpty | ECatchEmpty _ | ELocation _ | EScopeCall _
| EDStructAmend _ | EDStructAccess _ | ECustom _ ->
| EErrorOnEmpty _ | ELocation _ | EScopeCall _ | EDStructAmend _
| EDStructAccess _ | ECustom _ ->
fallback ppf e
let expr :

32
compiler/shared_ast/typing.ml
View File

@ -294,7 +294,6 @@ let polymorphic_op_type (op : Operator.polymorphic A.operator Mark.pos) :
let any2 = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in
let any3 = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in
let bt = lazy (UnionFind.make (TLit TBool, pos)) in
let ut = lazy (UnionFind.make (TLit TUnit, pos)) in
let it = lazy (UnionFind.make (TLit TInt, pos)) in
let cet = lazy (UnionFind.make (TClosureEnv, pos)) in
let array a = lazy (UnionFind.make (TArray (Lazy.force a), pos)) in
@ -314,9 +313,7 @@ let polymorphic_op_type (op : Operator.polymorphic A.operator Mark.pos) :
| Log (PosRecordIfTrueBool, _) -> [bt] @-> bt
| Log _ -> [any] @-> any
| Length -> [array any] @-> it
| HandleDefault -> [array ([ut] @-> any); [ut] @-> bt; [ut] @-> any] @-> any
| HandleDefaultOpt ->
[array (option any); [ut] @-> bt; [ut] @-> option any] @-> option any
| HandleExceptions -> [array (option any)] @-> option any
| ToClosureEnv -> [any] @-> cet
| FromClosureEnv -> [cet] @-> any
in
@ -348,7 +345,7 @@ let polymorphic_op_return_type
| Log (PosRecordIfTrueBool, _), _ -> uf (TLit TBool)
| Log _, [tau] -> tau
| Length, _ -> uf (TLit TInt)
| (HandleDefault | HandleDefaultOpt), [_; _; tf] -> return_type tf 1
| HandleExceptions, [_] -> any ()
| ToClosureEnv, _ -> uf TClosureEnv
| FromClosureEnv, _ -> any ()
| _ -> Message.error ~pos "Mismatched operator arguments"
@ -760,11 +757,6 @@ and typecheck_expr_top_down :
args
in
Expr.escopecall ~scope ~args:args' mark
| 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.ecatchempty body' handler' context_mark
| A.EVar v ->
let tau' =
match Env.get env v with
@ -895,15 +887,17 @@ and typecheck_expr_top_down :
let args =
Operator.kind_dispatch (Mark.set pos_e op)
~polymorphic:(fun op ->
(* Type the operator first, then right-to-left: polymorphic operators
are required to allow the resolution of all type variables this
way *)
if not env.flags.assume_op_types then
unify ctx e (polymorphic_op_type op) t_func
else unify ctx e (polymorphic_op_return_type ctx e op t_args) tau;
List.rev_map2
(typecheck_expr_top_down ctx env)
(List.rev t_args) (List.rev args))
if env.flags.assume_op_types then (
unify ctx e (polymorphic_op_return_type ctx e op t_args) tau;
List.rev_map (typecheck_expr_bottom_up ctx env) (List.rev args))
else (
(* Type the operator first, then right-to-left: polymorphic
operators are required to allow the resolution of all type
variables this way *)
unify ctx e (polymorphic_op_type op) t_func;
List.rev_map2
(typecheck_expr_top_down ctx env)
(List.rev t_args) (List.rev args)))
~overloaded:(fun op ->
(* Typing the arguments first is required to resolve the operator *)
let args' = List.map2 (typecheck_expr_top_down ctx env) t_args args in

29
runtimes/ocaml/runtime.ml
View File

@ -716,32 +716,9 @@ module EventParser = struct
ctx.events
end
let handle_default :
'a.
source_position array ->
(unit -> 'a) array ->
(unit -> bool) ->
(unit -> 'a) ->
'a =
fun pos exceptions just cons ->
let len = Array.length exceptions in
let rec filt_except i =
if i < len then
match exceptions.(i) () with
| new_val -> (new_val, i) :: filt_except (i + 1)
| exception Empty -> filt_except (i + 1)
else []
in
match filt_except 0 with
| [] -> if just () then cons () else raise Empty
| [(res, _)] -> res
| res -> error Conflict (List.map (fun (_, i) -> pos.(i)) res)
let handle_default_opt
let handle_exceptions
(pos : source_position array)
(exceptions : 'a Eoption.t array)
(just : unit -> bool)
(cons : unit -> 'a Eoption.t) : 'a Eoption.t =
(exceptions : 'a Eoption.t array) : 'a Eoption.t =
let len = Array.length exceptions in
let rec filt_except i =
if i < len then
@ -751,7 +728,7 @@ let handle_default_opt
else []
in
match filt_except 0 with
| [] -> if just () then cons () else Eoption.ENone ()
| [] -> Eoption.ENone ()
| [(res, _)] -> res
| res -> error Conflict (List.map (fun (_, i) -> pos.(i)) res)

17
runtimes/ocaml/runtime.mli
View File

@ -335,21 +335,8 @@ val duration_to_string : duration -> string
(**{1 Defaults} *)
val handle_default :
source_position array ->
(unit -> 'a) array ->
(unit -> bool) ->
(unit -> 'a) ->
'a
(** @raise Empty
@raise Error Conflict *)
val handle_default_opt :
source_position array ->
'a Eoption.t array ->
(unit -> bool) ->
(unit -> 'a Eoption.t) ->
'a Eoption.t
val handle_exceptions :
source_position array -> 'a Eoption.t array -> 'a Eoption.t
(** @raise Error Conflict *)
(**{1 Operators} *)

62
runtimes/python/src/catala/runtime.py
View File

@ -383,9 +383,9 @@ class NoValue(CatalaError):
source_position)
class Conflict(CatalaError):
def __init__(self, source_position: SourcePosition) -> None:
super().__init__("two or more concurring valid computations",
source_position)
def __init__(self, pos1: SourcePosition, pos2: SourcePosition) -> None:
super().__init__("two or more concurring valid computations:\nAt {}".format(pos2),
pos1)
class DivisionByZero(CatalaError):
def __init__(self, source_position: SourcePosition) -> None:
@ -606,56 +606,20 @@ def list_length(l: List[Alpha]) -> Integer:
# ========
def handle_default(
pos: SourcePosition,
exceptions: List[Callable[[Unit], Alpha]],
just: Callable[[Unit], Alpha],
cons: Callable[[Unit], Alpha]
) -> Alpha:
def handle_exceptions(
pos: List[SourcePosition],
exceptions: List[Optional[Alpha]]) -> Optional[Alpha]:
acc: Optional[Alpha] = None
for exception in exceptions:
new_val: Optional[Alpha]
try:
new_val = exception(Unit())
except Empty:
new_val = None
if acc is None:
acc = new_val
elif not (acc is None) and new_val is None:
acc_pos: Optional[pos] = None
for exception, pos in zip(exceptions, pos):
if exception is None:
pass # acc stays the same
elif not (acc is None) and not (new_val is None):
raise Conflict(pos)
if acc is None:
if just(Unit()):
return cons(Unit())
else:
raise Empty
else:
return acc
def handle_default_opt(
pos: SourcePosition,
exceptions: List[Optional[Any]],
just: Callable[[Unit], bool],
cons: Callable[[Unit], Optional[Alpha]]
) -> Optional[Alpha]:
acc: Optional[Alpha] = None
for exception in exceptions:
if acc is None:
elif acc is None:
acc = exception
elif not (acc is None) and exception is None:
pass # acc stays the same
elif not (acc is None) and not (exception is None):
raise Conflict(pos)
if acc is None:
b = just(Unit())
if b:
return cons(Unit())
acc_pos = pos
else:
return None
else:
return acc
raise Conflict(acc_pos,pos)
return acc
def no_input() -> Callable[[Unit], Alpha]:

1
runtimes/r/NAMESPACE
View File

@ -16,7 +16,6 @@ export(catala_decimal_to_numeric)
export(catala_duration_from_ymd)
export(catala_duration_to_ymd)
export(catala_empty_error)
export(catala_handle_default)
export(catala_integer_from_numeric)
export(catala_integer_from_string)
export(catala_integer_to_numeric)

30
runtimes/r/R/runtime.R
View File

@ -363,36 +363,6 @@ catala_assertion_failure <- function(pos) {
################ Defaults #################
#' @export
catala_handle_default <- function(pos, exceptions, just, cons) {
acc <- Reduce(function(acc, exception) {
new_val <- tryCatch(
exception(new("catala_unit", v = 0)),
catala_empty_error = function(e) {
NULL
}
)
if (is.null(acc)) {
new_val
} else {
if (is.null(new_val)) {
acc
} else {
stop(catala_conflict_error(pos))
}
}
}, exceptions, NULL)
if (is.null(acc)) {
if (just(new("catala_unit", v = 0))) {
cons(new("catala_unit", v = 0))
} else {
stop(catala_empty_error())
}
} else {
acc
}
}
# This value is used for the R code generation to trump R and forcing
# it to accept dead code. Indeed, when raising an exception during a variable
# definition, R could complains that the later dead code will not know what

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

@ -86,114 +86,116 @@ typedef struct array_1_struct {
int length_field;
} array_1_struct;
typedef struct tuple_0_struct {
typedef struct tuple_1_struct {
option_1_enum (*elt_0_field)(void * /* closure_env */ arg_0_typ, void* /* unit */ arg_1_typ);
void * /* closure_env */ elt_1_field;
} tuple_0_struct;
} tuple_1_struct;
typedef struct baz_in_struct {
tuple_0_struct a_in_field;
tuple_1_struct a_in_field;
} baz_in_struct;
baz_struct baz_func(baz_in_struct baz_in) {
tuple_0_struct a;
tuple_1_struct a;
a = baz_in.a_in_field;
bar_enum temp_a;
option_1_enum temp_a_1;
tuple_0_struct code_and_env;
tuple_1_struct code_and_env;
code_and_env = a;
option_1_enum (*code)(void * /* closure_env */ arg_0_typ, void* /* unit */ arg_1_typ);
void * /* closure_env */ env;
code = code_and_env.elt_0_field;
env = code_and_env.elt_1_field;
option_1_enum exception_acc = {option_1_enum_none_1_cons,
{none_1_cons: NULL}};
option_1_enum exception_current;
char exception_conflict = 0;
exception_current = code(env, NULL);
if (exception_current.code == option_1_enum_some_1_cons) {
if (exception_acc.code == option_1_enum_some_1_cons) {
exception_conflict = 1;
} else {
exception_acc = exception_current;
}
}
if (exception_conflict) {
catala_raise_fatal_error(catala_conflict,
"tests/backends/simple.catala_en", 11, 11, 11, 12);
}
if (exception_acc.code == option_1_enum_some_1_cons) {
temp_a_1 = exception_acc;
} else {
if (1 /* TRUE */) {
bar_enum temp_a_2;
option_1_enum temp_a_3;
option_1_enum temp_a_4;
array_1_struct temp_a_2;
temp_a_2.content_field = catala_malloc(sizeof(array_1_struct));
temp_a_2.content_field[0] = code(env, NULL);
option_1_enum match_arg = catala_handle_exceptions(temp_a_2);
switch (match_arg.code) {
case option_1_enum_none_1_cons:
if (1 /* TRUE */) {
bar_enum temp_a_5 = {bar_enum_no_cons, {no_cons: NULL}};
option_1_enum temp_a_6 = {option_1_enum_some_1_cons,
{some_1_cons: temp_a_5}};
temp_a_4 = temp_a_6;
} else {
temp_a_4.code = option_1_enum_none_1_cons;
temp_a_4.payload.none_1_cons = NULL;
}
option_1_enum exception_acc_1 = {option_1_enum_none_1_cons,
{none_1_cons: NULL}};
option_1_enum exception_current_1;
char exception_conflict_1 = 0;
exception_current_1 = temp_a_4;
if (exception_current_1.code == option_1_enum_some_1_cons) {
if (exception_acc_1.code == option_1_enum_some_1_cons) {
exception_conflict_1 = 1;
} else {
exception_acc_1 = exception_current_1;
bar_enum temp_a_3;
option_1_enum temp_a_4;
option_1_enum temp_a_5;
array_1_struct temp_a_6;
temp_a_6.content_field = catala_malloc(sizeof(array_1_struct));
option_1_enum match_arg_1 = catala_handle_exceptions(temp_a_6);
switch (match_arg_1.code) {
case option_1_enum_none_1_cons:
if (1 /* TRUE */) {
bar_enum temp_a_7 = {bar_enum_no_cons, {no_cons: NULL}};
option_1_enum temp_a_5 = {option_1_enum_some_1_cons,
{some_1_cons: temp_a_7}};
} else {
option_1_enum temp_a_5 = {option_1_enum_none_1_cons,
{none_1_cons: NULL}};
}
break;
case option_1_enum_some_1_cons:
bar_enum x = match_arg_1.payload.some_1_cons;
option_1_enum temp_a_5 = {option_1_enum_some_1_cons,
{some_1_cons: x}};
break;
}
}
if (exception_conflict_1) {
catala_raise_fatal_error(catala_conflict,
"tests/backends/simple.catala_en", 11, 11, 11, 12);
}
if (exception_acc_1.code == option_1_enum_some_1_cons) {
temp_a_3 = exception_acc_1;
} else {
if (0 /* FALSE */) {
option_1_enum temp_a_7 = {option_1_enum_none_1_cons,
{none_1_cons: NULL}};
temp_a_3 = temp_a_7;
} else {
temp_a_3.code = option_1_enum_none_1_cons;
temp_a_3.payload.none_1_cons = NULL;
array_1_struct temp_a_8;
temp_a_8.content_field = catala_malloc(sizeof(array_1_struct));
temp_a_8.content_field[0] = temp_a_5;
option_1_enum match_arg_2 = catala_handle_exceptions(temp_a_8);
switch (match_arg_2.code) {
case option_1_enum_none_1_cons:
if (0 /* FALSE */) {
option_1_enum temp_a_4 = {option_1_enum_none_1_cons,
{none_1_cons: NULL}};
} else {
option_1_enum temp_a_4 = {option_1_enum_none_1_cons,
{none_1_cons: NULL}};
}
break;
case option_1_enum_some_1_cons:
bar_enum x_1 = match_arg_2.payload.some_1_cons;
option_1_enum temp_a_4 = {option_1_enum_some_1_cons,
{some_1_cons: x_1}};
break;
}
option_1_enum match_arg_3 = temp_a_4;
switch (match_arg_3.code) {
case option_1_enum_none_1_cons:
catala_raise_fatal_error (catala_no_value,
"tests/backends/simple.catala_en", 11, 11, 11, 12);
break;
case option_1_enum_some_1_cons:
bar_enum arg = match_arg_3.payload.some_1_cons;
temp_a_3 = arg;
break;
}
option_1_enum temp_a_1 = {option_1_enum_some_1_cons,
{some_1_cons: temp_a_3}};
} else {
option_1_enum temp_a_1 = {option_1_enum_none_1_cons,
{none_1_cons: NULL}};
}
option_1_enum match_arg = temp_a_3;
switch (match_arg.code) {
case option_1_enum_none_1_cons:
catala_raise_fatal_error (catala_no_value,
"tests/backends/simple.catala_en", 11, 11, 11, 12);
break;
case option_1_enum_some_1_cons:
bar_enum arg = match_arg.payload.some_1_cons;
temp_a_2 = arg;
break;
}
option_1_enum temp_a_8 = {option_1_enum_some_1_cons,
{some_1_cons: temp_a_2}};
temp_a_1 = temp_a_8;
} else {
temp_a_1.code = option_1_enum_none_1_cons;
temp_a_1.payload.none_1_cons = NULL;
}
break;
case option_1_enum_some_1_cons:
bar_enum x_2 = match_arg.payload.some_1_cons;
option_1_enum temp_a_1 = {option_1_enum_some_1_cons,
{some_1_cons: x_2}};
break;
}
option_1_enum match_arg_1 = temp_a_1;
switch (match_arg_1.code) {
option_1_enum match_arg_4 = temp_a_1;
switch (match_arg_4.code) {
case option_1_enum_none_1_cons:
catala_raise_fatal_error (catala_no_value,
"tests/backends/simple.catala_en", 11, 11, 11, 12);
break;
case option_1_enum_some_1_cons:
bar_enum arg_1 = match_arg_1.payload.some_1_cons;
bar_enum arg_1 = match_arg_4.payload.some_1_cons;
temp_a = arg_1;
break;
}
@ -203,133 +205,143 @@ baz_struct baz_func(baz_in_struct baz_in) {
option_2_enum temp_b_1;
option_2_enum temp_b_2;
option_2_enum temp_b_3;
char /* bool */ temp_b_4;
bar_enum match_arg_2 = a_1;
switch (match_arg_2.code) {
case bar_enum_no_cons: temp_b_4 = 1 /* TRUE */; break;
case bar_enum_yes_cons:
foo_struct dummy_var = match_arg_2.payload.yes_cons;
temp_b_4 = 0 /* FALSE */;
array_2_struct temp_b_4;
temp_b_4.content_field = catala_malloc(sizeof(array_2_struct));
option_2_enum match_arg_5 = catala_handle_exceptions(temp_b_4);
switch (match_arg_5.code) {
case option_2_enum_none_2_cons:
char /* bool */ temp_b_5;
bar_enum match_arg_6 = a_1;
switch (match_arg_6.code) {
case bar_enum_no_cons: temp_b_5 = 1 /* TRUE */; break;
case bar_enum_yes_cons:
foo_struct dummy_var = match_arg_6.payload.yes_cons;
temp_b_5 = 0 /* FALSE */;
break;
}
if (temp_b_5) {
option_2_enum temp_b_3 = {option_2_enum_some_2_cons,
{some_2_cons: 42.}};
} else {
option_2_enum temp_b_3 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
}
break;
case option_2_enum_some_2_cons:
double x_3 = match_arg_5.payload.some_2_cons;
option_2_enum temp_b_3 = {option_2_enum_some_2_cons,
{some_2_cons: x_3}};
break;
}
if (temp_b_4) {
option_2_enum temp_b_5 = {option_2_enum_some_2_cons, {some_2_cons: 42.}};
temp_b_3 = temp_b_5;
} else {
temp_b_3.code = option_2_enum_none_2_cons;
temp_b_3.payload.none_2_cons = NULL;
array_2_struct temp_b_6;
temp_b_6.content_field = catala_malloc(sizeof(array_2_struct));
temp_b_6.content_field[0] = temp_b_3;
option_2_enum match_arg_7 = catala_handle_exceptions(temp_b_6);
switch (match_arg_7.code) {
case option_2_enum_none_2_cons:
if (0 /* FALSE */) {
option_2_enum temp_b_2 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
} else {
option_2_enum temp_b_2 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
}
break;
case option_2_enum_some_2_cons:
double x_4 = match_arg_7.payload.some_2_cons;
option_2_enum temp_b_2 = {option_2_enum_some_2_cons,
{some_2_cons: x_4}};
break;
}
option_2_enum exception_acc_2 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
option_2_enum exception_current_2;
char exception_conflict_2 = 0;
exception_current_2 = temp_b_3;
if (exception_current_2.code == option_2_enum_some_2_cons) {
if (exception_acc_2.code == option_2_enum_some_2_cons) {
exception_conflict_2 = 1;
} else {
exception_acc_2 = exception_current_2;
}
}
if (exception_conflict_2) {
catala_raise_fatal_error(catala_conflict,
"tests/backends/simple.catala_en", 12, 10, 12, 11);
}
if (exception_acc_2.code == option_2_enum_some_2_cons) {
temp_b_2 = exception_acc_2;
} else {
if (0 /* FALSE */) {
option_2_enum temp_b_6 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
temp_b_2 = temp_b_6;
} else {
temp_b_2.code = option_2_enum_none_2_cons;
temp_b_2.payload.none_2_cons = NULL;
}
}
option_2_enum exception_acc_3 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
option_2_enum exception_current_3;
char exception_conflict_3 = 0;
exception_current_3 = temp_b_2;
if (exception_current_3.code == option_2_enum_some_2_cons) {
if (exception_acc_3.code == option_2_enum_some_2_cons) {
exception_conflict_3 = 1;
} else {
exception_acc_3 = exception_current_3;
}
}
if (exception_conflict_3) {
catala_raise_fatal_error(catala_conflict,
"tests/backends/simple.catala_en", 12, 10, 12, 11);
}
if (exception_acc_3.code == option_2_enum_some_2_cons) {
temp_b_1 = exception_acc_3;
} else {
if (1 /* TRUE */) {
option_2_enum temp_b_7;
option_2_enum temp_b_8;
array_2_struct temp_b_7;
temp_b_7.content_field = catala_malloc(sizeof(array_2_struct));
temp_b_7.content_field[0] = temp_b_2;
option_2_enum match_arg_8 = catala_handle_exceptions(temp_b_7);
switch (match_arg_8.code) {
case option_2_enum_none_2_cons:
if (1 /* TRUE */) {
double temp_b_9;
bar_enum match_arg_3 = a_1;
switch (match_arg_3.code) {
case bar_enum_no_cons: temp_b_9 = 0.; break;
case bar_enum_yes_cons:
foo_struct foo = match_arg_3.payload.yes_cons;
double temp_b_10;
if (foo.x_field) {temp_b_10 = 1.; } else {temp_b_10 = 0.; }
temp_b_9 = (foo.y_field + temp_b_10);
option_2_enum temp_b_8;
array_2_struct temp_b_9;
temp_b_9.content_field = catala_malloc(sizeof(array_2_struct));
option_2_enum match_arg_9 = catala_handle_exceptions(temp_b_9);
switch (match_arg_9.code) {
case option_2_enum_none_2_cons:
if (1 /* TRUE */) {
double temp_b_10;
bar_enum match_arg_10 = a_1;
switch (match_arg_10.code) {
case bar_enum_no_cons: temp_b_10 = 0.; break;
case bar_enum_yes_cons:
foo_struct foo = match_arg_10.payload.yes_cons;
double temp_b_11;
if (foo.x_field) {temp_b_11 = 1.; } else {temp_b_11 = 0.; }
temp_b_10 = (foo.y_field + temp_b_11);
break;
}
option_2_enum temp_b_8 = {option_2_enum_some_2_cons,
{some_2_cons: temp_b_10}};
} else {
option_2_enum temp_b_8 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
}
break;
case option_2_enum_some_2_cons:
double x_5 = match_arg_9.payload.some_2_cons;
option_2_enum temp_b_8 = {option_2_enum_some_2_cons,
{some_2_cons: x_5}};
break;
}
option_2_enum temp_b_11 = {option_2_enum_some_2_cons,
{some_2_cons: temp_b_9}};
temp_b_8 = temp_b_11;
} else {
temp_b_8.code = option_2_enum_none_2_cons;
temp_b_8.payload.none_2_cons = NULL;
}
option_2_enum exception_acc_4 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
option_2_enum exception_current_4;
char exception_conflict_4 = 0;
exception_current_4 = temp_b_8;
if (exception_current_4.code == option_2_enum_some_2_cons) {
if (exception_acc_4.code == option_2_enum_some_2_cons) {
exception_conflict_4 = 1;
} else {
exception_acc_4 = exception_current_4;
array_2_struct temp_b_12;
temp_b_12.content_field = catala_malloc(sizeof(array_2_struct));
temp_b_12.content_field[0] = temp_b_8;
option_2_enum match_arg_11 = catala_handle_exceptions(temp_b_12);
switch (match_arg_11.code) {
case option_2_enum_none_2_cons:
if (0 /* FALSE */) {
option_2_enum temp_b_1 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
} else {
option_2_enum temp_b_1 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
}
break;
case option_2_enum_some_2_cons:
double x_6 = match_arg_11.payload.some_2_cons;
option_2_enum temp_b_1 = {option_2_enum_some_2_cons,
{some_2_cons: x_6}};
break;
}
}
if (exception_conflict_4) {
catala_raise_fatal_error(catala_conflict,
"tests/backends/simple.catala_en", 12, 10, 12, 11);
}
if (exception_acc_4.code == option_2_enum_some_2_cons) {
temp_b_7 = exception_acc_4;
} else {
if (0 /* FALSE */) {
option_2_enum temp_b_12 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
temp_b_7 = temp_b_12;
} else {
temp_b_7.code = option_2_enum_none_2_cons;
temp_b_7.payload.none_2_cons = NULL;
}
option_2_enum temp_b_1 = {option_2_enum_none_2_cons,
{none_2_cons: NULL}};
}
temp_b_1 = temp_b_7;
} else {
temp_b_1.code = option_2_enum_none_2_cons;
temp_b_1.payload.none_2_cons = NULL;
}
break;
case option_2_enum_some_2_cons:
double x_7 = match_arg_8.payload.some_2_cons;
option_2_enum temp_b_1 = {option_2_enum_some_2_cons,
{some_2_cons: x_7}};
break;
}
option_2_enum match_arg_4 = temp_b_1;
switch (match_arg_4.code) {
option_2_enum match_arg_12 = temp_b_1;
switch (match_arg_12.code) {
case option_2_enum_none_2_cons:
catala_raise_fatal_error (catala_no_value,
"tests/backends/simple.catala_en", 12, 10, 12, 11);
break;
case option_2_enum_some_2_cons:
double arg_2 = match_arg_4.payload.some_2_cons;
double arg_2 = match_arg_12.payload.some_2_cons;
temp_b = arg_2;
break;
}
@ -338,54 +350,62 @@ baz_struct baz_func(baz_in_struct baz_in) {
array_3_struct temp_c;
option_3_enum temp_c_1;
option_3_enum temp_c_2;
if (1 /* TRUE */) {
array_3_struct temp_c_3;
temp_c_3.content_field = catala_malloc(sizeof(array_3_struct));
temp_c_3.content_field[0] = b;
temp_c_3.content_field[1] = b;
option_3_enum temp_c_4 = {option_3_enum_some_3_cons,
{some_3_cons: temp_c_3}};
temp_c_2 = temp_c_4;
} else {
temp_c_2.code = option_3_enum_none_3_cons;
temp_c_2.payload.none_3_cons = NULL;
array_4_struct temp_c_3;
temp_c_3.content_field = catala_malloc(sizeof(array_4_struct));
option_3_enum match_arg_13 = catala_handle_exceptions(temp_c_3);
switch (match_arg_13.code) {
case option_3_enum_none_3_cons:
if (1 /* TRUE */) {
array_3_struct temp_c_4;
temp_c_4.content_field = catala_malloc(sizeof(array_3_struct));
temp_c_4.content_field[0] = b;
temp_c_4.content_field[1] = b;
option_3_enum temp_c_2 = {option_3_enum_some_3_cons,
{some_3_cons: temp_c_4}};
} else {
option_3_enum temp_c_2 = {option_3_enum_none_3_cons,
{none_3_cons: NULL}};
}
break;
case option_3_enum_some_3_cons:
array_3_struct x_8 = match_arg_13.payload.some_3_cons;
option_3_enum temp_c_2 = {option_3_enum_some_3_cons,
{some_3_cons: x_8}};
break;
}
option_3_enum exception_acc_5 = {option_3_enum_none_3_cons,
{none_3_cons: NULL}};
option_3_enum exception_current_5;
char exception_conflict_5 = 0;
exception_current_5 = temp_c_2;
if (exception_current_5.code == option_3_enum_some_3_cons) {
if (exception_acc_5.code == option_3_enum_some_3_cons) {
exception_conflict_5 = 1;
} else {
exception_acc_5 = exception_current_5;
}
array_4_struct temp_c_5;
temp_c_5.content_field = catala_malloc(sizeof(array_4_struct));
temp_c_5.content_field[0] = temp_c_2;
option_3_enum match_arg_14 = catala_handle_exceptions(temp_c_5);
switch (match_arg_14.code) {
case option_3_enum_none_3_cons:
if (0 /* FALSE */) {
option_3_enum temp_c_1 = {option_3_enum_none_3_cons,
{none_3_cons: NULL}};
} else {
option_3_enum temp_c_1 = {option_3_enum_none_3_cons,
{none_3_cons: NULL}};
}
break;
case option_3_enum_some_3_cons:
array_3_struct x_9 = match_arg_14.payload.some_3_cons;
option_3_enum temp_c_1 = {option_3_enum_some_3_cons,
{some_3_cons: x_9}};
break;
}
if (exception_conflict_5) {
catala_raise_fatal_error(catala_conflict,
"tests/backends/simple.catala_en", 13, 10, 13, 11);
}
if (exception_acc_5.code == option_3_enum_some_3_cons) {
temp_c_1 = exception_acc_5;
} else {
if (0 /* FALSE */) {
option_3_enum temp_c_5 = {option_3_enum_none_3_cons,
{none_3_cons: NULL}};
temp_c_1 = temp_c_5;
} else {
temp_c_1.code = option_3_enum_none_3_cons;
temp_c_1.payload.none_3_cons = NULL;
}
}
option_3_enum match_arg_5 = temp_c_1;
switch (match_arg_5.code) {
option_3_enum match_arg_15 = temp_c_1;
switch (match_arg_15.code) {
case option_3_enum_none_3_cons:
catala_raise_fatal_error (catala_no_value,
"tests/backends/simple.catala_en", 13, 10, 13, 11);
break;
case option_3_enum_some_3_cons:
array_3_struct arg_3 = match_arg_5.payload.some_3_cons;
array_3_struct arg_3 = match_arg_15.payload.some_3_cons;
temp_c = arg_3;
break;
}

101
tests/backends/python_name_clash.catala_en
View File

@ -91,60 +91,79 @@ class BIn:
def some_name(some_name_in:SomeNameIn):
i = some_name_in.i_in
try:
def temp_o(_:Unit):
def temp_o_1(_:Unit):
return True
def temp_o_2(_:Unit):
return (i + integer_of_string("1"))
return handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
perhaps_none_arg = handle_exceptions([], [])
if perhaps_none_arg is None:
if True:
temp_o = (i + integer_of_string("1"))
else:
temp_o = None
else:
x = perhaps_none_arg
temp_o = x
perhaps_none_arg_1 = handle_exceptions(
[SourcePosition(
filename="tests/backends/python_name_clash.catala_en",
start_line=10, start_column=23,
end_line=10, end_column=28,
law_headings=[]), [], temp_o_1, temp_o_2)
def temp_o_3(_:Unit):
return False
def temp_o_4(_:Unit):
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 Empty:
end_line=10, end_column=28, law_headings=[]
)],
[temp_o]
)
if perhaps_none_arg_1 is None:
if False:
temp_o_1 = None
else:
temp_o_1 = None
else:
x_1 = perhaps_none_arg_1
temp_o_1 = x_1
perhaps_none_arg_2 = temp_o_1
if perhaps_none_arg_2 is None:
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
else:
arg = perhaps_none_arg_2
temp_o_2 = arg
o = temp_o_2
return SomeName(o = o)
def b(b_in:BIn):
try:
def temp_result(_:Unit):
def temp_result_1(_:Unit):
return True
def temp_result_2(_:Unit):
return integer_of_string("1")
return handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
perhaps_none_arg_3 = handle_exceptions([], [])
if perhaps_none_arg_3 is None:
if True:
temp_result = integer_of_string("1")
else:
temp_result = None
else:
x_2 = perhaps_none_arg_3
temp_result = x_2
perhaps_none_arg_4 = handle_exceptions(
[SourcePosition(
filename="tests/backends/python_name_clash.catala_en",
start_line=16, start_column=33,
end_line=16, end_column=34,
law_headings=[]), [], temp_result_1,
temp_result_2)
def temp_result_3(_:Unit):
return False
def temp_result_4(_:Unit):
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 Empty:
end_line=16, end_column=34, law_headings=[]
)],
[temp_result]
)
if perhaps_none_arg_4 is None:
if False:
temp_result_1 = None
else:
temp_result_1 = None
else:
x_3 = perhaps_none_arg_4
temp_result_1 = x_3
perhaps_none_arg_5 = temp_result_1
if perhaps_none_arg_5 is None:
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))
else:
arg_1 = perhaps_none_arg_5
temp_result_2 = arg_1
result = some_name(SomeNameIn(i_in = temp_result_2))
result_1 = SomeName(o = result.o)
if True:
temp_some_name = result_1

8
tests/func/good/closure_conversion.catala_en
View File

@ -24,14 +24,16 @@ $ catala Typecheck --check-invariants
```
```catala-test-inline
$ catala Lcalc --avoid-exceptions -O --closure-conversion
type Eoption = | ENone of unit | ESome of any
$ catala Lcalc -O --closure-conversion
type Eoption = | ENone of unit | ESome of any
type S_in = { x_in: bool; }
type S = { z: integer; }
let topval closure_f1 : (closure_env, integer) → integer =
λ (env: closure_env) (y: integer) →
if (from_closure_env env).0 then y else - y
let scope S (S_in: S_in {x_in: bool}): S {z: integer} =
let get x : bool = S_in.x_in in
let set f : ((closure_env, integer) → integer, closure_env) =
@ -65,7 +67,7 @@ scope S2Use:
```
```catala-test-inline
$ catala Lcalc --avoid-exceptions -O --closure-conversion -s S2Use
$ catala Lcalc -O --closure-conversion -s S2Use
let scope S2Use
(S2Use_in: S2Use_in)
: S2Use {

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

@ -24,7 +24,7 @@ $ catala Typecheck --check-invariants
```
```catala-test-inline
$ catala Lcalc -s S --avoid-exceptions -O --closure-conversion
$ catala Lcalc -s S -O --closure-conversion
let scope S (S_in: S_in {x_in: list of integer}): S {y: integer} =
let get x : list of integer = S_in.x_in in
let set y : integer =
@ -38,12 +38,12 @@ let scope S (S_in: S_in {x_in: list of integer}): S {y: integer} =
```
The next test of closure conversion should give the same results, it checks that
`--avoid-exceptions` and `-O` are correctly implied by `--closure-conversion`
`-O` is correctly implied by `--closure-conversion`
The detection of closures that should not be converted because they are arguments
to reduce or other special operators relies on pattern matching the special
operator and its EAbs argument. However without exceptions on, because the
--avoid-exceptions pass is not optimized and produces more options than needed,
the closures that are arguments to special operators are let-binded with an
lcalc translation pass is not optimized and produces more options than needed,
the closures that are arguments to special operators are let-bound with an
option. This let-binding is reduced by partial evaluation, which is why the test
with optimizations on passes.
@ -53,31 +53,34 @@ let scope S (S_in: S_in {x_in: list of integer}): S {y: integer} =
let get x : list of integer = S_in.x_in in
let set y : integer =
match
(handle_default_opt
[
handle_default_opt
[]
(λ () → true)
(λ () →
ESome
(let weights : list of (integer, integer) =
map (λ (potential_max: integer) →
(potential_max,
let potential_max1 : integer = potential_max in
potential_max1))
x
in
reduce
(λ (x1: (integer, integer)) (x2: (integer, integer)) →
if x1.1 < x2.1 then x1 else x2)
let potential_max : integer = -1 in
(potential_max,
let potential_max1 : integer = potential_max in
potential_max1)
weights).0)
]
(λ () → false)
(λ () → ENone ()))
(match
(handle_exceptions
[
match (handle_exceptions []) with
| ENone →
if true then
ESome
(let weights : list of (integer, integer) =
map (λ (potential_max: integer) →
(potential_max,
let potential_max1 : integer = potential_max in
potential_max1))
x
in
reduce
(λ (x1: (integer, integer)) (x2: (integer, integer)) →
if x1.1 < x2.1 then x1 else x2)
let potential_max : integer = -1 in
(potential_max,
let potential_max1 : integer = potential_max in
potential_max1)
weights).0
else ENone ()
| ESome x → ESome x
])
with
| ENone → if false then ENone () else ENone ()
| ESome x → ESome x)
with
| ENone → error NoValue
| ESome arg → arg

6
tests/func/good/closure_return.catala_en
View File

@ -22,14 +22,16 @@ $ catala Typecheck --check-invariants
```
```catala-test-inline
$ catala Lcalc --avoid-exceptions -O --closure-conversion
type Eoption = | ENone of unit | ESome of any
$ catala Lcalc -O --closure-conversion
type Eoption = | ENone of unit | ESome of any
type S_in = { x_in: bool; }
type S = { f: ((closure_env, integer) → integer, closure_env); }
let topval closure_f1 : (closure_env, integer) → integer =
λ (env: closure_env) (y: integer) →
if (from_closure_env env).0 then y else - y
let scope S
(S_in: S_in {x_in: bool})
: S {f: ((closure_env, integer) → integer, closure_env)}

4
tests/func/good/closure_through_scope.catala_en
View File

@ -30,7 +30,7 @@ $ catala Typecheck --check-invariants
```
```catala-test-inline
$ catala Lcalc -s T --avoid-exceptions -O --closure-conversion
$ catala Lcalc -s T -O --closure-conversion
let scope T (T_in: T_in): T {y: integer} =
let set s : S {f: ((closure_env, integer) → integer, closure_env)} =
{ S f = (closure_s1, to_closure_env ()); }
@ -45,7 +45,7 @@ let scope T (T_in: T_in): T {y: integer} =
```
```catala-test-inline
$ catala Interpret --lcalc -s T --avoid-exceptions -O --closure-conversion
$ catala Interpret --lcalc -s T -O --closure-conversion
┌─[RESULT]─
│ y = -2
└─

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

@ -53,8 +53,9 @@ $ catala Typecheck --check-invariants
```
```catala-test-inline
$ catala Lcalc --avoid-exceptions -O --closure-conversion
type Eoption = | ENone of unit | ESome of any
$ catala Lcalc -O --closure-conversion
type Eoption = | ENone of unit | ESome of any
type Result = {
r: ((closure_env, integer) → integer, closure_env);
q: integer;
@ -69,12 +70,13 @@ type SubFoo2 = {
x1: integer;
y: ((closure_env, integer) → integer, closure_env);
}
type Foo_in = { b_in: ((closure_env, unit) → eoption bool, closure_env); }
type Foo_in = { b_in: ((closure_env, unit) → option bool, closure_env); }
type Foo = { z: integer; }
let topval closure_y1 : (closure_env, integer) → integer =
λ (env: closure_env) (z: integer) →
(from_closure_env env).0 + z
let scope SubFoo1
(SubFoo1_in: SubFoo1_in {x_in: integer})
: SubFoo1 {
@ -87,10 +89,12 @@ let scope SubFoo1
(closure_y1, to_closure_env (x))
in
return { SubFoo1 x = x; y = y; }
let topval closure_y1 : (closure_env, integer) → integer =
λ (env: closure_env) (z: integer) →
let env1 : (integer, integer) = from_closure_env env in
((env1.1 + env1.0 + z))
let scope SubFoo2
(SubFoo2_in: SubFoo2_in {x1_in: integer; x2_in: integer})
: SubFoo2 {
@ -104,29 +108,33 @@ let scope SubFoo2
(closure_y1, to_closure_env (x2, x1))
in
return { SubFoo2 x1 = x1; y = y; }
let topval closure_r2 : (closure_env, integer) → integer =
λ (env: closure_env) (param0: integer) →
let code_and_env : ((closure_env, integer) → integer, closure_env) =
(from_closure_env env).0.y
in
code_and_env.0 code_and_env.1 param0
let topval closure_r1 : (closure_env, integer) → integer =
λ (env: closure_env) (param0: integer) →
let code_and_env : ((closure_env, integer) → integer, closure_env) =
(from_closure_env env).0.y
in
code_and_env.0 code_and_env.1 param0
let scope Foo
(Foo_in:
Foo_in {b_in: ((closure_env, unit) → eoption bool, closure_env)})
(Foo_in: Foo_in {b_in: ((closure_env, unit) → option bool, closure_env)})
: Foo {z: integer}
=
let get b : ((closure_env, unit) → eoption bool, closure_env) =
let get b : ((closure_env, unit) → option bool, closure_env) =
Foo_in.b_in
in
let set b : bool =
match
(handle_default_opt [b.0 b.1 ()] (λ () → true) (λ () → ESome true))
(match (handle_exceptions [b.0 b.1 ()]) with
| ENone → ESome true
| ESome x → ESome x)
with
| ENone → error NoValue
| ESome arg → arg
@ -165,7 +173,7 @@ let scope Foo
```
```catala-test-inline
$ catala Interpret --lcalc -s Foo --avoid-exceptions -O --closure-conversion
$ catala Interpret --lcalc -s Foo -O --closure-conversion
┌─[RESULT]─
│ z = 11
└─

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

@ -27,39 +27,66 @@ end
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=29; start_column=24; end_line=29; end_column=30;
law_headings=["Test modules + inclusions 1"]}|]
([|(fun (_: unit) ->
handle_default [||] ([||]) (fun (_: unit) -> true)
(fun (_: unit) -> money_of_cents_string "100000"))|])
(fun (_: unit) -> false) (fun (_: unit) -> raise Empty))
with 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
match
(match
(handle_exceptions
[|{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"]}|]
([|(match
(handle_exceptions
[|{filename="tests/modules/good/mod_def.catala_en";
start_line=29; start_column=24;
end_line=29; end_column=30;
law_headings=["Test modules + inclusions 1"]}|]
([||]))
with
| Eoption.ENone _ ->
( if true then
(Eoption.ESome (money_of_cents_string "100000")) else
(Eoption.ENone ()))
| Eoption.ESome x_ -> (Eoption.ESome x_))|]))
with
| Eoption.ENone _ ->
( if false then (Eoption.ENone ()) else (Eoption.ENone ()))
| Eoption.ESome x_ -> (Eoption.ESome x_))
with
| Eoption.ENone _ -> (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"]}])))
| Eoption.ESome arg_ -> arg_ in
let e1_: Enum1.t =
try
(handle_default
[|{filename="tests/modules/good/mod_def.catala_en";
start_line=30; start_column=24; end_line=30; end_column=29;
law_headings=["Test modules + inclusions 1"]}|]
([|(fun (_: unit) ->
handle_default [||] ([||]) (fun (_: unit) -> true)
(fun (_: unit) -> Enum1.Maybe ()))|])
(fun (_: unit) -> false) (fun (_: unit) -> raise Empty))
with 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
match
(match
(handle_exceptions
[|{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"]}|]
([|(match
(handle_exceptions
[|{filename="tests/modules/good/mod_def.catala_en";
start_line=30; start_column=24;
end_line=30; end_column=29;
law_headings=["Test modules + inclusions 1"]}|]
([||]))
with
| Eoption.ENone _ ->
( if true then (Eoption.ESome (Enum1.Maybe ())) else
(Eoption.ENone ()))
| Eoption.ESome x_ -> (Eoption.ESome x_))|]))
with
| Eoption.ENone _ ->
( if false then (Eoption.ENone ()) else (Eoption.ENone ()))
| Eoption.ESome x_ -> (Eoption.ESome x_))
with
| Eoption.ENone _ -> (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"]}])))
| Eoption.ESome arg_ -> arg_ in
{S.sr = sr_; S.e1 = e1_}
let half_ : integer -> decimal =

111
tests/monomorphisation/context_var.catala_en Normal file
View File

@ -0,0 +1,111 @@
## Testing monomorphisation on context variables
```catala
declaration scope TestXor:
context output t content boolean
scope TestXor:
definition t equals true
```
```catala-test-inline
$ catala lcalc --monomorphize-types
type option_1 = | None_1 of unit | Some_1 of bool
type TestXor_in = { t_in: unit → option_1[None_1: unit | Some_1: bool]; }
type TestXor = { t: bool; }
type array_1 = {
content: list of option_1[None_1: unit | Some_1: bool];
length: integer;
}
let scope TestXor
(TestXor_in:
TestXor_in {t_in: unit → option_1[None_1: unit | Some_1: bool]})
: TestXor {t: bool}
=
let get t : unit → option_1[None_1: unit | Some_1: bool] =
TestXor_in.t_in
in
let set t : bool =
match
(match
(handle_exceptions { array_1 content = [t ()]; length = 1; })
with
| None_1 →
if true then
Some_1
(match
(match
(handle_exceptions
{ array_1
content =
[
match
(handle_exceptions
{ array_1 content = []; length = 0; })
with
| None_1 →
if true then Some_1 true else None_1 ()
| Some_1 x → Some_1 x
];
length = 1;
})
with
| None_1 → if false then None_1 () else None_1 ()
| Some_1 x → Some_1 x)
with
| None_1 → error NoValue
| Some_1 arg → arg)
else None_1 ()
| Some_1 x → Some_1 x)
with
| None_1 → error NoValue
| Some_1 arg → arg
in
return { TestXor t = t; }
```
```catala
declaration scope TestXor2:
t scope TestXor
output o content boolean
scope TestXor2:
definition o equals t.t
```
```catala-test-inline
$ catala lcalc --monomorphize-types -s TestXor2
let scope TestXor2 (TestXor2_in: TestXor2_in): TestXor2 {o: bool} =
let set t : TestXor {t: bool} =
let result : TestXor = TestXor { TestXor_in t_in = λ () → None_1 (); } in
let result1 : TestXor = { TestXor t = result.t; } in
if true then result1 else result1
in
let set o : bool =
match
(match
(handle_exceptions
{ array_1
content =
[
match
(handle_exceptions { array_1 content = []; length = 0; })
with
| None_1 → if true then Some_1 t.t else None_1 ()
| Some_1 x → Some_1 x
];
length = 1;
})
with
| None_1 → if false then None_1 () else None_1 ()
| Some_1 x → Some_1 x)
with
| None_1 → error NoValue
| Some_1 arg → arg
in
return { TestXor2 o = o; }
```

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

@ -47,44 +47,66 @@ module S = struct
end
module S_in = struct
type t = {a_in: unit -> bool}
type t = {a_in: unit -> (bool) Eoption.t}
end
let s (s_in: S_in.t) : S.t =
let a_: unit -> bool = s_in.S_in.a_in in
let a_: unit -> (bool) Eoption.t = s_in.S_in.a_in in
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_ ())|])
(fun (_: unit) -> true)
(fun (_: unit) ->
try
(handle_default
[|{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=11; start_column=5; end_line=13; end_column=6;
law_headings=["Article"]}|]
([|(fun (_: unit) ->
handle_default [||] ([||]) (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 Empty))
with 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 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
match
(match
(handle_exceptions
[|{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18; end_line=7; end_column=19;
law_headings=["Article"]}|] ([|(a_ ())|]))
with
| Eoption.ENone _ ->
( if true then
(Eoption.ESome
(match
(match
(handle_exceptions
[|{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=7; start_column=18;
end_line=7; end_column=19;
law_headings=["Article"]}|]
([|(match
(handle_exceptions
[|{filename="tests/name_resolution/good/let_in2.catala_en";
start_line=11; start_column=5;
end_line=13; end_column=6;
law_headings=["Article"]}|] ([||]))
with
| Eoption.ENone _ ->
( if true then
(Eoption.ESome (let a_ : bool = false
in
(let a_ : bool = (o_or a_ true)
in
a_))) else (Eoption.ENone ()))
| Eoption.ESome x_ -> (Eoption.ESome x_))|]))
with
| Eoption.ENone _ ->
( if false then (Eoption.ENone ()) else
(Eoption.ENone ()))
| Eoption.ESome x_ -> (Eoption.ESome x_))
with
| Eoption.ENone _ -> (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"]}])))
| Eoption.ESome arg_ -> arg_)) else (Eoption.ENone ()))
| Eoption.ESome x_ -> (Eoption.ESome x_))
with
| Eoption.ENone _ -> (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"]}])))
| Eoption.ESome arg_ -> arg_ in
{S.a = a_}
let () =

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

@ -107,144 +107,164 @@ $ catala test-scope S4
```catala-test-inline
$ catala scalc
let glob1_2 = 44.12
let glob1_1 = 44.12
let glob3_3 (x_3: money) = return to_rat x_3 + 10.
let glob3_1 (x_2: money) = return to_rat x_2 + 10.
let glob4_4 (x_4: money) (y_5: decimal) = return to_rat x_4 * y_5 + 10.
let glob4_2 (x_3: money) (y_4: decimal) = return to_rat x_3 * y_4 + 10.
let glob5_aux_5 =
decl x_7 : decimal;
x_7 = to_rat 2 * 3.;
decl y_8 : decimal;
y_8 = 1000.;
return x_7 * y_8
let glob5_aux_3 =
decl x_6 : decimal;
x_6 = to_rat 2 * 3.;
decl y_7 : decimal;
y_7 = 1000.;
return x_6 * y_7
let glob5_6 = glob5_aux_5 ()
let glob5_5 = glob5_aux_3 ()
let glob2_9 = A {"y": glob1_2 >= 30., "z": 123. * 17.}
let glob2_8 = A {"y": glob1_1 >= 30., "z": 123. * 17.}
let S2_6 (S2_in_10: S2_in) =
decl temp_a_12 : decimal;
try:
decl temp_a_13 : unit → decimal;
let func temp_a_13 (__14 : unit) =
decl temp_a_15 : unit → bool;
let func temp_a_15 (__16 : unit) =
return true;
decl temp_a_17 : unit → decimal;
let func temp_a_17 (__18 : unit) =
return glob3_3 ¤44.00 + 100.;
return handle_default [] temp_a_15 temp_a_17;
decl temp_a_19 : unit → bool;
let func temp_a_19 (__20 : unit) =
return false;
decl temp_a_21 : unit → decimal;
let func temp_a_21 (__22 : unit) =
raise Empty;
temp_a_12 = handle_default [temp_a_13] temp_a_19 temp_a_21
with Empty:
fatal NoValue;
decl a_11 : decimal;
a_11 = temp_a_12;
return S2 {"a": a_11}
let S2_4 (S2_in_9: S2_in) =
decl temp_a_11 : decimal;
decl temp_a_12 : option decimal;
decl temp_a_13 : option decimal;
switch handle_exceptions []:
| ENone __14 →
if true:
temp_a_13 = ESome glob3_1 ¤44.00 + 100.
else:
temp_a_13 = ENone ()
| ESome x_15 →
temp_a_13 = ESome x_15;
switch handle_exceptions [temp_a_13]:
| ENone __16 →
if false:
temp_a_12 = ENone ()
else:
temp_a_12 = ENone ()
| ESome x_17 →
temp_a_12 = ESome x_17;
switch temp_a_12:
| ENone __18 →
fatal NoValue
| ESome arg_19 →
temp_a_11 = arg_19;
decl a_10 : decimal;
a_10 = temp_a_11;
return S2 {"a": a_10}
let S3_7 (S3_in_23: S3_in) =
decl temp_a_25 : decimal;
try:
decl temp_a_26 : unit → decimal;
let func temp_a_26 (__27 : unit) =
decl temp_a_28 : unit → bool;
let func temp_a_28 (__29 : unit) =
return true;
decl temp_a_30 : unit → decimal;
let func temp_a_30 (__31 : unit) =
return 50. + glob4_4 ¤44.00 55.;
return handle_default [] temp_a_28 temp_a_30;
decl temp_a_32 : unit → bool;
let func temp_a_32 (__33 : unit) =
return false;
decl temp_a_34 : unit → decimal;
let func temp_a_34 (__35 : unit) =
raise Empty;
temp_a_25 = handle_default [temp_a_26] temp_a_32 temp_a_34
with Empty:
fatal NoValue;
decl a_24 : decimal;
a_24 = temp_a_25;
return S3 {"a": a_24}
let S3_5 (S3_in_20: S3_in) =
decl temp_a_22 : decimal;
decl temp_a_23 : option decimal;
decl temp_a_24 : option decimal;
switch handle_exceptions []:
| ENone __25 →
if true:
temp_a_24 = ESome 50. + glob4_2 ¤44.00 55.
else:
temp_a_24 = ENone ()
| ESome x_26 →
temp_a_24 = ESome x_26;
switch handle_exceptions [temp_a_24]:
| ENone __27 →
if false:
temp_a_23 = ENone ()
else:
temp_a_23 = ENone ()
| ESome x_28 →
temp_a_23 = ESome x_28;
switch temp_a_23:
| ENone __29 →
fatal NoValue
| ESome arg_30 →
temp_a_22 = arg_30;
decl a_21 : decimal;
a_21 = temp_a_22;
return S3 {"a": a_21}
let S4_8 (S4_in_36: S4_in) =
decl temp_a_38 : decimal;
try:
decl temp_a_39 : unit → decimal;
let func temp_a_39 (__40 : unit) =
decl temp_a_41 : unit → bool;
let func temp_a_41 (__42 : unit) =
return true;
decl temp_a_43 : unit → decimal;
let func temp_a_43 (__44 : unit) =
return glob5_6 + 1.;
return handle_default [] temp_a_41 temp_a_43;
decl temp_a_45 : unit → bool;
let func temp_a_45 (__46 : unit) =
return false;
decl temp_a_47 : unit → decimal;
let func temp_a_47 (__48 : unit) =
raise Empty;
temp_a_38 = handle_default [temp_a_39] temp_a_45 temp_a_47
with Empty:
fatal NoValue;
decl a_37 : decimal;
a_37 = temp_a_38;
return S4 {"a": a_37}
let S4_6 (S4_in_31: S4_in) =
decl temp_a_33 : decimal;
decl temp_a_34 : option decimal;
decl temp_a_35 : option decimal;
switch handle_exceptions []:
| ENone __36 →
if true:
temp_a_35 = ESome glob5_5 + 1.
else:
temp_a_35 = ENone ()
| ESome x_37 →
temp_a_35 = ESome x_37;
switch handle_exceptions [temp_a_35]:
| ENone __38 →
if false:
temp_a_34 = ENone ()
else:
temp_a_34 = ENone ()
| ESome x_39 →
temp_a_34 = ESome x_39;
switch temp_a_34:
| ENone __40 →
fatal NoValue
| ESome arg_41 →
temp_a_33 = arg_41;
decl a_32 : decimal;
a_32 = temp_a_33;
return S4 {"a": a_32}
let S_9 (S_in_49: S_in) =
decl temp_a_63 : decimal;
try:
decl temp_a_64 : unit → decimal;
let func temp_a_64 (__65 : unit) =
decl temp_a_66 : unit → bool;
let func temp_a_66 (__67 : unit) =
return true;
decl temp_a_68 : unit → decimal;
let func temp_a_68 (__69 : unit) =
return glob1_2 * glob1_2;
return handle_default [] temp_a_66 temp_a_68;
decl temp_a_70 : unit → bool;
let func temp_a_70 (__71 : unit) =
return false;
decl temp_a_72 : unit → decimal;
let func temp_a_72 (__73 : unit) =
raise Empty;
temp_a_63 = handle_default [temp_a_64] temp_a_70 temp_a_72
with Empty:
fatal NoValue;
decl a_50 : decimal;
a_50 = temp_a_63;
decl temp_b_52 : A {y: bool; z: decimal};
try:
decl temp_b_53 : unit → A {y: bool; z: decimal};
let func temp_b_53 (__54 : unit) =
decl temp_b_55 : unit → bool;
let func temp_b_55 (__56 : unit) =
return true;
decl temp_b_57 : unit → A {y: bool; z: decimal};
let func temp_b_57 (__58 : unit) =
return glob2_9;
return handle_default [] temp_b_55 temp_b_57;
decl temp_b_59 : unit → bool;
let func temp_b_59 (__60 : unit) =
return false;
decl temp_b_61 : unit → A {y: bool; z: decimal};
let func temp_b_61 (__62 : unit) =
raise Empty;
temp_b_52 = handle_default [temp_b_53] temp_b_59 temp_b_61
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}
let S_7 (S_in_42: S_in) =
decl temp_a_54 : decimal;
decl temp_a_55 : option decimal;
decl temp_a_56 : option decimal;
switch handle_exceptions []:
| ENone __57 →
if true:
temp_a_56 = ESome glob1_1 * glob1_1
else:
temp_a_56 = ENone ()
| ESome x_58 →
temp_a_56 = ESome x_58;
switch handle_exceptions [temp_a_56]:
| ENone __59 →
if false:
temp_a_55 = ENone ()
else:
temp_a_55 = ENone ()
| ESome x_60 →
temp_a_55 = ESome x_60;
switch temp_a_55:
| ENone __61 →
fatal NoValue
| ESome arg_62 →
temp_a_54 = arg_62;
decl a_43 : decimal;
a_43 = temp_a_54;
decl temp_b_45 : A {y: bool; z: decimal};
decl temp_b_46 : option A {y: bool; z: decimal};
decl temp_b_47 : option A {y: bool; z: decimal};
switch handle_exceptions []:
| ENone __48 →
if true:
temp_b_47 = ESome glob2_8
else:
temp_b_47 = ENone ()
| ESome x_49 →
temp_b_47 = ESome x_49;
switch handle_exceptions [temp_b_47]:
| ENone __50 →
if false:
temp_b_46 = ENone ()
else:
temp_b_46 = ENone ()
| ESome x_51 →
temp_b_46 = ESome x_51;
switch temp_b_46:
| ENone __52 →
fatal NoValue
| ESome arg_53 →
temp_b_45 = arg_53;
decl b_44 : A {y: bool; z: decimal};
b_44 = temp_b_45;
return S {"a": a_43, "b": b_44}
```
```catala-test-inline
@ -423,155 +443,205 @@ glob2 = (
decimal_of_string("30.")),
z = (decimal_of_string("123.") *
decimal_of_string("17.")))
)
)
def s2(s2_in:S2In):
try:
def temp_a(_:Unit):
def temp_a_1(_:Unit):
return True
def temp_a_2(_:Unit):
return (glob3(money_of_cents_string("4400")) +
decimal_of_string("100."))
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
perhaps_none_arg = handle_exceptions([], [])
if perhaps_none_arg is None:
if True:
temp_a = (glob3(money_of_cents_string("4400")) +
decimal_of_string("100."))
else:
temp_a = None
else:
x_3 = perhaps_none_arg
temp_a = x_3
perhaps_none_arg_1 = handle_exceptions(
[SourcePosition(
filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=53, start_column=24,
end_line=53, end_column=43,
law_headings=["Test toplevel function defs"]), [],
temp_a_1, temp_a_2)
def temp_a_3(_:Unit):
return False
def temp_a_4(_:Unit):
raise Empty
temp_a_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=50, start_column=10,
end_line=50, end_column=11,
law_headings=["Test toplevel function defs"]), [temp_a],
temp_a_3, temp_a_4)
except Empty:
law_headings=["Test toplevel function defs"]
)],
[temp_a]
)
if perhaps_none_arg_1 is None:
if False:
temp_a_1 = None
else:
temp_a_1 = None
else:
x_4 = perhaps_none_arg_1
temp_a_1 = x_4
perhaps_none_arg_2 = temp_a_1
if perhaps_none_arg_2 is None:
raise NoValue(SourcePosition(
filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=50, start_column=10,
end_line=50, end_column=11,
law_headings=["Test toplevel function defs"]))
a = temp_a_5
else:
arg = perhaps_none_arg_2
temp_a_2 = arg
a = temp_a_2
return S2(a = a)
def s3(s3_in:S3In):
try:
def temp_a_6(_:Unit):
def temp_a_7(_:Unit):
return True
def temp_a_8(_:Unit):
return (decimal_of_string("50.") +
glob4(money_of_cents_string("4400"),
decimal_of_string("55.")))
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
perhaps_none_arg_3 = handle_exceptions([], [])
if perhaps_none_arg_3 is None:
if True:
temp_a_3 = (decimal_of_string("50.") +
glob4(money_of_cents_string("4400"),
decimal_of_string("55.")))
else:
temp_a_3 = None
else:
x_5 = perhaps_none_arg_3
temp_a_3 = x_5
perhaps_none_arg_4 = handle_exceptions(
[SourcePosition(
filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=74, start_column=24,
end_line=74, end_column=47,
law_headings=["Test function def with two args"]), [],
temp_a_7, temp_a_8)
def temp_a_9(_:Unit):
return False
def temp_a_10(_:Unit):
raise Empty
temp_a_11 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=71, start_column=10,
end_line=71, end_column=11,
law_headings=["Test function def with two args"]), [temp_a_6],
temp_a_9, temp_a_10)
except Empty:
law_headings=["Test function def with two args"]
)],
[temp_a_3]
)
if perhaps_none_arg_4 is None:
if False:
temp_a_4 = None
else:
temp_a_4 = None
else:
x_6 = perhaps_none_arg_4
temp_a_4 = x_6
perhaps_none_arg_5 = temp_a_4
if perhaps_none_arg_5 is None:
raise NoValue(SourcePosition(
filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=71, start_column=10,
end_line=71, end_column=11,
law_headings=["Test function def with two args"]))
a_1 = temp_a_11
else:
arg_1 = perhaps_none_arg_5
temp_a_5 = arg_1
a_1 = temp_a_5
return S3(a = a_1)
def s4(s4_in:S4In):
try:
def temp_a_12(_:Unit):
def temp_a_13(_:Unit):
return True
def temp_a_14(_:Unit):
return (glob5 + decimal_of_string("1."))
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
perhaps_none_arg_6 = handle_exceptions([], [])
if perhaps_none_arg_6 is None:
if True:
temp_a_6 = (glob5 + decimal_of_string("1."))
else:
temp_a_6 = None
else:
x_7 = perhaps_none_arg_6
temp_a_6 = x_7
perhaps_none_arg_7 = handle_exceptions(
[SourcePosition(
filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=98, start_column=24,
end_line=98, end_column=34,
law_headings=["Test inline defs in toplevel defs"]), [],
temp_a_13, temp_a_14)
def temp_a_15(_:Unit):
return False
def temp_a_16(_:Unit):
raise Empty
temp_a_17 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=95, start_column=10,
end_line=95, end_column=11,
law_headings=["Test inline defs in toplevel defs"]), [temp_a_12],
temp_a_15, temp_a_16)
except Empty:
law_headings=["Test inline defs in toplevel defs"]
)],
[temp_a_6]
)
if perhaps_none_arg_7 is None:
if False:
temp_a_7 = None
else:
temp_a_7 = None
else:
x_8 = perhaps_none_arg_7
temp_a_7 = x_8
perhaps_none_arg_8 = temp_a_7
if perhaps_none_arg_8 is None:
raise NoValue(SourcePosition(
filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=95, start_column=10,
end_line=95, end_column=11,
law_headings=["Test inline defs in toplevel defs"]))
a_2 = temp_a_17
else:
arg_2 = perhaps_none_arg_8
temp_a_8 = arg_2
a_2 = temp_a_8
return S4(a = a_2)
def s(s_in:SIn):
try:
def temp_a_18(_:Unit):
def temp_a_19(_:Unit):
return True
def temp_a_20(_:Unit):
return (glob1 * glob1)
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=18, start_column=24,
end_line=18, end_column=37,
law_headings=["Test basic toplevel values defs"]), [],
temp_a_19, temp_a_20)
def temp_a_21(_:Unit):
return False
def temp_a_22(_:Unit):
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 Empty:
perhaps_none_arg_9 = handle_exceptions([], [])
if perhaps_none_arg_9 is None:
if True:
temp_a_9 = (glob1 * glob1)
else:
temp_a_9 = None
else:
x_9 = perhaps_none_arg_9
temp_a_9 = x_9
perhaps_none_arg_10 = handle_exceptions(
[SourcePosition(
filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=18, start_column=24,
end_line=18, end_column=37,
law_headings=["Test basic toplevel values defs"]
)],
[temp_a_9]
)
if perhaps_none_arg_10 is None:
if False:
temp_a_10 = None
else:
temp_a_10 = None
else:
x_10 = perhaps_none_arg_10
temp_a_10 = x_10
perhaps_none_arg_11 = temp_a_10
if perhaps_none_arg_11 is None:
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):
def temp_b_1(_:Unit):
return True
def temp_b_2(_:Unit):
return glob2
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=19, start_column=24,
end_line=19, end_column=29,
law_headings=["Test basic toplevel values defs"]), [],
temp_b_1, temp_b_2)
def temp_b_3(_:Unit):
return False
def temp_b_4(_:Unit):
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 Empty:
else:
arg_3 = perhaps_none_arg_11
temp_a_11 = arg_3
a_3 = temp_a_11
perhaps_none_arg_12 = handle_exceptions([], [])
if perhaps_none_arg_12 is None:
if True:
temp_b = glob2
else:
temp_b = None
else:
x_11 = perhaps_none_arg_12
temp_b = x_11
perhaps_none_arg_13 = handle_exceptions(
[SourcePosition(
filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=19, start_column=24,
end_line=19, end_column=29,
law_headings=["Test basic toplevel values defs"]
)],
[temp_b]
)
if perhaps_none_arg_13 is None:
if False:
temp_b_1 = None
else:
temp_b_1 = None
else:
x_12 = perhaps_none_arg_13
temp_b_1 = x_12
perhaps_none_arg_14 = temp_b_1
if perhaps_none_arg_14 is None:
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
else:
arg_4 = perhaps_none_arg_14
temp_b_2 = arg_4
b = temp_b_2
return S(a = a_3, b = b)
```

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

@ -39,11 +39,11 @@ $ catala Scalc -s Foo2 -O -t
│ 5 │ output bar content integer
│ │ ‾‾‾
└─ Test
let Foo2_3 (Foo2_in_2: Foo2_in) =
decl temp_bar_4 : integer;
let Foo2_1 (Foo2_in_1: Foo2_in) =
decl temp_bar_3 : integer;
fatal NoValue;
decl bar_3 : integer;
bar_3 = temp_bar_4;
return Foo2 {"bar": bar_3}
decl bar_2 : integer;
bar_2 = temp_bar_3;
return Foo2 {"bar": bar_2}
```

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

@ -68,7 +68,7 @@ $ catala interpret -s RentComputation --debug
```
```catala-test-inline
$ catala Interpret --lcalc -s RentComputation --avoid-exceptions --optimize --debug
$ catala Interpret --lcalc -s RentComputation --optimize --debug
[DEBUG] = INIT =
[DEBUG] = SURFACE =
[DEBUG] Parsing "tests/scope/good/scope_call4.catala_en"

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

@ -24,12 +24,20 @@ $ catala Typecheck --check-invariants
$ catala Lcalc -s Foo
let scope Foo (Foo_in: Foo_in): Foo {bar: integer} =
let set bar : integer =
try
handle_default
[λ () → handle_default [] (λ () → true) (λ () → 0)]
(λ () → false)
(λ () → raise Empty)
with Empty -> error NoValue
match
(match
(handle_exceptions
[
match (handle_exceptions []) with
| ENone → if true then ESome 0 else ENone ()
| ESome x → ESome x
])
with
| ENone → if false then ENone () else ENone ()
| ESome x → ESome x)
with
| ENone → error NoValue
| ESome arg → arg
in
return { Foo bar = bar; }
```