mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-07 10:35:56 +03:00
Remove the "with-exceptions" backend from the compiler (#641)
This commit is contained in:
commit
a7eec8fd72
2
Makefile
2
Makefile
@ -217,7 +217,7 @@ tests: test
|
|||||||
TEST_FLAGS_LIST = ""\
|
TEST_FLAGS_LIST = ""\
|
||||||
-O \
|
-O \
|
||||||
--lcalc \
|
--lcalc \
|
||||||
--lcalc,--avoid-exceptions,-O
|
--lcalc,--closure-conversion,-O
|
||||||
|
|
||||||
# Does not include running dune (to avoid duplication when run among bigger rules)
|
# Does not include running dune (to avoid duplication when run among bigger rules)
|
||||||
testsuite-base: .FORCE
|
testsuite-base: .FORCE
|
||||||
|
@ -75,8 +75,8 @@ module Cli = struct
|
|||||||
tests. Comma-separated list. A subset may also be applied to the \
|
tests. Comma-separated list. A subset may also be applied to the \
|
||||||
compilation of modules, as needed.\n\
|
compilation of modules, as needed.\n\
|
||||||
WARNING: flag shortcuts are not allowed here (i.e. don't use \
|
WARNING: flag shortcuts are not allowed here (i.e. don't use \
|
||||||
non-ambiguous prefixes such as $(b,--avoid-ex) for \
|
non-ambiguous prefixes such as $(b,--closure) for \
|
||||||
$(b,--avoid-exceptions))\n\
|
$(b,--closure-conversion))\n\
|
||||||
NOTE: if this is set, all inline tests that are $(i,not) \
|
NOTE: if this is set, all inline tests that are $(i,not) \
|
||||||
$(b,catala test-scope) are skipped to avoid redundant testing.")
|
$(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 =
|
let catala_flags_ocaml =
|
||||||
List.filter
|
List.filter
|
||||||
(function
|
(function
|
||||||
| "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" ->
|
| "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false)
|
||||||
true
|
|
||||||
| _ -> false)
|
|
||||||
test_flags
|
test_flags
|
||||||
in
|
in
|
||||||
let catala_flags_python =
|
let catala_flags_python =
|
||||||
List.filter
|
List.filter
|
||||||
(function
|
(function
|
||||||
| "--avoid-exceptions" | "-O" | "--optimize" | "--closure-conversion" ->
|
| "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false)
|
||||||
true
|
|
||||||
| _ -> false)
|
|
||||||
test_flags
|
test_flags
|
||||||
in
|
in
|
||||||
let ocaml_flags = Lazy.force Poll.ocaml_include_flags in
|
let ocaml_flags = Lazy.force Poll.ocaml_include_flags in
|
||||||
|
@ -69,16 +69,68 @@ let has_command cmd =
|
|||||||
let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in
|
let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in
|
||||||
Sys.command check_cmd = 0
|
Sys.command check_cmd = 0
|
||||||
|
|
||||||
let longuest_common_prefix_length s1 s2 =
|
type 'a diff = Eq of 'a | Subs of 'a * 'a | Del of 'a | Add of 'a
|
||||||
let len = min (String.length s1) (String.length s2) in
|
|
||||||
let rec aux i =
|
let colordiff_str s1 s2 =
|
||||||
if i >= len then i
|
let split_re =
|
||||||
else
|
Re.(compile (alt [set "=()[]{};-,"; rep1 space; rep1 digit]))
|
||||||
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
|
|
||||||
in
|
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 diff_command =
|
||||||
let has_gnu_diff () =
|
let has_gnu_diff () =
|
||||||
@ -139,10 +191,8 @@ let diff_command =
|
|||||||
else Format.fprintf ppf "%s@{<blue>│@}@{<red>%s@}" l r
|
else Format.fprintf ppf "%s@{<blue>│@}@{<red>%s@}" l r
|
||||||
| '<' -> Format.fprintf ppf "%s@{<blue>│@}@{<red>-@}" l
|
| '<' -> Format.fprintf ppf "%s@{<blue>│@}@{<red>-@}" l
|
||||||
| '|' ->
|
| '|' ->
|
||||||
let w = longuest_common_prefix_length (" " ^ l) r in
|
let ppleft, ppright = colordiff_str l r in
|
||||||
Format.fprintf ppf "%s@{<blue>│@}%s@{<red>%s@}" l
|
Format.fprintf ppf "%a@{<blue>│@}%a" ppleft () ppright ()
|
||||||
(String.sub r 0 w)
|
|
||||||
(String.sub r w (String.length r - w))
|
|
||||||
| _ -> Format.pp_print_string ppf li))
|
| _ -> Format.pp_print_string ppf li))
|
||||||
ppf )
|
ppf )
|
||||||
| Some cmd_opt | (None as cmd_opt) ->
|
| Some cmd_opt | (None as cmd_opt) ->
|
||||||
@ -287,7 +337,7 @@ let print_box tcolor ppf title (pcontents : box -> unit) =
|
|||||||
(fun ppf ->
|
(fun ppf ->
|
||||||
Format.pp_print_tab ppf ();
|
Format.pp_print_tab ppf ();
|
||||||
Format.fprintf ppf "%t┃@}@," tcolor)
|
Format.fprintf ppf "%t┃@}@," tcolor)
|
||||||
ppf ("%t@<1>%s@} " ^^ fmt) tcolor "┃");
|
ppf ("%t@<1>%s@} " ^^ fmt) tcolor "┃");
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
pcontents box;
|
pcontents box;
|
||||||
|
@ -334,13 +334,6 @@ module Flags = struct
|
|||||||
~env:(Cmd.Env.info "CATALA_OPTIMIZE")
|
~env:(Cmd.Env.info "CATALA_OPTIMIZE")
|
||||||
~doc:"Run compiler optimizations."
|
~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 =
|
let keep_special_ops =
|
||||||
value
|
value
|
||||||
& flag
|
& flag
|
||||||
@ -381,9 +374,7 @@ module Flags = struct
|
|||||||
value
|
value
|
||||||
& flag
|
& flag
|
||||||
& info ["closure-conversion"]
|
& info ["closure-conversion"]
|
||||||
~doc:
|
~doc:"Performs closure conversion on the lambda calculus."
|
||||||
"Performs closure conversion on the lambda calculus. Implies \
|
|
||||||
$(b,--avoid-exceptions)."
|
|
||||||
|
|
||||||
let disable_counterexamples =
|
let disable_counterexamples =
|
||||||
value
|
value
|
||||||
|
@ -55,7 +55,6 @@ module Flags : sig
|
|||||||
val ex_variable : string Term.t
|
val ex_variable : string Term.t
|
||||||
val output : raw_file option Term.t
|
val output : raw_file option Term.t
|
||||||
val optimize : bool Term.t
|
val optimize : bool Term.t
|
||||||
val avoid_exceptions : bool Term.t
|
|
||||||
val closure_conversion : bool Term.t
|
val closure_conversion : bool Term.t
|
||||||
val keep_special_ops : bool Term.t
|
val keep_special_ops : bool Term.t
|
||||||
val monomorphize_types : bool Term.t
|
val monomorphize_types : bool Term.t
|
||||||
|
@ -36,22 +36,16 @@ module Flags : sig
|
|||||||
type nonrec t = private t
|
type nonrec t = private t
|
||||||
|
|
||||||
val pass :
|
val pass :
|
||||||
(t -> 'a) ->
|
(t -> 'a) -> closure_conversion:bool -> monomorphize_types:bool -> 'a
|
||||||
avoid_exceptions:bool ->
|
|
||||||
closure_conversion:bool ->
|
|
||||||
monomorphize_types:bool ->
|
|
||||||
'a
|
|
||||||
|
|
||||||
val of_t : int -> t
|
val of_t : int -> t
|
||||||
end = struct
|
end = struct
|
||||||
type nonrec t = t
|
type nonrec t = t
|
||||||
|
|
||||||
let pass k ~avoid_exceptions ~closure_conversion ~monomorphize_types =
|
let pass k ~closure_conversion ~monomorphize_types =
|
||||||
let avoid_exceptions = avoid_exceptions || closure_conversion in
|
|
||||||
(* Should not affect the call convention or actual interfaces: include,
|
(* Should not affect the call convention or actual interfaces: include,
|
||||||
optimize, check_invariants, typed *)
|
optimize, check_invariants, typed *)
|
||||||
!(avoid_exceptions : bool)
|
!(closure_conversion : bool)
|
||||||
% !(closure_conversion : bool)
|
|
||||||
% !(monomorphize_types : bool)
|
% !(monomorphize_types : bool)
|
||||||
% (* The following may not affect the call convention, but we want it set in
|
% (* The following may not affect the call convention, but we want it set in
|
||||||
an homogeneous way *)
|
an homogeneous way *)
|
||||||
|
@ -58,12 +58,7 @@ val map :
|
|||||||
first argument is expected to be a [Foo.Map.fold] function. The result is
|
first argument is expected to be a [Foo.Map.fold] function. The result is
|
||||||
independent of the ordering of the map. *)
|
independent of the ordering of the map. *)
|
||||||
|
|
||||||
val finalise :
|
val finalise : t -> closure_conversion:bool -> monomorphize_types:bool -> full
|
||||||
t ->
|
|
||||||
avoid_exceptions:bool ->
|
|
||||||
closure_conversion:bool ->
|
|
||||||
monomorphize_types:bool ->
|
|
||||||
full
|
|
||||||
(** Turns a raw interface hash into a full hash, ready for printing *)
|
(** Turns a raw interface hash into a full hash, ready for printing *)
|
||||||
|
|
||||||
val to_string : full -> string
|
val to_string : full -> string
|
||||||
|
@ -111,8 +111,7 @@ let print_time_marker =
|
|||||||
let old_time = !time in
|
let old_time = !time in
|
||||||
time := new_time;
|
time := new_time;
|
||||||
let delta = (new_time -. old_time) *. 1000. in
|
let delta = (new_time -. old_time) *. 1000. in
|
||||||
if delta > 50. then
|
if delta > 50. then Format.fprintf ppf " @{<bold;black>%.0fms@}" delta
|
||||||
Format.fprintf ppf "@{<bold;black>[TIME] %.0fms@}@\n" delta
|
|
||||||
|
|
||||||
let pp_marker ?extra_label target ppf =
|
let pp_marker ?extra_label target ppf =
|
||||||
let open Ocolor_types in
|
let open Ocolor_types in
|
||||||
@ -129,10 +128,10 @@ let pp_marker ?extra_label target ppf =
|
|||||||
| None -> str
|
| None -> str
|
||||||
| Some lbl -> Printf.sprintf "%s %s" str lbl
|
| Some lbl -> Printf.sprintf "%s %s" str lbl
|
||||||
in
|
in
|
||||||
if target = Debug then print_time_marker ppf ();
|
|
||||||
Format.pp_open_stag ppf (Ocolor_format.Ocolor_styles_tag tags);
|
Format.pp_open_stag ppf (Ocolor_format.Ocolor_styles_tag tags);
|
||||||
Format.pp_print_string ppf str;
|
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}*)
|
(**{2 Printers}*)
|
||||||
|
|
||||||
|
@ -227,7 +227,6 @@ module Passes = struct
|
|||||||
~optimize
|
~optimize
|
||||||
~check_invariants
|
~check_invariants
|
||||||
~(typed : ty mark)
|
~(typed : ty mark)
|
||||||
~avoid_exceptions
|
|
||||||
~closure_conversion
|
~closure_conversion
|
||||||
~monomorphize_types :
|
~monomorphize_types :
|
||||||
typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
||||||
@ -235,23 +234,11 @@ module Passes = struct
|
|||||||
dcalc options ~includes ~optimize ~check_invariants ~typed
|
dcalc options ~includes ~optimize ~check_invariants ~typed
|
||||||
in
|
in
|
||||||
debug_pass_name "lcalc";
|
debug_pass_name "lcalc";
|
||||||
let avoid_exceptions = avoid_exceptions || closure_conversion in
|
|
||||||
(* --closure-conversion implies --avoid-exceptions *)
|
|
||||||
let prg =
|
let prg =
|
||||||
if avoid_exceptions && options.trace then
|
match typed with
|
||||||
Message.warning
|
| Untyped _ -> Lcalc.From_dcalc.translate_program prg
|
||||||
"It is discouraged to use option @{<yellow>--avoid-exceptions@} if \
|
| Typed _ -> Lcalc.From_dcalc.translate_program prg
|
||||||
you@ also@ need@ @{<yellow>--trace@},@ the@ resulting@ trace@ may@ \
|
| Custom _ -> invalid_arg "Driver.Passes.lcalc"
|
||||||
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"
|
|
||||||
in
|
in
|
||||||
let prg =
|
let prg =
|
||||||
if optimize then begin
|
if optimize then begin
|
||||||
@ -295,7 +282,6 @@ module Passes = struct
|
|||||||
~includes
|
~includes
|
||||||
~optimize
|
~optimize
|
||||||
~check_invariants
|
~check_invariants
|
||||||
~avoid_exceptions
|
|
||||||
~closure_conversion
|
~closure_conversion
|
||||||
~keep_special_ops
|
~keep_special_ops
|
||||||
~dead_value_assignment
|
~dead_value_assignment
|
||||||
@ -304,7 +290,7 @@ module Passes = struct
|
|||||||
Scalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
Scalc.Ast.program * Scopelang.Dependency.TVertex.t list =
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed
|
lcalc options ~includes ~optimize ~check_invariants ~typed:Expr.typed
|
||||||
~avoid_exceptions ~closure_conversion ~monomorphize_types
|
~closure_conversion ~monomorphize_types
|
||||||
in
|
in
|
||||||
debug_pass_name "scalc";
|
debug_pass_name "scalc";
|
||||||
( Scalc.From_lcalc.translate_program
|
( Scalc.From_lcalc.translate_program
|
||||||
@ -710,10 +696,7 @@ module Commands = struct
|
|||||||
Passes.dcalc options ~includes ~optimize ~check_invariants ~typed
|
Passes.dcalc options ~includes ~optimize ~check_invariants ~typed
|
||||||
in
|
in
|
||||||
Interpreter.load_runtime_modules
|
Interpreter.load_runtime_modules
|
||||||
~hashf:
|
~hashf:Hash.(finalise ~closure_conversion:false ~monomorphize_types:false)
|
||||||
Hash.(
|
|
||||||
finalise ~avoid_exceptions:false ~closure_conversion:false
|
|
||||||
~monomorphize_types:false)
|
|
||||||
prg;
|
prg;
|
||||||
print_interpretation_results options Interpreter.interpret_program_dcalc prg
|
print_interpretation_results options Interpreter.interpret_program_dcalc prg
|
||||||
(get_scopeopt_uid prg.decl_ctx ex_scope_opt)
|
(get_scopeopt_uid prg.decl_ctx ex_scope_opt)
|
||||||
@ -725,13 +708,12 @@ module Commands = struct
|
|||||||
output
|
output
|
||||||
optimize
|
optimize
|
||||||
check_invariants
|
check_invariants
|
||||||
avoid_exceptions
|
|
||||||
closure_conversion
|
closure_conversion
|
||||||
monomorphize_types
|
monomorphize_types
|
||||||
ex_scope_opt =
|
ex_scope_opt =
|
||||||
let prg, _ =
|
let prg, _ =
|
||||||
Passes.lcalc options ~includes ~optimize ~check_invariants
|
Passes.lcalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~closure_conversion ~typed ~monomorphize_types
|
~closure_conversion ~typed ~monomorphize_types
|
||||||
in
|
in
|
||||||
let _output_file, with_output = get_output_format options output in
|
let _output_file, with_output = get_output_format options output in
|
||||||
with_output
|
with_output
|
||||||
@ -764,14 +746,12 @@ module Commands = struct
|
|||||||
$ Cli.Flags.output
|
$ Cli.Flags.output
|
||||||
$ Cli.Flags.optimize
|
$ Cli.Flags.optimize
|
||||||
$ Cli.Flags.check_invariants
|
$ Cli.Flags.check_invariants
|
||||||
$ Cli.Flags.avoid_exceptions
|
|
||||||
$ Cli.Flags.closure_conversion
|
$ Cli.Flags.closure_conversion
|
||||||
$ Cli.Flags.monomorphize_types
|
$ Cli.Flags.monomorphize_types
|
||||||
$ Cli.Flags.ex_scope_opt)
|
$ Cli.Flags.ex_scope_opt)
|
||||||
|
|
||||||
let interpret_lcalc
|
let interpret_lcalc
|
||||||
typed
|
typed
|
||||||
avoid_exceptions
|
|
||||||
closure_conversion
|
closure_conversion
|
||||||
monomorphize_types
|
monomorphize_types
|
||||||
options
|
options
|
||||||
@ -781,32 +761,27 @@ module Commands = struct
|
|||||||
ex_scope_opt =
|
ex_scope_opt =
|
||||||
let prg, _ =
|
let prg, _ =
|
||||||
Passes.lcalc options ~includes ~optimize ~check_invariants
|
Passes.lcalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~closure_conversion ~monomorphize_types ~typed
|
~closure_conversion ~monomorphize_types ~typed
|
||||||
in
|
in
|
||||||
Interpreter.load_runtime_modules
|
Interpreter.load_runtime_modules
|
||||||
~hashf:
|
~hashf:(Hash.finalise ~closure_conversion ~monomorphize_types)
|
||||||
(Hash.finalise ~avoid_exceptions ~closure_conversion ~monomorphize_types)
|
|
||||||
prg;
|
prg;
|
||||||
print_interpretation_results options Interpreter.interpret_program_lcalc prg
|
print_interpretation_results options Interpreter.interpret_program_lcalc prg
|
||||||
(get_scopeopt_uid prg.decl_ctx ex_scope_opt)
|
(get_scopeopt_uid prg.decl_ctx ex_scope_opt)
|
||||||
|
|
||||||
let interpret_cmd =
|
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 not lcalc then
|
||||||
if avoid_exceptions || closure_conversion || monomorphize_types then
|
if closure_conversion || monomorphize_types then
|
||||||
Message.error
|
Message.error
|
||||||
"The flags @{<bold>--avoid-exceptions@}, \
|
"The flags @{<bold>--closure-conversion@} and \
|
||||||
@{<bold>--closure-conversion@} and @{<bold>--monomorphize-types@} \
|
@{<bold>--monomorphize-types@} only make sense with the \
|
||||||
only make sense with the @{<bold>--lcalc@} option"
|
@{<bold>--lcalc@} option"
|
||||||
else if no_typing then interpret_dcalc Expr.untyped
|
else if no_typing then interpret_dcalc Expr.untyped
|
||||||
else interpret_dcalc Expr.typed
|
else interpret_dcalc Expr.typed
|
||||||
else if no_typing then
|
else if no_typing then
|
||||||
interpret_lcalc Expr.untyped avoid_exceptions closure_conversion
|
interpret_lcalc Expr.untyped closure_conversion monomorphize_types
|
||||||
monomorphize_types
|
else interpret_lcalc Expr.typed closure_conversion monomorphize_types
|
||||||
else
|
|
||||||
interpret_lcalc Expr.typed avoid_exceptions closure_conversion
|
|
||||||
monomorphize_types
|
|
||||||
in
|
in
|
||||||
Cmd.v
|
Cmd.v
|
||||||
(Cmd.info "interpret"
|
(Cmd.info "interpret"
|
||||||
@ -817,7 +792,6 @@ module Commands = struct
|
|||||||
Term.(
|
Term.(
|
||||||
const f
|
const f
|
||||||
$ Cli.Flags.lcalc
|
$ Cli.Flags.lcalc
|
||||||
$ Cli.Flags.avoid_exceptions
|
|
||||||
$ Cli.Flags.closure_conversion
|
$ Cli.Flags.closure_conversion
|
||||||
$ Cli.Flags.monomorphize_types
|
$ Cli.Flags.monomorphize_types
|
||||||
$ Cli.Flags.no_typing
|
$ Cli.Flags.no_typing
|
||||||
@ -833,13 +807,11 @@ module Commands = struct
|
|||||||
output
|
output
|
||||||
optimize
|
optimize
|
||||||
check_invariants
|
check_invariants
|
||||||
avoid_exceptions
|
|
||||||
closure_conversion
|
closure_conversion
|
||||||
ex_scope_opt =
|
ex_scope_opt =
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
Passes.lcalc options ~includes ~optimize ~check_invariants
|
Passes.lcalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~typed:Expr.typed ~closure_conversion
|
~typed:Expr.typed ~closure_conversion ~monomorphize_types:false
|
||||||
~monomorphize_types:false
|
|
||||||
in
|
in
|
||||||
let output_file, with_output =
|
let output_file, with_output =
|
||||||
get_output_format options ~ext:".ml" output
|
get_output_format options ~ext:".ml" output
|
||||||
@ -850,10 +822,7 @@ module Commands = struct
|
|||||||
Message.debug "Writing to %s..."
|
Message.debug "Writing to %s..."
|
||||||
(Option.value ~default:"stdout" output_file);
|
(Option.value ~default:"stdout" output_file);
|
||||||
let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in
|
let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in
|
||||||
let hashf =
|
let hashf = Hash.finalise ~closure_conversion ~monomorphize_types:false in
|
||||||
Hash.finalise ~avoid_exceptions ~closure_conversion
|
|
||||||
~monomorphize_types:false
|
|
||||||
in
|
|
||||||
Lcalc.To_ocaml.format_program fmt prg ?exec_scope ~hashf type_ordering
|
Lcalc.To_ocaml.format_program fmt prg ?exec_scope ~hashf type_ordering
|
||||||
|
|
||||||
let ocaml_cmd =
|
let ocaml_cmd =
|
||||||
@ -867,7 +836,6 @@ module Commands = struct
|
|||||||
$ Cli.Flags.output
|
$ Cli.Flags.output
|
||||||
$ Cli.Flags.optimize
|
$ Cli.Flags.optimize
|
||||||
$ Cli.Flags.check_invariants
|
$ Cli.Flags.check_invariants
|
||||||
$ Cli.Flags.avoid_exceptions
|
|
||||||
$ Cli.Flags.closure_conversion
|
$ Cli.Flags.closure_conversion
|
||||||
$ Cli.Flags.ex_scope_opt)
|
$ Cli.Flags.ex_scope_opt)
|
||||||
|
|
||||||
@ -877,7 +845,6 @@ module Commands = struct
|
|||||||
output
|
output
|
||||||
optimize
|
optimize
|
||||||
check_invariants
|
check_invariants
|
||||||
avoid_exceptions
|
|
||||||
closure_conversion
|
closure_conversion
|
||||||
keep_special_ops
|
keep_special_ops
|
||||||
dead_value_assignment
|
dead_value_assignment
|
||||||
@ -886,8 +853,8 @@ module Commands = struct
|
|||||||
ex_scope_opt =
|
ex_scope_opt =
|
||||||
let prg, _ =
|
let prg, _ =
|
||||||
Passes.scalc options ~includes ~optimize ~check_invariants
|
Passes.scalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~closure_conversion ~keep_special_ops
|
~closure_conversion ~keep_special_ops ~dead_value_assignment
|
||||||
~dead_value_assignment ~no_struct_literals ~monomorphize_types
|
~no_struct_literals ~monomorphize_types
|
||||||
in
|
in
|
||||||
let _output_file, with_output = get_output_format options output in
|
let _output_file, with_output = get_output_format options output in
|
||||||
with_output
|
with_output
|
||||||
@ -919,7 +886,6 @@ module Commands = struct
|
|||||||
$ Cli.Flags.output
|
$ Cli.Flags.output
|
||||||
$ Cli.Flags.optimize
|
$ Cli.Flags.optimize
|
||||||
$ Cli.Flags.check_invariants
|
$ Cli.Flags.check_invariants
|
||||||
$ Cli.Flags.avoid_exceptions
|
|
||||||
$ Cli.Flags.closure_conversion
|
$ Cli.Flags.closure_conversion
|
||||||
$ Cli.Flags.keep_special_ops
|
$ Cli.Flags.keep_special_ops
|
||||||
$ Cli.Flags.dead_value_assignment
|
$ Cli.Flags.dead_value_assignment
|
||||||
@ -933,13 +899,11 @@ module Commands = struct
|
|||||||
output
|
output
|
||||||
optimize
|
optimize
|
||||||
check_invariants
|
check_invariants
|
||||||
avoid_exceptions
|
|
||||||
closure_conversion =
|
closure_conversion =
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
Passes.scalc options ~includes ~optimize ~check_invariants
|
Passes.scalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~closure_conversion ~keep_special_ops:false
|
~closure_conversion ~keep_special_ops:false ~dead_value_assignment:true
|
||||||
~dead_value_assignment:true ~no_struct_literals:false
|
~no_struct_literals:false ~monomorphize_types:false
|
||||||
~monomorphize_types:false
|
|
||||||
in
|
in
|
||||||
|
|
||||||
let output_file, with_output =
|
let output_file, with_output =
|
||||||
@ -962,15 +926,13 @@ module Commands = struct
|
|||||||
$ Cli.Flags.output
|
$ Cli.Flags.output
|
||||||
$ Cli.Flags.optimize
|
$ Cli.Flags.optimize
|
||||||
$ Cli.Flags.check_invariants
|
$ Cli.Flags.check_invariants
|
||||||
$ Cli.Flags.avoid_exceptions
|
|
||||||
$ Cli.Flags.closure_conversion)
|
$ Cli.Flags.closure_conversion)
|
||||||
|
|
||||||
let r options includes output optimize check_invariants closure_conversion =
|
let r options includes output optimize check_invariants closure_conversion =
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
Passes.scalc options ~includes ~optimize ~check_invariants
|
Passes.scalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions:false ~closure_conversion ~keep_special_ops:false
|
~closure_conversion ~keep_special_ops:false ~dead_value_assignment:false
|
||||||
~dead_value_assignment:false ~no_struct_literals:false
|
~no_struct_literals:false ~monomorphize_types:false
|
||||||
~monomorphize_types:false
|
|
||||||
in
|
in
|
||||||
|
|
||||||
let output_file, with_output = get_output_format options ~ext:".r" output 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 c options includes output optimize check_invariants =
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
Passes.scalc options ~includes ~optimize ~check_invariants
|
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
|
~dead_value_assignment:false ~no_struct_literals:true
|
||||||
~monomorphize_types:true
|
~monomorphize_types:true
|
||||||
in
|
in
|
||||||
|
@ -51,7 +51,6 @@ module Passes : sig
|
|||||||
optimize:bool ->
|
optimize:bool ->
|
||||||
check_invariants:bool ->
|
check_invariants:bool ->
|
||||||
typed:'m Shared_ast.mark ->
|
typed:'m Shared_ast.mark ->
|
||||||
avoid_exceptions:bool ->
|
|
||||||
closure_conversion:bool ->
|
closure_conversion:bool ->
|
||||||
monomorphize_types:bool ->
|
monomorphize_types:bool ->
|
||||||
Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
Shared_ast.typed Lcalc.Ast.program * Scopelang.Dependency.TVertex.t list
|
||||||
@ -61,7 +60,6 @@ module Passes : sig
|
|||||||
includes:Global.raw_file list ->
|
includes:Global.raw_file list ->
|
||||||
optimize:bool ->
|
optimize:bool ->
|
||||||
check_invariants:bool ->
|
check_invariants:bool ->
|
||||||
avoid_exceptions:bool ->
|
|
||||||
closure_conversion:bool ->
|
closure_conversion:bool ->
|
||||||
keep_special_ops:bool ->
|
keep_special_ops:bool ->
|
||||||
dead_value_assignment:bool ->
|
dead_value_assignment:bool ->
|
||||||
|
@ -30,6 +30,10 @@ type 'm ctx = {
|
|||||||
let new_var ?(pfx = "") name_context =
|
let new_var ?(pfx = "") name_context =
|
||||||
name_context.counter <- name_context.counter + 1;
|
name_context.counter <- name_context.counter + 1;
|
||||||
Var.make (pfx ^ name_context.prefix ^ string_of_int name_context.counter)
|
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 }
|
let new_context prefix = { prefix; counter = 0 }
|
||||||
|
|
||||||
@ -142,8 +146,7 @@ let rec transform_closures_expr :
|
|||||||
let m = Mark.get e in
|
let m = Mark.get e in
|
||||||
match Mark.remove e with
|
match Mark.remove e with
|
||||||
| EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _
|
| EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _
|
||||||
| ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ | ERaiseEmpty
|
| ELit _ | EAssert _ | EFatalError _ | EIfThenElse _ ->
|
||||||
| ECatchEmpty _ ->
|
|
||||||
Expr.map_gather ~acc:Var.Map.empty ~join:join_vars
|
Expr.map_gather ~acc:Var.Map.empty ~join:join_vars
|
||||||
~f:(transform_closures_expr ctx)
|
~f:(transform_closures_expr ctx)
|
||||||
e
|
e
|
||||||
@ -217,7 +220,7 @@ let rec transform_closures_expr :
|
|||||||
EnumConstructor.Map.add cons
|
EnumConstructor.Map.add cons
|
||||||
(Expr.eabs new_binder tys (Mark.get e1))
|
(Expr.eabs new_binder tys (Mark.get e1))
|
||||||
new_cases )
|
new_cases )
|
||||||
| _ -> failwith "should not happen")
|
| _ -> assert false)
|
||||||
cases
|
cases
|
||||||
(free_vars, EnumConstructor.Map.empty)
|
(free_vars, EnumConstructor.Map.empty)
|
||||||
in
|
in
|
||||||
@ -253,7 +256,7 @@ let rec transform_closures_expr :
|
|||||||
free_vars, build_closure ctx (Var.Map.bindings free_vars) body vars tys m
|
free_vars, build_closure ctx (Var.Map.bindings free_vars) body vars tys m
|
||||||
| EAppOp
|
| EAppOp
|
||||||
{
|
{
|
||||||
op = ((HandleDefaultOpt | Fold | Map | Map2 | Filter | Reduce), _) as op;
|
op = ((HandleExceptions | Fold | Map | Map2 | Filter | Reduce), _) as op;
|
||||||
tys;
|
tys;
|
||||||
args;
|
args;
|
||||||
} ->
|
} ->
|
||||||
@ -270,6 +273,9 @@ let rec transform_closures_expr :
|
|||||||
| EAbs { binder; tys } ->
|
| EAbs { binder; tys } ->
|
||||||
let vars, arg = Bindlib.unmbind binder in
|
let vars, arg = Bindlib.unmbind binder in
|
||||||
let new_free_vars, new_arg = (transform_closures_expr ctx) arg 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 =
|
let new_arg =
|
||||||
Expr.make_abs vars new_arg tys (Expr.mark_pos m_arg)
|
Expr.make_abs vars new_arg tys (Expr.mark_pos m_arg)
|
||||||
in
|
in
|
||||||
@ -507,7 +513,7 @@ let rec hoist_closures_expr :
|
|||||||
EnumConstructor.Map.add cons
|
EnumConstructor.Map.add cons
|
||||||
(Expr.eabs new_binder tys (Mark.get e1))
|
(Expr.eabs new_binder tys (Mark.get e1))
|
||||||
new_cases )
|
new_cases )
|
||||||
| _ -> failwith "should not happen")
|
| _ -> assert false)
|
||||||
cases
|
cases
|
||||||
(collected_closures, EnumConstructor.Map.empty)
|
(collected_closures, EnumConstructor.Map.empty)
|
||||||
in
|
in
|
||||||
@ -530,12 +536,7 @@ let rec hoist_closures_expr :
|
|||||||
in
|
in
|
||||||
( collected_closures,
|
( collected_closures,
|
||||||
Expr.eapp ~f:(Expr.eabs new_binder tys e1_pos) ~args:new_args ~tys m )
|
Expr.eapp ~f:(Expr.eabs new_binder tys e1_pos) ~args:new_args ~tys m )
|
||||||
| EAppOp
|
| EAppOp { op = ((Fold | Map | Filter | Reduce), _) as op; tys; args } ->
|
||||||
{
|
|
||||||
op = ((HandleDefaultOpt | Fold | Map | Filter | Reduce), _) as op;
|
|
||||||
tys;
|
|
||||||
args;
|
|
||||||
} ->
|
|
||||||
(* Special case for some operators: its arguments closures thunks because if
|
(* 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
|
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
|
evaluation order, but backends that don't support closures will simply
|
||||||
@ -562,21 +563,21 @@ let rec hoist_closures_expr :
|
|||||||
args ([], [])
|
args ([], [])
|
||||||
in
|
in
|
||||||
collected_closures, Expr.eappop ~op ~args:new_args ~tys (Mark.get e)
|
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 *)
|
(* this is the closure we want to hoist *)
|
||||||
let closure_var = new_var ~pfx:"closure_" name_context in
|
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 pos = Expr.mark_pos m in
|
||||||
let ty = Expr.maybe_ty ~typ:(TArrow (tys, (TAny, 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 )
|
Expr.make_var closure_var m )
|
||||||
| EApp _ | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _
|
| EApp _ | EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _
|
||||||
| EArray _ | ELit _ | EAssert _ | EFatalError _ | EAppOp _ | EIfThenElse _
|
| EArray _ | ELit _ | EAssert _ | EFatalError _ | EAppOp _ | EIfThenElse _
|
||||||
| ERaiseEmpty | ECatchEmpty _ | EVar _ ->
|
| EVar _ ->
|
||||||
Expr.map_gather ~acc:[] ~join:( @ ) ~f:(hoist_closures_expr name_context) e
|
Expr.map_gather ~acc:[] ~join:( @ ) ~f:(hoist_closures_expr name_context) e
|
||||||
| EExternal { name } -> [], Expr.box (EExternal { name }, m)
|
| EExternal { name } -> [], Expr.box (EExternal { name }, m)
|
||||||
| _ -> .
|
| _ -> .
|
||||||
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -1,6 +1,6 @@
|
|||||||
(* This file is part of the Catala compiler, a specification language for tax
|
(* This file is part of the Catala compiler, a specification language for tax
|
||||||
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
|
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
|
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
|
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
|
License for the specific language governing permissions and limitations under
|
||||||
the License. *)
|
the License. *)
|
||||||
|
|
||||||
|
open Catala_utils
|
||||||
open Shared_ast
|
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 =
|
let add_option_type ctx =
|
||||||
{
|
{
|
||||||
@ -26,9 +149,7 @@ let add_option_type ctx =
|
|||||||
let add_option_type_program prg =
|
let add_option_type_program prg =
|
||||||
{ prg with decl_ctx = add_option_type prg.decl_ctx }
|
{ prg with decl_ctx = add_option_type prg.decl_ctx }
|
||||||
|
|
||||||
let translate_program_with_exceptions =
|
let translate_program (prg : 'm D.program) : 'm A.program =
|
||||||
Compile_with_exceptions.translate_program
|
Program.map_exprs
|
||||||
|
(add_option_type_program prg)
|
||||||
let translate_program_without_exceptions prg =
|
~typ:translate_typ ~varf:Var.translate ~f:translate_expr
|
||||||
let prg = add_option_type_program prg in
|
|
||||||
Compile_without_exceptions.translate_program prg
|
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
(* This file is part of the Catala compiler, a specification language for tax
|
(* This file is part of the Catala compiler, a specification language for tax
|
||||||
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
|
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
|
||||||
Denis Merigoux <denis.merigoux@inria.fr>
|
contributor: Alain Delaët-Tixeuil <alain.delaet--tixeuil@inria.fr>
|
||||||
|
|
||||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
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
|
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
|
License for the specific language governing permissions and limitations under
|
||||||
the License. *)
|
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 from the default calculus to the lambda calculus. This
|
||||||
translation uses an option monad to handle empty defaults terms. This
|
translation uses an option monad to handle empty defaults terms. This
|
||||||
transformation is one piece to permit to compile toward legacy languages
|
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
|
||||||
|
@ -78,7 +78,7 @@ let collect_monomorphized_instances (prg : typed program) :
|
|||||||
args;
|
args;
|
||||||
name =
|
name =
|
||||||
StructName.fresh []
|
StructName.fresh []
|
||||||
( "tuple_" ^ string_of_int !option_instances_counter,
|
( "tuple_" ^ string_of_int !tuple_instances_counter,
|
||||||
Pos.no_pos );
|
Pos.no_pos );
|
||||||
})
|
})
|
||||||
acc.tuples;
|
acc.tuples;
|
||||||
@ -90,7 +90,7 @@ let collect_monomorphized_instances (prg : typed program) :
|
|||||||
{
|
{
|
||||||
acc with
|
acc with
|
||||||
arrays =
|
arrays =
|
||||||
Type.Map.update t
|
Type.Map.update typ
|
||||||
(fun monomorphized_name ->
|
(fun monomorphized_name ->
|
||||||
match monomorphized_name with
|
match monomorphized_name with
|
||||||
| Some e -> Some e
|
| Some e -> Some e
|
||||||
@ -118,7 +118,7 @@ let collect_monomorphized_instances (prg : typed program) :
|
|||||||
{
|
{
|
||||||
acc with
|
acc with
|
||||||
options =
|
options =
|
||||||
Type.Map.update t
|
Type.Map.update typ
|
||||||
(fun monomorphized_name ->
|
(fun monomorphized_name ->
|
||||||
match monomorphized_name with
|
match monomorphized_name with
|
||||||
| Some e -> Some e
|
| Some e -> Some e
|
||||||
@ -173,8 +173,9 @@ let rec monomorphize_typ
|
|||||||
(typ : typ) : typ =
|
(typ : typ) : typ =
|
||||||
match Mark.remove typ with
|
match Mark.remove typ with
|
||||||
| TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> typ
|
| TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> typ
|
||||||
| TArray t1 ->
|
| TArray _ ->
|
||||||
TStruct (Type.Map.find t1 monomorphized_instances.arrays).name, Mark.get typ
|
( TStruct (Type.Map.find typ monomorphized_instances.arrays).name,
|
||||||
|
Mark.get typ )
|
||||||
| TDefault t1 ->
|
| TDefault t1 ->
|
||||||
TDefault (monomorphize_typ monomorphized_instances t1), Mark.get typ
|
TDefault (monomorphize_typ monomorphized_instances t1), Mark.get typ
|
||||||
| TArrow (t1s, t2) ->
|
| TArrow (t1s, t2) ->
|
||||||
@ -185,8 +186,8 @@ let rec monomorphize_typ
|
|||||||
| TTuple _ ->
|
| TTuple _ ->
|
||||||
( TStruct (Type.Map.find typ monomorphized_instances.tuples).name,
|
( TStruct (Type.Map.find typ monomorphized_instances.tuples).name,
|
||||||
Mark.get typ )
|
Mark.get typ )
|
||||||
| TOption t1 ->
|
| TOption _ ->
|
||||||
TEnum (Type.Map.find t1 monomorphized_instances.options).name, Mark.get typ
|
TEnum (Type.Map.find typ monomorphized_instances.options).name, Mark.get typ
|
||||||
|
|
||||||
let is_some c =
|
let is_some c =
|
||||||
EnumConstructor.equal Expr.some_constr c
|
EnumConstructor.equal Expr.some_constr c
|
||||||
@ -233,7 +234,12 @@ let rec monomorphize_expr
|
|||||||
field = fst (List.nth tuple_instance.fields index);
|
field = fst (List.nth tuple_instance.fields index);
|
||||||
}
|
}
|
||||||
| EMatch { name; e; cases } when EnumName.equal name Expr.option_enum ->
|
| 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
|
EMatch
|
||||||
{
|
{
|
||||||
name = option_instance.name;
|
name = option_instance.name;
|
||||||
@ -247,11 +253,7 @@ let rec monomorphize_expr
|
|||||||
cases EnumConstructor.Map.empty;
|
cases EnumConstructor.Map.empty;
|
||||||
}
|
}
|
||||||
| EInj { name; e; cons } when EnumName.equal name Expr.option_enum ->
|
| EInj { name; e; cons } when EnumName.equal name Expr.option_enum ->
|
||||||
let option_instance =
|
let option_instance = Type.Map.find ty0 monomorphized_instances.options in
|
||||||
Type.Map.find
|
|
||||||
(match Mark.remove ty0 with TOption t -> t | _ -> assert false)
|
|
||||||
monomorphized_instances.options
|
|
||||||
in
|
|
||||||
EInj
|
EInj
|
||||||
{
|
{
|
||||||
name = option_instance.name;
|
name = option_instance.name;
|
||||||
@ -264,7 +266,7 @@ let rec monomorphize_expr
|
|||||||
let elt_ty =
|
let elt_ty =
|
||||||
match Mark.remove ty0 with TArray t -> t | _ -> assert false
|
match Mark.remove ty0 with TArray t -> t | _ -> assert false
|
||||||
in
|
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
|
EStruct
|
||||||
{
|
{
|
||||||
name = array_instance.name;
|
name = array_instance.name;
|
||||||
|
@ -409,21 +409,6 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
|
|||||||
format_with_parens arg1
|
format_with_parens arg1
|
||||||
| EAppOp { op = Log _, _; args = [arg1]; _ } ->
|
| EAppOp { op = Log _, _; args = [arg1]; _ } ->
|
||||||
Format.fprintf fmt "%a" format_with_parens 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; _ } ->
|
| EApp { f; args; _ } ->
|
||||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
|
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
|
||||||
(Format.pp_print_list
|
(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
|
Format.fprintf ppf "%a@ " format_pos pos
|
||||||
| Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur ->
|
| 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))
|
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
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
|
~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 ->
|
| EFatalError er ->
|
||||||
Format.fprintf fmt "raise@ (Runtime_ocaml.Runtime.Error (%a, [%a]))"
|
Format.fprintf fmt "raise@ (Runtime_ocaml.Runtime.Error (%a, [%a]))"
|
||||||
Print.runtime_error er format_pos (Expr.pos e)
|
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
|
let format_struct_embedding
|
||||||
|
@ -471,15 +471,13 @@ let run
|
|||||||
output
|
output
|
||||||
optimize
|
optimize
|
||||||
check_invariants
|
check_invariants
|
||||||
avoid_exceptions
|
|
||||||
closure_conversion
|
closure_conversion
|
||||||
monomorphize_types
|
monomorphize_types
|
||||||
_options =
|
_options =
|
||||||
let options = Global.enforce_options ~trace:true () in
|
let options = Global.enforce_options ~trace:true () in
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
|
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~closure_conversion ~typed:Expr.typed
|
~closure_conversion ~typed:Expr.typed ~monomorphize_types
|
||||||
~monomorphize_types
|
|
||||||
in
|
in
|
||||||
let jsoo_output_file, with_formatter =
|
let jsoo_output_file, with_formatter =
|
||||||
Driver.Commands.get_output_format options ~ext:"_api_web.ml" output
|
Driver.Commands.get_output_format options ~ext:"_api_web.ml" output
|
||||||
@ -506,7 +504,6 @@ let term =
|
|||||||
$ Cli.Flags.output
|
$ Cli.Flags.output
|
||||||
$ Cli.Flags.optimize
|
$ Cli.Flags.optimize
|
||||||
$ Cli.Flags.check_invariants
|
$ Cli.Flags.check_invariants
|
||||||
$ Cli.Flags.avoid_exceptions
|
|
||||||
$ Cli.Flags.closure_conversion
|
$ Cli.Flags.closure_conversion
|
||||||
$ Cli.Flags.monomorphize_types
|
$ Cli.Flags.monomorphize_types
|
||||||
|
|
||||||
|
@ -1085,8 +1085,7 @@ let expr_to_dot_label0 :
|
|||||||
| Reduce -> xlang () ~en:"reduce" ~fr:"réunion"
|
| Reduce -> xlang () ~en:"reduce" ~fr:"réunion"
|
||||||
| Filter -> xlang () ~en:"filter" ~fr:"filtre"
|
| Filter -> xlang () ~en:"filter" ~fr:"filtre"
|
||||||
| Fold -> xlang () ~en:"fold" ~fr:"pliage"
|
| Fold -> xlang () ~en:"fold" ~fr:"pliage"
|
||||||
| HandleDefault -> ""
|
| HandleExceptions -> ""
|
||||||
| HandleDefaultOpt -> ""
|
|
||||||
| ToClosureEnv -> ""
|
| ToClosureEnv -> ""
|
||||||
| FromClosureEnv -> ""
|
| FromClosureEnv -> ""
|
||||||
in
|
in
|
||||||
@ -1382,9 +1381,7 @@ let run includes optimize ex_scope explain_options global_options =
|
|||||||
~check_invariants:false ~typed:Expr.typed
|
~check_invariants:false ~typed:Expr.typed
|
||||||
in
|
in
|
||||||
Interpreter.load_runtime_modules prg
|
Interpreter.load_runtime_modules prg
|
||||||
~hashf:
|
~hashf:(Hash.finalise ~closure_conversion:false ~monomorphize_types:false);
|
||||||
(Hash.finalise ~avoid_exceptions:false ~closure_conversion:false
|
|
||||||
~monomorphize_types:false);
|
|
||||||
let scope = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in
|
let scope = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in
|
||||||
(* let result_expr, env = interpret_program prg scope in *)
|
(* let result_expr, env = interpret_program prg scope in *)
|
||||||
let g, base_vars, env = program_to_graph explain_options prg scope in
|
let g, base_vars, env = program_to_graph explain_options prg scope in
|
||||||
|
@ -210,15 +210,13 @@ let run
|
|||||||
output
|
output
|
||||||
optimize
|
optimize
|
||||||
check_invariants
|
check_invariants
|
||||||
avoid_exceptions
|
|
||||||
closure_conversion
|
closure_conversion
|
||||||
monomorphize_types
|
monomorphize_types
|
||||||
ex_scope
|
ex_scope
|
||||||
options =
|
options =
|
||||||
let prg, _ =
|
let prg, _ =
|
||||||
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
|
Driver.Passes.lcalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~closure_conversion ~typed:Expr.typed
|
~closure_conversion ~typed:Expr.typed ~monomorphize_types
|
||||||
~monomorphize_types
|
|
||||||
in
|
in
|
||||||
let output_file, with_output =
|
let output_file, with_output =
|
||||||
Driver.Commands.get_output_format options ~ext:"_schema.json" output
|
Driver.Commands.get_output_format options ~ext:"_schema.json" output
|
||||||
@ -239,7 +237,6 @@ let term =
|
|||||||
$ Cli.Flags.output
|
$ Cli.Flags.output
|
||||||
$ Cli.Flags.optimize
|
$ Cli.Flags.optimize
|
||||||
$ Cli.Flags.check_invariants
|
$ Cli.Flags.check_invariants
|
||||||
$ Cli.Flags.avoid_exceptions
|
|
||||||
$ Cli.Flags.closure_conversion
|
$ Cli.Flags.closure_conversion
|
||||||
$ Cli.Flags.monomorphize_types
|
$ Cli.Flags.monomorphize_types
|
||||||
$ Cli.Flags.ex_scope
|
$ Cli.Flags.ex_scope
|
||||||
|
@ -272,9 +272,7 @@ let run includes optimize check_invariants ex_scope options =
|
|||||||
~typed:Expr.typed
|
~typed:Expr.typed
|
||||||
in
|
in
|
||||||
Interpreter.load_runtime_modules prg
|
Interpreter.load_runtime_modules prg
|
||||||
~hashf:
|
~hashf:(Hash.finalise ~closure_conversion:false ~monomorphize_types:false);
|
||||||
(Hash.finalise ~avoid_exceptions:false ~closure_conversion:false
|
|
||||||
~monomorphize_types:false);
|
|
||||||
let scope = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in
|
let scope = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in
|
||||||
let result_expr, _env = interpret_program prg scope in
|
let result_expr, _env = interpret_program prg scope in
|
||||||
let fmt = Format.std_formatter in
|
let fmt = Format.std_formatter in
|
||||||
|
@ -22,20 +22,12 @@
|
|||||||
|
|
||||||
open Catala_utils
|
open Catala_utils
|
||||||
|
|
||||||
let run
|
let run includes output optimize check_invariants closure_conversion options =
|
||||||
includes
|
|
||||||
output
|
|
||||||
optimize
|
|
||||||
check_invariants
|
|
||||||
avoid_exceptions
|
|
||||||
closure_conversion
|
|
||||||
options =
|
|
||||||
let open Driver.Commands in
|
let open Driver.Commands in
|
||||||
let prg, type_ordering =
|
let prg, type_ordering =
|
||||||
Driver.Passes.scalc options ~includes ~optimize ~check_invariants
|
Driver.Passes.scalc options ~includes ~optimize ~check_invariants
|
||||||
~avoid_exceptions ~closure_conversion ~keep_special_ops:false
|
~closure_conversion ~keep_special_ops:false ~dead_value_assignment:true
|
||||||
~dead_value_assignment:true ~no_struct_literals:false
|
~no_struct_literals:false ~monomorphize_types:false
|
||||||
~monomorphize_types:false
|
|
||||||
in
|
in
|
||||||
|
|
||||||
let output_file, with_output = get_output_format options ~ext:".py" output 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.output
|
||||||
$ Cli.Flags.optimize
|
$ Cli.Flags.optimize
|
||||||
$ Cli.Flags.check_invariants
|
$ Cli.Flags.check_invariants
|
||||||
$ Cli.Flags.avoid_exceptions
|
|
||||||
$ Cli.Flags.closure_conversion
|
$ Cli.Flags.closure_conversion
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
|
@ -33,10 +33,6 @@ module VarName =
|
|||||||
end)
|
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 operator = Shared_ast.lcalc Shared_ast.operator
|
||||||
|
|
||||||
type expr = naked_expr Mark.pos
|
type expr = naked_expr Mark.pos
|
||||||
|
@ -35,13 +35,6 @@ type 'm ctxt = {
|
|||||||
program_ctx : A.ctx;
|
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
|
(* Expressions can spill out side effect, hence this function also returns a
|
||||||
list of statements to be prepended before the expression is evaluated *)
|
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; _ } ->
|
| ETupleAccess { e = e1; index; _ } ->
|
||||||
let e1_stmts, new_e1 = translate_expr ctxt e1 in
|
let e1_stmts, new_e1 = translate_expr ctxt e1 in
|
||||||
e1_stmts, (A.ETupleAccess { e1 = new_e1; index }, Expr.pos expr)
|
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 = _ } ->
|
| EAppOp { op; args; tys = _ } ->
|
||||||
let args_stmts, new_args = translate_expr_list ctxt args in
|
let args_stmts, new_args = translate_expr_list ctxt args in
|
||||||
(* FIXME: what happens if [arg] is not a tuple but reduces to one ? *)
|
(* 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 )
|
Expr.pos expr )
|
||||||
in
|
in
|
||||||
RevBlock.empty, (EExternal { modname; name }, Expr.pos expr)
|
RevBlock.empty, (EExternal { modname; name }, Expr.pos expr)
|
||||||
| ECatchEmpty _ | EAbs _ | EIfThenElse _ | EMatch _ | EAssert _
|
| EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ | EFatalError _ ->
|
||||||
| EFatalError _ | ERaiseEmpty ->
|
|
||||||
raise (NotAnExpr { needs_a_local_decl = true })
|
raise (NotAnExpr { needs_a_local_decl = true })
|
||||||
| _ -> .
|
| _ -> .
|
||||||
with NotAnExpr { needs_a_local_decl } ->
|
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]
|
~tail:[A.SAssert (Mark.remove new_e), Expr.pos block_expr]
|
||||||
e_stmts
|
e_stmts
|
||||||
| EFatalError err -> [SFatalError err, Expr.pos block_expr]
|
| EFatalError err -> [SFatalError err, Expr.pos block_expr]
|
||||||
| EAppOp
|
(* | EAppOp
|
||||||
{ op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] }
|
* { op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] }
|
||||||
when ctxt.config.keep_special_ops ->
|
* when ctxt.config.keep_special_ops ->
|
||||||
let exceptions =
|
* let exceptions =
|
||||||
match Mark.remove exceptions with
|
* match Mark.remove exceptions with
|
||||||
| EStruct { fields; _ } -> (
|
* | EStruct { fields; _ } -> (
|
||||||
let _, exceptions =
|
* let _, exceptions =
|
||||||
List.find
|
* List.find
|
||||||
(fun (field, _) ->
|
* (fun (field, _) ->
|
||||||
String.equal (Mark.remove (StructField.get_info field)) "content")
|
* String.equal (Mark.remove (StructField.get_info field)) "content")
|
||||||
(StructField.Map.bindings fields)
|
* (StructField.Map.bindings fields)
|
||||||
in
|
* in
|
||||||
match Mark.remove exceptions with
|
* match Mark.remove exceptions with
|
||||||
| EArray exceptions -> exceptions
|
* | EArray exceptions -> exceptions
|
||||||
| _ -> failwith "should not happen")
|
* | _ -> failwith "should not happen")
|
||||||
| _ -> failwith "should not happen"
|
* | _ -> failwith "should not happen"
|
||||||
in
|
* in
|
||||||
let just = unthunk just in
|
* let just = unthunk just in
|
||||||
let cons = unthunk cons in
|
* let cons = unthunk cons in
|
||||||
let exceptions_stmts, new_exceptions =
|
* let exceptions_stmts, new_exceptions =
|
||||||
translate_expr_list ctxt exceptions
|
* translate_expr_list ctxt exceptions
|
||||||
in
|
* in
|
||||||
let just_stmts, new_just = translate_expr ctxt just in
|
* let just_stmts, new_just = translate_expr ctxt just in
|
||||||
let cons_stmts, new_cons = translate_expr ctxt cons in
|
* let cons_stmts, new_cons = translate_expr ctxt cons in
|
||||||
RevBlock.rebuild exceptions_stmts
|
* RevBlock.rebuild exceptions_stmts
|
||||||
~tail:
|
* ~tail:
|
||||||
(RevBlock.rebuild just_stmts
|
* (RevBlock.rebuild just_stmts
|
||||||
~tail:
|
* ~tail:
|
||||||
[
|
* [
|
||||||
( A.SSpecialOp
|
* ( A.SSpecialOp
|
||||||
(OHandleDefaultOpt
|
* (OHandleDefaultOpt
|
||||||
{
|
* {
|
||||||
exceptions = new_exceptions;
|
* exceptions = new_exceptions;
|
||||||
just = new_just;
|
* just = new_just;
|
||||||
cons =
|
* cons =
|
||||||
RevBlock.rebuild cons_stmts
|
* RevBlock.rebuild cons_stmts
|
||||||
~tail:
|
* ~tail:
|
||||||
[
|
* [
|
||||||
( (match ctxt.inside_definition_of with
|
* ( (match ctxt.inside_definition_of with
|
||||||
| None -> A.SReturn (Mark.remove new_cons)
|
* | None -> A.SReturn (Mark.remove new_cons)
|
||||||
| Some x ->
|
* | Some x ->
|
||||||
A.SLocalDef
|
* A.SLocalDef
|
||||||
{
|
* {
|
||||||
name = Mark.copy new_cons x;
|
* name = Mark.copy new_cons x;
|
||||||
expr = new_cons;
|
* expr = new_cons;
|
||||||
typ =
|
* typ =
|
||||||
Expr.maybe_ty (Mark.get block_expr);
|
* Expr.maybe_ty (Mark.get block_expr);
|
||||||
}),
|
* }),
|
||||||
Expr.pos block_expr );
|
* Expr.pos block_expr );
|
||||||
];
|
* ];
|
||||||
return_typ = Expr.maybe_ty (Mark.get block_expr);
|
* return_typ = Expr.maybe_ty (Mark.get block_expr);
|
||||||
}),
|
* }),
|
||||||
Expr.pos block_expr );
|
* Expr.pos block_expr );
|
||||||
])
|
* ]) *)
|
||||||
| EApp { f = EAbs { binder; tys }, binder_mark; args; _ } ->
|
| EApp { f = EAbs { binder; tys }, binder_mark; args; _ } ->
|
||||||
(* This defines multiple local variables at the time *)
|
(* This defines multiple local variables at the time *)
|
||||||
let binder_pos = Expr.mark_pos binder_mark in
|
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 );
|
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 ->
|
| EInj { e = e1; cons; name } when ctxt.config.no_struct_literals ->
|
||||||
let e1_stmts, new_e1 = translate_expr ctxt e1 in
|
let e1_stmts, new_e1 = translate_expr ctxt e1 in
|
||||||
let tmp_struct_var_name =
|
let tmp_struct_var_name =
|
||||||
|
@ -53,7 +53,7 @@ let rec format_expr
|
|||||||
(StructField.Map.bindings es)
|
(StructField.Map.bindings es)
|
||||||
Print.punctuation "}"
|
Print.punctuation "}"
|
||||||
| ETuple es ->
|
| 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
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||||
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
|
(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 ()
|
Format.pp_print_cut ppf ()
|
||||||
|
|
||||||
let format_program ?debug ppf prg =
|
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;
|
Format.pp_open_vbox ppf 0;
|
||||||
ModuleName.Map.iter
|
ModuleName.Map.iter
|
||||||
(fun m var ->
|
(fun m var ->
|
||||||
Format.fprintf ppf "%a %a = %a@," Print.keyword "module" format_var_name
|
Format.fprintf ppf "%a %a = %a@," Print.keyword "module" format_var_name
|
||||||
var ModuleName.format m)
|
var ModuleName.format m)
|
||||||
prg.ctx.modules;
|
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 ()
|
Format.pp_close_box ppf ()
|
||||||
|
@ -313,9 +313,8 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
|
|||||||
| Reduce -> Format.pp_print_string fmt "catala_list_reduce"
|
| Reduce -> Format.pp_print_string fmt "catala_list_reduce"
|
||||||
| Filter -> Format.pp_print_string fmt "catala_list_filter"
|
| Filter -> Format.pp_print_string fmt "catala_list_filter"
|
||||||
| Fold -> Format.pp_print_string fmt "catala_list_fold_left"
|
| Fold -> Format.pp_print_string fmt "catala_list_fold_left"
|
||||||
| HandleDefault -> Format.pp_print_string fmt "catala_handle_default"
|
| HandleExceptions -> Format.pp_print_string fmt "catala_handle_exceptions"
|
||||||
| HandleDefaultOpt | FromClosureEnv | ToClosureEnv | Map2 ->
|
| FromClosureEnv | ToClosureEnv | Map2 -> failwith "unimplemented"
|
||||||
failwith "unimplemented"
|
|
||||||
|
|
||||||
let _format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
let _format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
||||||
let sanitize_quotes = Re.compile (Re.char '"') in
|
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
|
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) arg1
|
||||||
| EAppOp { op; args = [arg1] } ->
|
| EAppOp { op; args = [arg1] } ->
|
||||||
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) 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 } ->
|
| EApp { f; args } ->
|
||||||
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
|
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
|
@ -88,8 +88,7 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
|
|||||||
| Reduce -> Format.pp_print_string fmt "list_reduce"
|
| Reduce -> Format.pp_print_string fmt "list_reduce"
|
||||||
| Filter -> Format.pp_print_string fmt "list_filter"
|
| Filter -> Format.pp_print_string fmt "list_filter"
|
||||||
| Fold -> Format.pp_print_string fmt "list_fold_left"
|
| Fold -> Format.pp_print_string fmt "list_fold_left"
|
||||||
| HandleDefault -> Format.pp_print_string fmt "handle_default"
|
| HandleExceptions -> Format.pp_print_string fmt "handle_exceptions"
|
||||||
| HandleDefaultOpt -> Format.pp_print_string fmt "handle_default_opt"
|
|
||||||
| FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
|
| FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
|
||||||
|
|
||||||
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
|
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];
|
args = [arg1];
|
||||||
} ->
|
} ->
|
||||||
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) 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] } ->
|
| EAppOp { op; args = [arg1] } ->
|
||||||
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) 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 } ->
|
| 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
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||||
(format_expression ctx))
|
(format_expression ctx))
|
||||||
args
|
args
|
||||||
| EAppOp { op; 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
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||||
(format_expression ctx))
|
(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
|
match Mark.remove s with
|
||||||
| SInnerFuncDef { name; func = { func_params; func_body; _ } } ->
|
| 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)
|
(Mark.remove name)
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||||
(fun fmt (var, typ) ->
|
(fun fmt (var, typ) ->
|
||||||
Format.fprintf fmt "%a:%a" format_var (Mark.remove var)
|
Format.fprintf fmt "%a:%a" format_var (Mark.remove var)
|
||||||
(format_typ ctx) typ))
|
(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 *)
|
assert false (* We don't need to declare variables in Python *)
|
||||||
| SLocalDef { name = v; expr = e; _ } | SLocalInit { name = v; expr = e; _ }
|
| 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
|
(format_expression ctx) e
|
||||||
| STryWEmpty { try_block = try_b; with_block = catch_b } ->
|
| 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
|
(format_block ctx) try_b (format_block ctx) catch_b
|
||||||
| SRaiseEmpty -> Format.fprintf fmt "raise Empty"
|
| SRaiseEmpty -> Format.fprintf fmt "raise Empty"
|
||||||
| SFatalError err ->
|
| SFatalError err ->
|
||||||
Format.fprintf fmt "@[<hov 4>raise %a@]" format_error (err, Mark.get s)
|
Format.fprintf fmt "@[<hov 4>raise %a@]" format_error (err, Mark.get s)
|
||||||
| SIfThenElse { if_expr = cond; then_block = b1; else_block = b2 } ->
|
| 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
|
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
|
||||||
| SSwitch
|
| 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 ->
|
when EnumName.equal e_name Expr.option_enum ->
|
||||||
(* We translate the option type with an overloading by Python's [None] *)
|
(* We translate the option type with an overloading by Python's [None] *)
|
||||||
let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in
|
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)
|
Format.fprintf fmt "@[<hv 4>%a = %a@]@," format_var tmp_var
|
||||||
e1;
|
(format_expression ctx) e1;
|
||||||
Format.fprintf fmt "@[<v 4>if %a is None:@\n%a@]@\n" format_var tmp_var
|
Format.fprintf fmt "@[<v 4>if %a is None:@ %a@]@," format_var tmp_var
|
||||||
(format_block ctx) case_none;
|
(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
|
format_var tmp_var (format_block ctx) case_some
|
||||||
| SSwitch { switch_expr = e1; enum_name = e_name; switch_cases = cases; _ } ->
|
| 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
|
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 ->
|
| SAssert e1 ->
|
||||||
let pos = Mark.get s in
|
let pos = Mark.get s in
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"@[<hov 4>if not (%a):@\n\
|
"@[<hv 4>if not (%a):@,\
|
||||||
raise AssertionFailure(@[<hov 0>SourcePosition(@[<hov \
|
raise AssertionFailure(@[<hov>SourcePosition(@[<hov 0>filename=\"%s\",@ \
|
||||||
0>filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \
|
start_line=%d,@ start_column=%d,@ end_line=%d,@ end_column=%d,@ \
|
||||||
end_column=%d,@ law_headings=@[<hv>%a@])@])@]@]"
|
law_headings=@[<hv>%a@])@])@]@]"
|
||||||
(format_expression ctx)
|
(format_expression ctx)
|
||||||
(e1, Mark.get s)
|
(e1, Mark.get s)
|
||||||
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
|
(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"
|
| SSpecialOp _ -> failwith "should not happen"
|
||||||
|
|
||||||
and format_block ctx (fmt : Format.formatter) (b : block) : unit =
|
and format_block ctx (fmt : Format.formatter) (b : block) : unit =
|
||||||
|
Format.pp_open_vbox fmt 0;
|
||||||
Format.pp_print_list
|
Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,")
|
||||||
(format_statement ctx) fmt
|
(format_statement ctx) fmt
|
||||||
(List.filter
|
(List.filter
|
||||||
(fun s -> match Mark.remove s with SLocalDecl _ -> false | _ -> true)
|
(fun s -> match Mark.remove s with SLocalDecl _ -> false | _ -> true)
|
||||||
b)
|
b);
|
||||||
|
Format.pp_close_box fmt ()
|
||||||
|
|
||||||
let format_ctx
|
let format_ctx
|
||||||
(type_ordering : Scopelang.Dependency.TVertex.t list)
|
(type_ordering : Scopelang.Dependency.TVertex.t list)
|
||||||
@ -496,20 +483,20 @@ let format_ctx
|
|||||||
let format_struct_decl fmt (struct_name, struct_fields) =
|
let format_struct_decl fmt (struct_name, struct_fields) =
|
||||||
let fields = StructField.Map.bindings struct_fields in
|
let fields = StructField.Map.bindings struct_fields in
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"class %a:@\n\
|
"class %a:@,\
|
||||||
\ def __init__(self, %a) -> None:@\n\
|
\ def __init__(self, %a) -> None:@,\
|
||||||
%a@\n\
|
%a@,\
|
||||||
@\n\
|
@,\
|
||||||
\ def __eq__(self, other: object) -> bool:@\n\
|
\ def __eq__(self, other: object) -> bool:@,\
|
||||||
\ if isinstance(other, %a):@\n\
|
\ if isinstance(other, %a):@,\
|
||||||
\ return @[<hov>(%a)@]@\n\
|
\ return @[<hov>(%a)@]@,\
|
||||||
\ else:@\n\
|
\ else:@,\
|
||||||
\ return False@\n\
|
\ return False@,\
|
||||||
@\n\
|
@,\
|
||||||
\ def __ne__(self, other: object) -> bool:@\n\
|
\ def __ne__(self, other: object) -> bool:@,\
|
||||||
\ return not (self == other)@\n\
|
\ return not (self == other)@,\
|
||||||
@\n\
|
@,\
|
||||||
\ def __str__(self) -> str:@\n\
|
\ def __str__(self) -> str:@,\
|
||||||
\ @[<hov 4>return \"%a(%a)\".format(%a)@]" (format_struct_name ctx)
|
\ @[<hov 4>return \"%a(%a)\".format(%a)@]" (format_struct_name ctx)
|
||||||
struct_name
|
struct_name
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
@ -521,9 +508,7 @@ let format_ctx
|
|||||||
(if StructField.Map.is_empty struct_fields then fun fmt _ ->
|
(if StructField.Map.is_empty struct_fields then fun fmt _ ->
|
||||||
Format.fprintf fmt " pass"
|
Format.fprintf fmt " pass"
|
||||||
else
|
else
|
||||||
Format.pp_print_list
|
Format.pp_print_list (fun fmt (struct_field, _) ->
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
|
||||||
(fun fmt (struct_field, _) ->
|
|
||||||
Format.fprintf fmt " self.%a = %a" format_struct_field_name
|
Format.fprintf fmt " self.%a = %a" format_struct_field_name
|
||||||
struct_field format_struct_field_name struct_field))
|
struct_field format_struct_field_name struct_field))
|
||||||
fields (format_struct_name ctx) struct_name
|
fields (format_struct_name ctx) struct_name
|
||||||
@ -551,32 +536,30 @@ let format_ctx
|
|||||||
failwith "no constructors in the enum"
|
failwith "no constructors in the enum"
|
||||||
else
|
else
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
"@[<hov 4>class %a_Code(Enum):@\n\
|
"@[<v 4>class %a_Code(Enum):@,\
|
||||||
%a@]@\n\
|
%a@]@,\
|
||||||
@\n\
|
@,\
|
||||||
class %a:@\n\
|
class %a:@,\
|
||||||
\ def __init__(self, code: %a_Code, value: Any) -> None:@\n\
|
\ def __init__(self, code: %a_Code, value: Any) -> None:@,\
|
||||||
\ self.code = code@\n\
|
\ self.code = code@,\
|
||||||
\ self.value = value@\n\
|
\ self.value = value@,\
|
||||||
@\n\
|
@,\
|
||||||
@\n\
|
@,\
|
||||||
\ def __eq__(self, other: object) -> bool:@\n\
|
\ def __eq__(self, other: object) -> bool:@,\
|
||||||
\ if isinstance(other, %a):@\n\
|
\ if isinstance(other, %a):@,\
|
||||||
\ return self.code == other.code and self.value == \
|
\ return self.code == other.code and self.value == \
|
||||||
other.value@\n\
|
other.value@,\
|
||||||
\ else:@\n\
|
\ else:@,\
|
||||||
\ return False@\n\
|
\ return False@,\
|
||||||
@\n\
|
@,\
|
||||||
@\n\
|
@,\
|
||||||
\ def __ne__(self, other: object) -> bool:@\n\
|
\ def __ne__(self, other: object) -> bool:@,\
|
||||||
\ return not (self == other)@\n\
|
\ return not (self == other)@,\
|
||||||
@\n\
|
@,\
|
||||||
\ def __str__(self) -> str:@\n\
|
\ def __str__(self) -> str:@,\
|
||||||
\ @[<hov 4>return \"{}({})\".format(self.code, self.value)@]"
|
\ @[<hov 4>return \"{}({})\".format(self.code, self.value)@]"
|
||||||
(format_enum_name ctx) enum_name
|
(format_enum_name ctx) enum_name
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list (fun fmt (i, enum_cons, _enum_cons_type) ->
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
|
||||||
(fun fmt (i, enum_cons, _enum_cons_type) ->
|
|
||||||
Format.fprintf fmt "%a = %d" format_enum_cons_name enum_cons i))
|
Format.fprintf fmt "%a = %d" format_enum_cons_name enum_cons i))
|
||||||
(List.mapi
|
(List.mapi
|
||||||
(fun i (x, y) -> i, x, y)
|
(fun i (x, y) -> i, x, y)
|
||||||
@ -606,11 +589,11 @@ let format_ctx
|
|||||||
match struct_or_enum with
|
match struct_or_enum with
|
||||||
| Scopelang.Dependency.TVertex.Struct s ->
|
| Scopelang.Dependency.TVertex.Struct s ->
|
||||||
if StructName.path s = [] then
|
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)
|
(s, StructName.Map.find s ctx.decl_ctx.ctx_structs)
|
||||||
| Scopelang.Dependency.TVertex.Enum e ->
|
| Scopelang.Dependency.TVertex.Enum e ->
|
||||||
if EnumName.path e = [] then
|
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))
|
(e, EnumName.Map.find e ctx.decl_ctx.ctx_enums))
|
||||||
(type_ordering @ scope_structs)
|
(type_ordering @ scope_structs)
|
||||||
|
|
||||||
@ -626,14 +609,15 @@ let reserve_func_name = function
|
|||||||
|
|
||||||
let format_code_item ctx fmt = function
|
let format_code_item ctx fmt = function
|
||||||
| SVar { var; expr; typ = _ } ->
|
| 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
|
(format_expression ctx) expr
|
||||||
| SFunc { var; func }
|
| SFunc { var; func }
|
||||||
| SScope { scope_body_var = var; scope_body_func = func; _ } ->
|
| SScope { scope_body_var = var; scope_body_func = func; _ } ->
|
||||||
let { Ast.func_params; Ast.func_body; _ } = func in
|
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
|
(Format.pp_print_list
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||||
(fun fmt (var, typ) ->
|
(fun fmt (var, typ) ->
|
||||||
Format.fprintf fmt "%a:%a" format_var (Mark.remove var)
|
Format.fprintf fmt "%a:%a" format_var (Mark.remove var)
|
||||||
(format_typ ctx) typ))
|
(format_typ ctx) typ))
|
||||||
|
@ -103,8 +103,7 @@ let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
|
|||||||
| Reduce -> Format.pp_print_string fmt "catala_list_reduce"
|
| Reduce -> Format.pp_print_string fmt "catala_list_reduce"
|
||||||
| Filter -> Format.pp_print_string fmt "catala_list_filter"
|
| Filter -> Format.pp_print_string fmt "catala_list_filter"
|
||||||
| Fold -> Format.pp_print_string fmt "catala_list_fold_left"
|
| Fold -> Format.pp_print_string fmt "catala_list_fold_left"
|
||||||
| HandleDefault -> Format.pp_print_string fmt "catala_handle_default"
|
| HandleExceptions | FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
|
||||||
| HandleDefaultOpt | FromClosureEnv | ToClosureEnv -> failwith "unimplemented"
|
|
||||||
|
|
||||||
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
||||||
let sanitize_quotes = Re.compile (Re.char '"') in
|
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];
|
args = [arg1];
|
||||||
} ->
|
} ->
|
||||||
Format.fprintf fmt "%a %a" format_op op (format_expression ctx) 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] } ->
|
| EAppOp { op; args = [arg1] } ->
|
||||||
Format.fprintf fmt "%a(%a)" format_op op (format_expression ctx) 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 } ->
|
| EApp { f; args } ->
|
||||||
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
|
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
|
||||||
(Format.pp_print_list
|
(Format.pp_print_list
|
||||||
|
@ -20,6 +20,13 @@ type ('e, 'elt, 'last) t = ('e, 'elt, 'last) bound_list =
|
|||||||
| Last of 'last
|
| Last of 'last
|
||||||
| Cons of 'elt * ('e, ('e, 'elt, 'last) t) binder
|
| 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
|
let rec last = function
|
||||||
| Last e -> e
|
| Last e -> e
|
||||||
| Cons (_, bnd) ->
|
| Cons (_, bnd) ->
|
||||||
|
@ -30,6 +30,7 @@ type ('e, 'elt, 'last) t = ('e, 'elt, 'last) bound_list =
|
|||||||
| Last of 'last
|
| Last of 'last
|
||||||
| Cons of 'elt * ('e, ('e, 'elt, 'last) t) binder
|
| 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 last : (_, _, 'a) t -> 'a
|
||||||
val iter : f:('e Var.t -> 'elt -> unit) -> ('e, 'elt, 'last) t -> 'last
|
val iter : f:('e Var.t -> 'elt -> unit) -> ('e, 'elt, 'last) t -> 'last
|
||||||
val find : f:('elt -> 'a option) -> (_, 'elt, _) t -> 'a
|
val find : f:('elt -> 'a option) -> (_, 'elt, _) t -> 'a
|
||||||
|
@ -138,7 +138,6 @@ type desugared =
|
|||||||
; explicitScopes : yes
|
; explicitScopes : yes
|
||||||
; assertions : no
|
; assertions : no
|
||||||
; defaultTerms : yes
|
; defaultTerms : yes
|
||||||
; exceptions : no
|
|
||||||
; custom : no >
|
; custom : no >
|
||||||
(* Technically, desugared before name resolution has [syntacticNames: yes;
|
(* Technically, desugared before name resolution has [syntacticNames: yes;
|
||||||
resolvedNames: no], and after name resolution has the opposite; but the
|
resolvedNames: no], and after name resolution has the opposite; but the
|
||||||
@ -159,7 +158,6 @@ type scopelang =
|
|||||||
; explicitScopes : yes
|
; explicitScopes : yes
|
||||||
; assertions : no
|
; assertions : no
|
||||||
; defaultTerms : yes
|
; defaultTerms : yes
|
||||||
; exceptions : no
|
|
||||||
; custom : no >
|
; custom : no >
|
||||||
|
|
||||||
type dcalc =
|
type dcalc =
|
||||||
@ -173,7 +171,6 @@ type dcalc =
|
|||||||
; explicitScopes : no
|
; explicitScopes : no
|
||||||
; assertions : yes
|
; assertions : yes
|
||||||
; defaultTerms : yes
|
; defaultTerms : yes
|
||||||
; exceptions : no
|
|
||||||
; custom : no >
|
; custom : no >
|
||||||
|
|
||||||
type lcalc =
|
type lcalc =
|
||||||
@ -187,7 +184,6 @@ type lcalc =
|
|||||||
; explicitScopes : no
|
; explicitScopes : no
|
||||||
; assertions : yes
|
; assertions : yes
|
||||||
; defaultTerms : no
|
; defaultTerms : no
|
||||||
; exceptions : yes
|
|
||||||
; custom : no >
|
; custom : no >
|
||||||
|
|
||||||
type 'a any = < .. > as 'a
|
type 'a any = < .. > as 'a
|
||||||
@ -206,12 +202,11 @@ type dcalc_lcalc_features =
|
|||||||
; assertions : yes >
|
; assertions : yes >
|
||||||
(** Features that are common to Dcalc and Lcalc *)
|
(** Features that are common to Dcalc and Lcalc *)
|
||||||
|
|
||||||
type ('a, 'b) dcalc_lcalc =
|
type 'd dcalc_lcalc = < dcalc_lcalc_features ; defaultTerms : 'd ; custom : no >
|
||||||
< dcalc_lcalc_features ; defaultTerms : 'a ; exceptions : 'b ; custom : no >
|
|
||||||
(** This type regroups Dcalc and Lcalc ASTs. *)
|
(** This type regroups Dcalc and Lcalc ASTs. *)
|
||||||
|
|
||||||
type ('a, 'b, 'c) interpr_kind =
|
type ('d, 'c) interpr_kind =
|
||||||
< dcalc_lcalc_features ; defaultTerms : 'a ; exceptions : 'b ; custom : 'c >
|
< dcalc_lcalc_features ; defaultTerms : 'd ; custom : 'c >
|
||||||
(** This type corresponds to the types handled by the interpreter: it regroups
|
(** This type corresponds to the types handled by the interpreter: it regroups
|
||||||
Dcalc and Lcalc ASTs and may have custom terms *)
|
Dcalc and Lcalc ASTs and may have custom terms *)
|
||||||
|
|
||||||
@ -372,8 +367,7 @@ module Op = struct
|
|||||||
(* * polymorphic *)
|
(* * polymorphic *)
|
||||||
| Reduce : < polymorphic ; .. > t
|
| Reduce : < polymorphic ; .. > t
|
||||||
| Fold : < polymorphic ; .. > t
|
| Fold : < polymorphic ; .. > t
|
||||||
| HandleDefault : < polymorphic ; .. > t
|
| HandleExceptions : < polymorphic ; .. > t
|
||||||
| HandleDefaultOpt : < polymorphic ; .. > t
|
|
||||||
end
|
end
|
||||||
|
|
||||||
type 'a operator = 'a Op.t
|
type 'a operator = 'a Op.t
|
||||||
@ -563,13 +557,6 @@ and ('a, 'b, 'm) base_gexpr =
|
|||||||
| EErrorOnEmpty :
|
| EErrorOnEmpty :
|
||||||
('a, 'm) gexpr
|
('a, 'm) gexpr
|
||||||
-> ('a, < defaultTerms : yes ; .. >, 'm) base_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 *)
|
(* Only used during evaluation *)
|
||||||
| ECustom : {
|
| ECustom : {
|
||||||
obj : Obj.t;
|
obj : Obj.t;
|
||||||
|
@ -145,10 +145,6 @@ let eifthenelse cond etrue efalse =
|
|||||||
|
|
||||||
let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> EErrorOnEmpty e1
|
let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> EErrorOnEmpty e1
|
||||||
let eempty mark = Mark.add mark (Bindlib.box EEmpty)
|
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 =
|
let ecustom obj targs tret mark =
|
||||||
Mark.add mark (Bindlib.box (ECustom { obj; targs; tret }))
|
Mark.add mark (Bindlib.box (ECustom { obj; targs; tret }))
|
||||||
@ -333,8 +329,6 @@ let map
|
|||||||
| EPureDefault e1 -> epuredefault (f e1) m
|
| EPureDefault e1 -> epuredefault (f e1) m
|
||||||
| EEmpty -> eempty m
|
| EEmpty -> eempty m
|
||||||
| EErrorOnEmpty e1 -> eerroronempty (f e1) m
|
| EErrorOnEmpty e1 -> eerroronempty (f e1) m
|
||||||
| ECatchEmpty { body; handler } -> ecatchempty (f body) (f handler) m
|
|
||||||
| ERaiseEmpty -> eraiseempty m
|
|
||||||
| ELocation loc -> elocation loc m
|
| ELocation loc -> elocation loc m
|
||||||
| EStruct { name; fields } ->
|
| EStruct { name; fields } ->
|
||||||
let fields = StructField.Map.map f fields in
|
let fields = StructField.Map.map f fields in
|
||||||
@ -365,9 +359,7 @@ let shallow_fold
|
|||||||
(acc : 'acc) : 'acc =
|
(acc : 'acc) : 'acc =
|
||||||
let lfold x acc = List.fold_left (fun acc x -> f x acc) acc x in
|
let lfold x acc = List.fold_left (fun acc x -> f x acc) acc x in
|
||||||
match Mark.remove e with
|
match Mark.remove e with
|
||||||
| ELit _ | EVar _ | EFatalError _ | EExternal _ | ERaiseEmpty | ELocation _
|
| ELit _ | EVar _ | EFatalError _ | EExternal _ | ELocation _ | EEmpty -> acc
|
||||||
| EEmpty ->
|
|
||||||
acc
|
|
||||||
| EApp { f = e; args; _ } -> acc |> f e |> lfold args
|
| EApp { f = e; args; _ } -> acc |> f e |> lfold args
|
||||||
| EAppOp { args; _ } -> acc |> lfold args
|
| EAppOp { args; _ } -> acc |> lfold args
|
||||||
| EArray 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
|
| EDefault { excepts; just; cons } -> acc |> lfold excepts |> f just |> f cons
|
||||||
| EPureDefault e -> acc |> f e
|
| EPureDefault e -> acc |> f e
|
||||||
| EErrorOnEmpty 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
|
| EStruct { fields; _ } -> acc |> StructField.Map.fold (fun _ -> f) fields
|
||||||
| EDStructAmend { e; fields; _ } ->
|
| EDStructAmend { e; fields; _ } ->
|
||||||
acc |> f e |> Ident.Map.fold (fun _ -> f) fields
|
acc |> f e |> Ident.Map.fold (fun _ -> f) fields
|
||||||
@ -460,11 +451,6 @@ let map_gather
|
|||||||
| EErrorOnEmpty e ->
|
| EErrorOnEmpty e ->
|
||||||
let acc, e = f e in
|
let acc, e = f e in
|
||||||
acc, eerroronempty e m
|
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
|
| ELocation loc -> acc, elocation loc m
|
||||||
| EStruct { name; fields } ->
|
| EStruct { name; fields } ->
|
||||||
let acc, 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) =
|
let is_value (type a) (e : (a, _) gexpr) =
|
||||||
match Mark.remove e with
|
match Mark.remove e with
|
||||||
| ELit _ | EAbs _ | ERaiseEmpty | ECustom _ | EExternal _ -> true
|
| ELit _ | EAbs _ | ECustom _ | EExternal _ -> true
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
let equal_lit (l1 : lit) (l2 : lit) =
|
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
|
equal if1 if2 && equal then1 then2 && equal else1 else2
|
||||||
| EEmpty, EEmpty -> true
|
| EEmpty, EEmpty -> true
|
||||||
| EErrorOnEmpty e1, EErrorOnEmpty e2 -> equal e1 e2
|
| 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 ->
|
| ELocation l1, ELocation l2 ->
|
||||||
equal_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2)
|
equal_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2)
|
||||||
| ( EStruct { name = s1; fields = fields1 },
|
| ( 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
|
Type.equal_list targs1 targs2 && Type.equal tret1 tret2 && obj1 == obj2
|
||||||
| ( ( EVar _ | EExternal _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _
|
| ( ( EVar _ | EExternal _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _
|
||||||
| EAbs _ | EApp _ | EAppOp _ | EAssert _ | EFatalError _ | EDefault _
|
| EAbs _ | EApp _ | EAppOp _ | EAssert _ | EFatalError _ | EDefault _
|
||||||
| EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ERaiseEmpty
|
| EPureDefault _ | EIfThenElse _ | EEmpty | EErrorOnEmpty _ | ELocation _
|
||||||
| ECatchEmpty _ | ELocation _ | EStruct _ | EDStructAmend _
|
| EStruct _ | EDStructAmend _ | EDStructAccess _ | EStructAccess _
|
||||||
| EDStructAccess _ | EStructAccess _ | EInj _ | EMatch _ | EScopeCall _
|
| EInj _ | EMatch _ | EScopeCall _ | ECustom _ ),
|
||||||
| ECustom _ ),
|
|
||||||
_ ) ->
|
_ ) ->
|
||||||
false
|
false
|
||||||
|
|
||||||
@ -796,11 +777,6 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
|
|||||||
| EEmpty, EEmpty -> 0
|
| EEmpty, EEmpty -> 0
|
||||||
| EErrorOnEmpty e1, EErrorOnEmpty e2 ->
|
| EErrorOnEmpty e1, EErrorOnEmpty e2 ->
|
||||||
compare e1 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 _ ->
|
| ECustom _, _ | _, ECustom _ ->
|
||||||
(* fixme: ideally this would be forbidden by typing *)
|
(* fixme: ideally this would be forbidden by typing *)
|
||||||
invalid_arg "Custom block comparison"
|
invalid_arg "Custom block comparison"
|
||||||
@ -827,9 +803,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
|
|||||||
| EDefault _, _ -> -1 | _, EDefault _ -> 1
|
| EDefault _, _ -> -1 | _, EDefault _ -> 1
|
||||||
| EPureDefault _, _ -> -1 | _, EPureDefault _ -> 1
|
| EPureDefault _, _ -> -1 | _, EPureDefault _ -> 1
|
||||||
| EEmpty , _ -> -1 | _, EEmpty -> 1
|
| EEmpty , _ -> -1 | _, EEmpty -> 1
|
||||||
| EErrorOnEmpty _, _ -> -1 | _, EErrorOnEmpty _ -> 1
|
| EErrorOnEmpty _, _ -> . | _, EErrorOnEmpty _ -> .
|
||||||
| ERaiseEmpty, _ -> -1 | _, ERaiseEmpty -> 1
|
|
||||||
| ECatchEmpty _, _ -> . | _, ECatchEmpty _ -> .
|
|
||||||
|
|
||||||
let rec free_vars : ('a, 't) gexpr -> ('a, 't) gexpr Var.Set.t = function
|
let rec free_vars : ('a, 't) gexpr -> ('a, 't) gexpr Var.Set.t = function
|
||||||
| EVar v, _ -> Var.Set.singleton v
|
| 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)
|
(fun acc except -> acc + size except)
|
||||||
(1 + size just + size cons)
|
(1 + size just + size cons)
|
||||||
excepts
|
excepts
|
||||||
| ERaiseEmpty -> 1
|
|
||||||
| ECatchEmpty { body; handler } -> 1 + size body + size handler
|
|
||||||
| ELocation _ -> 1
|
| ELocation _ -> 1
|
||||||
| EStruct { fields; _ } ->
|
| EStruct { fields; _ } ->
|
||||||
StructField.Map.fold (fun _ e acc -> acc + 1 + size e) fields 0
|
StructField.Map.fold (fun _ e acc -> acc + 1 + size e) fields 0
|
||||||
|
@ -117,13 +117,6 @@ val eerroronempty :
|
|||||||
'm mark ->
|
'm mark ->
|
||||||
((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr
|
((< 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 elocation : 'a glocation -> 'm mark -> ((< .. > as 'a), 'm) boxed_gexpr
|
||||||
|
|
||||||
val estruct :
|
val estruct :
|
||||||
|
@ -422,36 +422,7 @@ let rec evaluate_operator
|
|||||||
ELit (LBool (o_eq_dat_dat x y))
|
ELit (LBool (o_eq_dat_dat x y))
|
||||||
| Eq_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] ->
|
| Eq_dur_dur, [(ELit (LDuration x), _); (ELit (LDuration y), _)] ->
|
||||||
ELit (LBool (o_eq_dur_dur (rpos ()) x y))
|
ELit (LBool (o_eq_dur_dur (rpos ()) x y))
|
||||||
| HandleDefault, [(EArray excepts, _); just; cons] -> (
|
| HandleExceptions, [(EArray exps, _)] -> (
|
||||||
(* 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] -> (
|
|
||||||
let valid_exceptions =
|
let valid_exceptions =
|
||||||
ListLabels.filter exps ~f:(function
|
ListLabels.filter exps ~f:(function
|
||||||
| EInj { name; cons; _ }, _ when EnumName.equal name Expr.option_enum ->
|
| EInj { name; cons; _ }, _ when EnumName.equal name Expr.option_enum ->
|
||||||
@ -459,28 +430,9 @@ let rec evaluate_operator
|
|||||||
| _ -> err ())
|
| _ -> err ())
|
||||||
in
|
in
|
||||||
match valid_exceptions with
|
match valid_exceptions with
|
||||||
| [] -> (
|
| [] ->
|
||||||
let e = evaluate_expr (Expr.unthunk_term_nobox justification) in
|
EInj
|
||||||
match Mark.remove e with
|
{ name = Expr.option_enum; cons = Expr.none_constr; e = ELit LUnit, m }
|
||||||
| 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 { cons; name; _ } as e), _)]
|
| [((EInj { cons; name; _ } as e), _)]
|
||||||
when EnumName.equal name Expr.option_enum
|
when EnumName.equal name Expr.option_enum
|
||||||
&& EnumConstructor.equal cons Expr.some_constr ->
|
&& 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
|
| 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
|
| 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
|
| 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 ()
|
err ()
|
||||||
|
|
||||||
(* /S\ dark magic here. This relies both on internals of [Lcalc.to_ocaml] *and*
|
(* /S\ dark magic here. This relies both on internals of [Lcalc.to_ocaml] *and*
|
||||||
of the OCaml runtime *)
|
of the OCaml runtime *)
|
||||||
let rec runtime_to_val :
|
let rec runtime_to_val :
|
||||||
type d e.
|
type d.
|
||||||
(decl_ctx ->
|
(decl_ctx ->
|
||||||
((d, e, _) interpr_kind, 'm) gexpr ->
|
((d, _) interpr_kind, 'm) gexpr ->
|
||||||
((d, e, _) interpr_kind, 'm) gexpr) ->
|
((d, _) interpr_kind, 'm) gexpr) ->
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
'm mark ->
|
'm mark ->
|
||||||
typ ->
|
typ ->
|
||||||
Obj.t ->
|
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 ->
|
fun eval_expr ctx m ty o ->
|
||||||
let m = Expr.map_ty (fun _ -> ty) m in
|
let m = Expr.map_ty (fun _ -> ty) m in
|
||||||
match Mark.remove ty with
|
match Mark.remove ty with
|
||||||
@ -578,21 +529,26 @@ let rec runtime_to_val :
|
|||||||
(Array.to_list (Obj.obj o))),
|
(Array.to_list (Obj.obj o))),
|
||||||
m )
|
m )
|
||||||
| TArrow (targs, tret) -> ECustom { obj = o; targs; tret }, 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
|
| TAny -> assert false
|
||||||
|
|
||||||
and val_to_runtime :
|
and val_to_runtime :
|
||||||
type d e.
|
type d.
|
||||||
(decl_ctx ->
|
(decl_ctx ->
|
||||||
((d, e, _) interpr_kind, 'm) gexpr ->
|
((d, _) interpr_kind, 'm) gexpr ->
|
||||||
((d, e, _) interpr_kind, 'm) gexpr) ->
|
((d, _) interpr_kind, 'm) gexpr) ->
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
typ ->
|
typ ->
|
||||||
((d, e, _) interpr_kind, 'm) gexpr ->
|
((d, _) interpr_kind, 'm) gexpr ->
|
||||||
Obj.t =
|
Obj.t =
|
||||||
fun eval_expr ctx ty v ->
|
fun eval_expr ctx ty v ->
|
||||||
match Mark.remove ty, Mark.remove v with
|
match Mark.remove ty, Mark.remove v with
|
||||||
| _, EEmpty -> raise Runtime.Empty
|
|
||||||
| TLit TBool, ELit (LBool b) -> Obj.repr b
|
| TLit TBool, ELit (LBool b) -> Obj.repr b
|
||||||
| TLit TUnit, ELit LUnit -> Obj.repr ()
|
| TLit TUnit, ELit LUnit -> Obj.repr ()
|
||||||
| TLit TInt, ELit (LInt i) -> Obj.repr i
|
| 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)
|
curry (runtime_to_val eval_expr ctx m targ x :: acc) targs)
|
||||||
in
|
in
|
||||||
curry [] targs
|
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 ->
|
| TClosureEnv, v ->
|
||||||
(* By construction, a closure environment can only be consumed from the same
|
(* 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
|
scope where it was built (compiled or not) ; for this reason, we can
|
||||||
@ -671,11 +631,11 @@ and val_to_runtime :
|
|||||||
Expr.format v
|
Expr.format v
|
||||||
|
|
||||||
let rec evaluate_expr :
|
let rec evaluate_expr :
|
||||||
type d e.
|
type d.
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Global.backend_lang ->
|
Global.backend_lang ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr ->
|
((d, yes) interpr_kind, 't) gexpr ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr =
|
((d, yes) interpr_kind, 't) gexpr =
|
||||||
fun ctx lang e ->
|
fun ctx lang e ->
|
||||||
let m = Mark.get e in
|
let m = Mark.get e in
|
||||||
let pos = Expr.mark_pos m in
|
let pos = Expr.mark_pos m in
|
||||||
@ -875,18 +835,14 @@ let rec evaluate_expr :
|
|||||||
in
|
in
|
||||||
raise Runtime.(Error (Conflict, poslist)))
|
raise Runtime.(Error (Conflict, poslist)))
|
||||||
| EPureDefault e -> evaluate_expr ctx lang e
|
| 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 :
|
and partially_evaluate_expr_for_assertion_failure_message :
|
||||||
type d e.
|
type d.
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Global.backend_lang ->
|
Global.backend_lang ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr ->
|
((d, yes) interpr_kind, 't) gexpr ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr =
|
((d, yes) interpr_kind, 't) gexpr =
|
||||||
fun ctx lang e ->
|
fun ctx lang e ->
|
||||||
(* Here we want to print an expression that explains why an assertion has
|
(* Here we want to print an expression that explains why an assertion has
|
||||||
failed. Since assertions have type [bool] and are usually constructed with
|
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
|
| _ -> evaluate_expr ctx lang e
|
||||||
|
|
||||||
let evaluate_expr_trace :
|
let evaluate_expr_trace :
|
||||||
type d e.
|
type d.
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Global.backend_lang ->
|
Global.backend_lang ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr ->
|
((d, yes) interpr_kind, 't) gexpr ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr =
|
((d, yes) interpr_kind, 't) gexpr =
|
||||||
fun ctx lang e ->
|
fun ctx lang e ->
|
||||||
Fun.protect
|
Fun.protect
|
||||||
(fun () -> evaluate_expr ctx lang e)
|
(fun () -> evaluate_expr ctx lang e)
|
||||||
@ -937,11 +893,11 @@ let evaluate_expr_trace :
|
|||||||
(Runtime.EventParser.parse_raw_events trace)] fais here, check why *))
|
(Runtime.EventParser.parse_raw_events trace)] fais here, check why *))
|
||||||
|
|
||||||
let evaluate_expr_safe :
|
let evaluate_expr_safe :
|
||||||
type d e.
|
type d.
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Global.backend_lang ->
|
Global.backend_lang ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr ->
|
((d, yes) interpr_kind, 't) gexpr ->
|
||||||
((d, e, yes) interpr_kind, 't) gexpr =
|
((d, yes) interpr_kind, 't) gexpr =
|
||||||
fun ctx lang e ->
|
fun ctx lang e ->
|
||||||
try evaluate_expr_trace ctx lang e
|
try evaluate_expr_trace ctx lang e
|
||||||
with Runtime.Error (err, rpos) ->
|
with Runtime.Error (err, rpos) ->
|
||||||
@ -953,9 +909,9 @@ let evaluate_expr_safe :
|
|||||||
(* Typing shenanigan to add custom terms to the AST type. *)
|
(* Typing shenanigan to add custom terms to the AST type. *)
|
||||||
let addcustom e =
|
let addcustom e =
|
||||||
let rec f :
|
let rec f :
|
||||||
type c d e.
|
type c d.
|
||||||
((d, e, c) interpr_kind, 't) gexpr ->
|
((d, c) interpr_kind, 't) gexpr -> ((d, yes) interpr_kind, 't) gexpr boxed
|
||||||
((d, e, yes) interpr_kind, 't) gexpr boxed = function
|
= function
|
||||||
| (ECustom _, _) as e -> Expr.map ~f e
|
| (ECustom _, _) as e -> Expr.map ~f e
|
||||||
| EAppOp { op; tys; args }, m ->
|
| EAppOp { op; tys; args }, m ->
|
||||||
Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) 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
|
| (EPureDefault _, _) as e -> Expr.map ~f e
|
||||||
| (EEmpty, _) as e -> Expr.map ~f e
|
| (EEmpty, _) as e -> Expr.map ~f e
|
||||||
| (EErrorOnEmpty _, _) 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 _
|
| ( ( EAssert _ | EFatalError _ | ELit _ | EApp _ | EArray _ | EVar _
|
||||||
| EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _
|
| EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _
|
||||||
| EInj _ | EStruct _ | EStructAccess _ | EMatch _ ),
|
| EInj _ | EStruct _ | EStructAccess _ | EMatch _ ),
|
||||||
@ -974,8 +928,8 @@ let addcustom e =
|
|||||||
in
|
in
|
||||||
let open struct
|
let open struct
|
||||||
external id :
|
external id :
|
||||||
(('d, 'e, 'c) interpr_kind, 't) gexpr ->
|
(('d, 'c) interpr_kind, 't) gexpr -> (('d, yes) interpr_kind, 't) gexpr
|
||||||
(('d, 'e, yes) interpr_kind, 't) gexpr = "%identity"
|
= "%identity"
|
||||||
end in
|
end in
|
||||||
if false then Expr.unbox (f e)
|
if false then Expr.unbox (f e)
|
||||||
(* We keep the implementation as a typing proof, but bypass the AST
|
(* We keep the implementation as a typing proof, but bypass the AST
|
||||||
@ -985,9 +939,9 @@ let addcustom e =
|
|||||||
|
|
||||||
let delcustom e =
|
let delcustom e =
|
||||||
let rec f :
|
let rec f :
|
||||||
type c d e.
|
type c d.
|
||||||
((d, e, c) interpr_kind, 't) gexpr ->
|
((d, c) interpr_kind, 't) gexpr -> ((d, no) interpr_kind, 't) gexpr boxed
|
||||||
((d, e, no) interpr_kind, 't) gexpr boxed = function
|
= function
|
||||||
| ECustom _, _ -> invalid_arg "Custom term remaining in evaluated term"
|
| ECustom _, _ -> invalid_arg "Custom term remaining in evaluated term"
|
||||||
| EAppOp { op; args; tys }, m ->
|
| EAppOp { op; args; tys }, m ->
|
||||||
Expr.eappop ~tys ~args:(List.map f args) ~op:(Operator.translate op) 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
|
| (EPureDefault _, _) as e -> Expr.map ~f e
|
||||||
| (EEmpty, _) as e -> Expr.map ~f e
|
| (EEmpty, _) as e -> Expr.map ~f e
|
||||||
| (EErrorOnEmpty _, _) 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 _
|
| ( ( EAssert _ | EFatalError _ | ELit _ | EApp _ | EArray _ | EVar _
|
||||||
| EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _
|
| EExternal _ | EAbs _ | EIfThenElse _ | ETuple _ | ETupleAccess _
|
||||||
| EInj _ | EStruct _ | EStructAccess _ | EMatch _ ),
|
| EInj _ | EStruct _ | EStructAccess _ | EMatch _ ),
|
||||||
@ -1027,22 +979,13 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
|
|||||||
(fun ty ->
|
(fun ty ->
|
||||||
match Mark.remove ty with
|
match Mark.remove ty with
|
||||||
| TArrow (ty_in, (TOption _, _)) ->
|
| TArrow (ty_in, (TOption _, _)) ->
|
||||||
(* Context args may return an option if avoid_exceptions is on *)
|
(* Context args should return an option *)
|
||||||
Expr.make_abs
|
Expr.make_abs
|
||||||
(Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in)
|
(Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in)
|
||||||
(Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr
|
(Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr
|
||||||
~name:Expr.option_enum mark_e
|
~name:Expr.option_enum mark_e
|
||||||
: (_, _) boxed_gexpr)
|
: (_, _) boxed_gexpr)
|
||||||
ty_in pos
|
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 _, _)), _) :: _) ->
|
| TTuple ((TArrow (ty_in, (TOption _, _)), _) :: _) ->
|
||||||
(* ... or a closure if closure conversion is enabled *)
|
(* ... or a closure if closure conversion is enabled *)
|
||||||
Expr.make_tuple
|
Expr.make_tuple
|
||||||
|
@ -21,7 +21,7 @@ open Catala_utils
|
|||||||
open Definitions
|
open Definitions
|
||||||
|
|
||||||
val evaluate_operator :
|
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 ->
|
'a operator Mark.pos ->
|
||||||
'm mark ->
|
'm mark ->
|
||||||
Global.backend_lang ->
|
Global.backend_lang ->
|
||||||
@ -35,14 +35,14 @@ val evaluate_operator :
|
|||||||
val evaluate_expr :
|
val evaluate_expr :
|
||||||
decl_ctx ->
|
decl_ctx ->
|
||||||
Global.backend_lang ->
|
Global.backend_lang ->
|
||||||
(('a, 'b, _) interpr_kind, 'm) gexpr ->
|
(('a, _) interpr_kind, 'm) gexpr ->
|
||||||
(('a, 'b, yes) interpr_kind, 'm) gexpr
|
(('a, yes) interpr_kind, 'm) gexpr
|
||||||
(** Evaluates an expression according to the semantics of the default calculus. *)
|
(** Evaluates an expression according to the semantics of the default calculus. *)
|
||||||
|
|
||||||
val interpret_program_dcalc :
|
val interpret_program_dcalc :
|
||||||
(dcalc, 'm) gexpr program ->
|
(dcalc, 'm) gexpr program ->
|
||||||
ScopeName.t ->
|
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
|
(** Interprets a program. This function expects an expression typed as a
|
||||||
function whose argument are all thunked. The function is executed by
|
function whose argument are all thunked. The function is executed by
|
||||||
providing for each argument a thunked empty default. Returns a list of all
|
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 :
|
val interpret_program_lcalc :
|
||||||
(lcalc, 'm) gexpr program ->
|
(lcalc, 'm) gexpr program ->
|
||||||
ScopeName.t ->
|
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
|
(** Interprets a program. This function expects an expression typed as a
|
||||||
function whose argument are all thunked. The function is executed by
|
function whose argument are all thunked. The function is executed by
|
||||||
providing for each argument a thunked empty default. Returns a list of all
|
providing for each argument a thunked empty default. Returns a list of all
|
||||||
the computed values for the scope variables of the executed scope. *)
|
the computed values for the scope variables of the executed scope. *)
|
||||||
|
|
||||||
val delcustom :
|
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
|
(** Runtime check that the term contains no custom terms (raises
|
||||||
[Invalid_argument] if that is the case *)
|
[Invalid_argument] if that is the case *)
|
||||||
|
|
||||||
|
@ -108,8 +108,7 @@ let name : type a. a t -> string = function
|
|||||||
| Eq_dur_dur -> "o_eq_dur_dur"
|
| Eq_dur_dur -> "o_eq_dur_dur"
|
||||||
| Eq_dat_dat -> "o_eq_dat_dat"
|
| Eq_dat_dat -> "o_eq_dat_dat"
|
||||||
| Fold -> "o_fold"
|
| Fold -> "o_fold"
|
||||||
| HandleDefault -> "o_handledefault"
|
| HandleExceptions -> "handle_exceptions"
|
||||||
| HandleDefaultOpt -> "o_handledefaultopt"
|
|
||||||
| ToClosureEnv -> "o_toclosureenv"
|
| ToClosureEnv -> "o_toclosureenv"
|
||||||
| FromClosureEnv -> "o_fromclosureenv"
|
| 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_dat_dat, Eq_dat_dat
|
||||||
| Eq_dur_dur, Eq_dur_dur
|
| Eq_dur_dur, Eq_dur_dur
|
||||||
| Fold, Fold
|
| Fold, Fold
|
||||||
| HandleDefault, HandleDefault
|
| HandleExceptions, HandleExceptions
|
||||||
| HandleDefaultOpt, HandleDefaultOpt
|
|
||||||
| FromClosureEnv, FromClosureEnv | ToClosureEnv, ToClosureEnv -> 0
|
| FromClosureEnv, FromClosureEnv | ToClosureEnv, ToClosureEnv -> 0
|
||||||
| Not, _ -> -1 | _, Not -> 1
|
| Not, _ -> -1 | _, Not -> 1
|
||||||
| Length, _ -> -1 | _, Length -> 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_mon_mon, _ -> -1 | _, Eq_mon_mon -> 1
|
||||||
| Eq_dat_dat, _ -> -1 | _, Eq_dat_dat -> 1
|
| Eq_dat_dat, _ -> -1 | _, Eq_dat_dat -> 1
|
||||||
| Eq_dur_dur, _ -> -1 | _, Eq_dur_dur -> 1
|
| Eq_dur_dur, _ -> -1 | _, Eq_dur_dur -> 1
|
||||||
| HandleDefault, _ -> -1 | _, HandleDefault -> 1
|
| HandleExceptions, _ -> -1 | _, HandleExceptions -> 1
|
||||||
| HandleDefaultOpt, _ -> -1 | _, HandleDefaultOpt -> 1
|
|
||||||
| FromClosureEnv, _ -> -1 | _, FromClosureEnv -> 1
|
| FromClosureEnv, _ -> -1 | _, FromClosureEnv -> 1
|
||||||
| ToClosureEnv, _ -> -1 | _, ToClosureEnv -> 1
|
| ToClosureEnv, _ -> -1 | _, ToClosureEnv -> 1
|
||||||
| Fold, _ | _, Fold -> .
|
| Fold, _ | _, Fold -> .
|
||||||
@ -344,7 +341,7 @@ let kind_dispatch :
|
|||||||
_ ) as op ->
|
_ ) as op ->
|
||||||
monomorphic op
|
monomorphic op
|
||||||
| ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold
|
| ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold
|
||||||
| HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ),
|
| HandleExceptions | FromClosureEnv | ToClosureEnv ),
|
||||||
_ ) as op ->
|
_ ) as op ->
|
||||||
polymorphic op
|
polymorphic op
|
||||||
| ( ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt
|
| ( ( 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 =
|
let translate (t : 'a no_overloads t Mark.pos) : 'b no_overloads t Mark.pos =
|
||||||
match t with
|
match t with
|
||||||
| ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
|
| ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
|
||||||
| And | Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq
|
| And | Or | Xor | HandleExceptions | Log _ | Length | Eq | Map | Map2
|
||||||
| Map | Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat
|
| Concat | Filter | Reduce | Fold | Minus_int | Minus_rat | Minus_mon
|
||||||
| Minus_mon | Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat
|
| Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat | Round_mon
|
||||||
| Round_mon | Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _
|
| Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _ | Add_dur_dur
|
||||||
| Add_dur_dur | Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat
|
| Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat | Sub_dat_dur
|
||||||
| Sub_dat_dur | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat
|
| Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat | Mult_dur_int
|
||||||
| Mult_dur_int | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat
|
| Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat | Div_dur_dur
|
||||||
| Div_dur_dur | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat
|
| Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat | Lt_dur_dur
|
||||||
| Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat
|
| Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat | Lte_dur_dur
|
||||||
| Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat
|
| Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat | Gt_dur_dur
|
||||||
| Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat
|
| Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat | Gte_dur_dur
|
||||||
| Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat
|
| Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat | Eq_dur_dur
|
||||||
| Eq_dur_dur | FromClosureEnv | ToClosureEnv ),
|
| FromClosureEnv | ToClosureEnv ),
|
||||||
_ ) as op ->
|
_ ) as op ->
|
||||||
op
|
op
|
||||||
|
|
||||||
|
@ -58,14 +58,14 @@ let all_match_cases_map_to_same_constructor cases n =
|
|||||||
|
|
||||||
let binder_vars_used_at_most_once
|
let binder_vars_used_at_most_once
|
||||||
(binder :
|
(binder :
|
||||||
( (('a, 'b) dcalc_lcalc, ('a, 'b) dcalc_lcalc, 'm) base_gexpr,
|
( ('a dcalc_lcalc, 'a dcalc_lcalc, 'm) base_gexpr,
|
||||||
(('a, 'b) dcalc_lcalc, 'm) gexpr )
|
('a dcalc_lcalc, 'm) gexpr )
|
||||||
Bindlib.mbinder) : bool =
|
Bindlib.mbinder) : bool =
|
||||||
(* fast path: variables not used at all *)
|
(* fast path: variables not used at all *)
|
||||||
(not (Array.exists Fun.id (Bindlib.mbinder_occurs binder)))
|
(not (Array.exists Fun.id (Bindlib.mbinder_occurs binder)))
|
||||||
||
|
||
|
||||||
let vars, body = Bindlib.unmbind binder in
|
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
|
match e with
|
||||||
| EVar v, _ ->
|
| EVar v, _ ->
|
||||||
Array.map
|
Array.map
|
||||||
@ -82,8 +82,8 @@ let binder_vars_used_at_most_once
|
|||||||
let rec optimize_expr :
|
let rec optimize_expr :
|
||||||
type a b.
|
type a b.
|
||||||
(a, b, 'm) optimizations_ctx ->
|
(a, b, 'm) optimizations_ctx ->
|
||||||
((a, b) dcalc_lcalc, 'm) gexpr ->
|
(a dcalc_lcalc, 'm) gexpr ->
|
||||||
((a, b) dcalc_lcalc, 'm) boxed_gexpr =
|
(a dcalc_lcalc, 'm) boxed_gexpr =
|
||||||
fun ctx e ->
|
fun ctx e ->
|
||||||
(* We proceed bottom-up, first apply on the subterms *)
|
(* We proceed bottom-up, first apply on the subterms *)
|
||||||
let e = Expr.map ~f:(optimize_expr ctx) ~op:Fun.id e in
|
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) *)
|
able to keep the inner position (see the division_by_zero test) *)
|
||||||
(* Then reduce the parent node (this is applied through Box.apply, therefore
|
(* Then reduce the parent node (this is applied through Box.apply, therefore
|
||||||
delayed to unbinding time: no need to be concerned about reboxing) *)
|
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
|
(* 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
|
the matches and the log calls are not preserved, which would be a good
|
||||||
property *)
|
property *)
|
||||||
@ -365,22 +365,15 @@ let rec optimize_expr :
|
|||||||
el) ->
|
el) ->
|
||||||
(* identity tuple reconstruction *)
|
(* identity tuple reconstruction *)
|
||||||
Mark.remove e
|
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
|
| e -> e
|
||||||
in
|
in
|
||||||
Expr.Box.app1 e reduce mark
|
Expr.Box.app1 e reduce mark
|
||||||
|
|
||||||
let optimize_expr :
|
let optimize_expr :
|
||||||
'm.
|
'm.
|
||||||
decl_ctx ->
|
decl_ctx -> ('a dcalc_lcalc, 'm) gexpr -> ('a dcalc_lcalc, 'm) boxed_gexpr
|
||||||
(('a, 'b) dcalc_lcalc, 'm) gexpr ->
|
=
|
||||||
(('a, 'b) dcalc_lcalc, 'm) boxed_gexpr =
|
fun (decl_ctx : decl_ctx) (e : ('a dcalc_lcalc, 'm) gexpr) ->
|
||||||
fun (decl_ctx : decl_ctx) (e : (('a, 'b) dcalc_lcalc, 'm) gexpr) ->
|
|
||||||
optimize_expr { decl_ctx } e
|
optimize_expr { decl_ctx } e
|
||||||
|
|
||||||
let optimize_program (p : 'm program) : 'm program =
|
let optimize_program (p : 'm program) : 'm program =
|
||||||
|
@ -21,13 +21,10 @@
|
|||||||
open Definitions
|
open Definitions
|
||||||
|
|
||||||
val optimize_expr :
|
val optimize_expr :
|
||||||
decl_ctx ->
|
decl_ctx -> ('a dcalc_lcalc, 'm) gexpr -> ('a dcalc_lcalc, 'm) boxed_gexpr
|
||||||
(('a, 'b) dcalc_lcalc, 'm) gexpr ->
|
|
||||||
(('a, 'b) dcalc_lcalc, 'm) boxed_gexpr
|
|
||||||
|
|
||||||
val optimize_program :
|
val optimize_program :
|
||||||
(('a, 'b) dcalc_lcalc, 'm) gexpr program ->
|
('a dcalc_lcalc, 'm) gexpr program -> ('a dcalc_lcalc, 'm) gexpr program
|
||||||
(('a, 'b) dcalc_lcalc, 'm) gexpr program
|
|
||||||
|
|
||||||
(** {1 Tests}*)
|
(** {1 Tests}*)
|
||||||
|
|
||||||
|
@ -142,7 +142,7 @@ let rec typ_gen
|
|||||||
mty))
|
mty))
|
||||||
def punctuation "]")
|
def punctuation "]")
|
||||||
| TOption t ->
|
| 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) ->
|
| TArrow ([t1], t2) ->
|
||||||
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" (typ_with_parens ~colors) t1
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" (typ_with_parens ~colors) t1
|
||||||
op_style "→" (typ ~colors) t2
|
op_style "→" (typ ~colors) t2
|
||||||
@ -280,8 +280,7 @@ let operator_to_string : type a. a Op.t -> string =
|
|||||||
| Eq_dur_dur -> "=^"
|
| Eq_dur_dur -> "=^"
|
||||||
| Eq_dat_dat -> "=@"
|
| Eq_dat_dat -> "=@"
|
||||||
| Fold -> "fold"
|
| Fold -> "fold"
|
||||||
| HandleDefault -> "handle_default"
|
| HandleExceptions -> "handle_exceptions"
|
||||||
| HandleDefaultOpt -> "handle_default_opt"
|
|
||||||
| ToClosureEnv -> "to_closure_env"
|
| ToClosureEnv -> "to_closure_env"
|
||||||
| FromClosureEnv -> "from_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 ->
|
| Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dur_dur | Gte_dat_dat | Gte ->
|
||||||
">="
|
">="
|
||||||
| Fold -> "fold"
|
| Fold -> "fold"
|
||||||
| HandleDefault -> "handle_default"
|
| HandleExceptions -> "handle_exceptions"
|
||||||
| HandleDefaultOpt -> "handle_default_opt"
|
|
||||||
| ToClosureEnv -> "to_closure_env"
|
| ToClosureEnv -> "to_closure_env"
|
||||||
| FromClosureEnv -> "from_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 | Div_int_int | Div_rat_rat | Div_mon_rat | Div_mon_mon
|
||||||
| Div_dur_dur ->
|
| Div_dur_dur ->
|
||||||
Op Div
|
Op Div
|
||||||
| HandleDefault | HandleDefaultOpt | Map | Map2 | Concat | Filter | Reduce
|
| HandleExceptions | Map | Map2 | Concat | Filter | Reduce | Fold
|
||||||
| Fold | ToClosureEnv | FromClosureEnv ->
|
| ToClosureEnv | FromClosureEnv ->
|
||||||
App)
|
App)
|
||||||
| EApp _ -> App
|
| EApp _ -> App
|
||||||
| EArray _ -> Contained
|
| EArray _ -> Contained
|
||||||
@ -426,8 +424,6 @@ module Precedence = struct
|
|||||||
| EPureDefault _ -> Contained
|
| EPureDefault _ -> Contained
|
||||||
| EEmpty -> Contained
|
| EEmpty -> Contained
|
||||||
| EErrorOnEmpty _ -> App
|
| EErrorOnEmpty _ -> App
|
||||||
| ERaiseEmpty -> App
|
|
||||||
| ECatchEmpty _ -> App
|
|
||||||
| ECustom _ -> Contained
|
| ECustom _ -> Contained
|
||||||
|
|
||||||
let needs_parens ~context ?(rhs = false) e =
|
let needs_parens ~context ?(rhs = false) e =
|
||||||
@ -671,12 +667,6 @@ module ExprGen (C : EXPR_PARAM) = struct
|
|||||||
| EFatalError err ->
|
| EFatalError err ->
|
||||||
Format.fprintf fmt "@[<hov 2>%a@ @{<red>%s@}@]" keyword "error"
|
Format.fprintf fmt "@[<hov 2>%a@ @{<red>%s@}@]" keyword "error"
|
||||||
(Runtime.error_to_string err)
|
(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
|
| ELocation loc -> location fmt loc
|
||||||
| EDStructAccess { e; field; _ } ->
|
| EDStructAccess { e; field; _ } ->
|
||||||
Format.fprintf fmt "@[<hv 2>%a%a@,%a%a%a@]" (lhs exprc) e punctuation
|
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
|
Format.fprintf fmt "@[<v 0>@[<hv 2>%a@ %a@;<1 -2>%a@]@ %a@]" keyword
|
||||||
"match" (lhs exprc) e keyword "with"
|
"match" (lhs exprc) e keyword "with"
|
||||||
(EnumConstructor.Map.format_bindings
|
(EnumConstructor.Map.format_bindings
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
|
||||||
(fun fmt pp_cons_name case_expr ->
|
(fun fmt pp_cons_name case_expr ->
|
||||||
match case_expr with
|
match case_expr with
|
||||||
| EAbs { binder; tys; _ }, _ ->
|
| EAbs { binder; tys; _ }, _ ->
|
||||||
@ -868,13 +857,12 @@ let enum
|
|||||||
fmt
|
fmt
|
||||||
(pp_name : Format.formatter -> unit)
|
(pp_name : Format.formatter -> unit)
|
||||||
(c : typ EnumConstructor.Map.t) =
|
(c : typ EnumConstructor.Map.t) =
|
||||||
Format.fprintf fmt "@[<h 0>%a %t %a@ %a@]" keyword "type" pp_name punctuation
|
Format.fprintf fmt "@[<h 0>%a %t %a@ %a@]@," keyword "type" pp_name
|
||||||
"="
|
punctuation "="
|
||||||
(EnumConstructor.Map.format_bindings
|
(EnumConstructor.Map.format_bindings ~pp_sep:Format.pp_print_space
|
||||||
~pp_sep:(fun _ _ -> ())
|
|
||||||
(fun fmt pp_n ty ->
|
(fun fmt pp_n ty ->
|
||||||
Format.fprintf fmt "@[<hov2> %a %t %a %a@]@;" punctuation "|" pp_n
|
Format.fprintf fmt "@[<hov2>%a %t %a %a@]" punctuation "|" pp_n keyword
|
||||||
keyword "of"
|
"of"
|
||||||
(if debug then typ_debug else typ decl_ctx)
|
(if debug then typ_debug else typ decl_ctx)
|
||||||
ty))
|
ty))
|
||||||
c
|
c
|
||||||
@ -897,14 +885,10 @@ let struct_
|
|||||||
let decl_ctx ?(debug = false) decl_ctx (fmt : Format.formatter) (ctx : decl_ctx)
|
let decl_ctx ?(debug = false) decl_ctx (fmt : Format.formatter) (ctx : decl_ctx)
|
||||||
: unit =
|
: unit =
|
||||||
let { ctx_enums; ctx_structs; _ } = ctx in
|
let { ctx_enums; ctx_structs; _ } = ctx in
|
||||||
Format.fprintf fmt "%a@.%a@.@."
|
Format.fprintf fmt "@[<v>%a@,%a@,@,@]"
|
||||||
(EnumName.Map.format_bindings
|
(EnumName.Map.format_bindings (enum ~debug decl_ctx))
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@.")
|
|
||||||
(enum ~debug decl_ctx))
|
|
||||||
ctx_enums
|
ctx_enums
|
||||||
(StructName.Map.format_bindings
|
(StructName.Map.format_bindings (struct_ ~debug decl_ctx))
|
||||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@.")
|
|
||||||
(struct_ ~debug decl_ctx))
|
|
||||||
ctx_structs
|
ctx_structs
|
||||||
|
|
||||||
let scope
|
let scope
|
||||||
@ -936,11 +920,15 @@ let code_item ?(debug = false) ?name decl_ctx fmt c =
|
|||||||
"=" (expr ~debug ()) e
|
"=" (expr ~debug ()) e
|
||||||
|
|
||||||
let code_item_list ?(debug = false) decl_ctx fmt c =
|
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
|
code_item ~debug
|
||||||
~name:(Format.asprintf "%a" var_debug x)
|
~name:(Format.asprintf "%a" var_debug x)
|
||||||
decl_ctx fmt item;
|
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 =
|
let program ?(debug = false) fmt p =
|
||||||
decl_ctx ~debug p.decl_ctx fmt p.decl_ctx;
|
decl_ctx ~debug p.decl_ctx fmt p.decl_ctx;
|
||||||
@ -1136,8 +1124,8 @@ module UserFacing = struct
|
|||||||
| EExternal _ -> Format.pp_print_string ppf "<external>"
|
| EExternal _ -> Format.pp_print_string ppf "<external>"
|
||||||
| EApp _ | EAppOp _ | EVar _ | EIfThenElse _ | EMatch _ | ETupleAccess _
|
| EApp _ | EAppOp _ | EVar _ | EIfThenElse _ | EMatch _ | ETupleAccess _
|
||||||
| EStructAccess _ | EAssert _ | EFatalError _ | EDefault _ | EPureDefault _
|
| EStructAccess _ | EAssert _ | EFatalError _ | EDefault _ | EPureDefault _
|
||||||
| EErrorOnEmpty _ | ERaiseEmpty | ECatchEmpty _ | ELocation _ | EScopeCall _
|
| EErrorOnEmpty _ | ELocation _ | EScopeCall _ | EDStructAmend _
|
||||||
| EDStructAmend _ | EDStructAccess _ | ECustom _ ->
|
| EDStructAccess _ | ECustom _ ->
|
||||||
fallback ppf e
|
fallback ppf e
|
||||||
|
|
||||||
let expr :
|
let expr :
|
||||||
|
@ -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 any2 = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in
|
||||||
let any3 = 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 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 it = lazy (UnionFind.make (TLit TInt, pos)) in
|
||||||
let cet = lazy (UnionFind.make (TClosureEnv, pos)) in
|
let cet = lazy (UnionFind.make (TClosureEnv, pos)) in
|
||||||
let array a = lazy (UnionFind.make (TArray (Lazy.force a), 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 (PosRecordIfTrueBool, _) -> [bt] @-> bt
|
||||||
| Log _ -> [any] @-> any
|
| Log _ -> [any] @-> any
|
||||||
| Length -> [array any] @-> it
|
| Length -> [array any] @-> it
|
||||||
| HandleDefault -> [array ([ut] @-> any); [ut] @-> bt; [ut] @-> any] @-> any
|
| HandleExceptions -> [array (option any)] @-> option any
|
||||||
| HandleDefaultOpt ->
|
|
||||||
[array (option any); [ut] @-> bt; [ut] @-> option any] @-> option any
|
|
||||||
| ToClosureEnv -> [any] @-> cet
|
| ToClosureEnv -> [any] @-> cet
|
||||||
| FromClosureEnv -> [cet] @-> any
|
| FromClosureEnv -> [cet] @-> any
|
||||||
in
|
in
|
||||||
@ -348,7 +345,7 @@ let polymorphic_op_return_type
|
|||||||
| Log (PosRecordIfTrueBool, _), _ -> uf (TLit TBool)
|
| Log (PosRecordIfTrueBool, _), _ -> uf (TLit TBool)
|
||||||
| Log _, [tau] -> tau
|
| Log _, [tau] -> tau
|
||||||
| Length, _ -> uf (TLit TInt)
|
| Length, _ -> uf (TLit TInt)
|
||||||
| (HandleDefault | HandleDefaultOpt), [_; _; tf] -> return_type tf 1
|
| HandleExceptions, [_] -> any ()
|
||||||
| ToClosureEnv, _ -> uf TClosureEnv
|
| ToClosureEnv, _ -> uf TClosureEnv
|
||||||
| FromClosureEnv, _ -> any ()
|
| FromClosureEnv, _ -> any ()
|
||||||
| _ -> Message.error ~pos "Mismatched operator arguments"
|
| _ -> Message.error ~pos "Mismatched operator arguments"
|
||||||
@ -760,11 +757,6 @@ and typecheck_expr_top_down :
|
|||||||
args
|
args
|
||||||
in
|
in
|
||||||
Expr.escopecall ~scope ~args:args' mark
|
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 ->
|
| A.EVar v ->
|
||||||
let tau' =
|
let tau' =
|
||||||
match Env.get env v with
|
match Env.get env v with
|
||||||
@ -895,15 +887,17 @@ and typecheck_expr_top_down :
|
|||||||
let args =
|
let args =
|
||||||
Operator.kind_dispatch (Mark.set pos_e op)
|
Operator.kind_dispatch (Mark.set pos_e op)
|
||||||
~polymorphic:(fun op ->
|
~polymorphic:(fun op ->
|
||||||
(* Type the operator first, then right-to-left: polymorphic operators
|
if env.flags.assume_op_types then (
|
||||||
are required to allow the resolution of all type variables this
|
unify ctx e (polymorphic_op_return_type ctx e op t_args) tau;
|
||||||
way *)
|
List.rev_map (typecheck_expr_bottom_up ctx env) (List.rev args))
|
||||||
if not env.flags.assume_op_types then
|
else (
|
||||||
unify ctx e (polymorphic_op_type op) t_func
|
(* Type the operator first, then right-to-left: polymorphic
|
||||||
else unify ctx e (polymorphic_op_return_type ctx e op t_args) tau;
|
operators are required to allow the resolution of all type
|
||||||
List.rev_map2
|
variables this way *)
|
||||||
(typecheck_expr_top_down ctx env)
|
unify ctx e (polymorphic_op_type op) t_func;
|
||||||
(List.rev t_args) (List.rev args))
|
List.rev_map2
|
||||||
|
(typecheck_expr_top_down ctx env)
|
||||||
|
(List.rev t_args) (List.rev args)))
|
||||||
~overloaded:(fun op ->
|
~overloaded:(fun op ->
|
||||||
(* Typing the arguments first is required to resolve the operator *)
|
(* Typing the arguments first is required to resolve the operator *)
|
||||||
let args' = List.map2 (typecheck_expr_top_down ctx env) t_args args in
|
let args' = List.map2 (typecheck_expr_top_down ctx env) t_args args in
|
||||||
|
@ -716,32 +716,9 @@ module EventParser = struct
|
|||||||
ctx.events
|
ctx.events
|
||||||
end
|
end
|
||||||
|
|
||||||
let handle_default :
|
let handle_exceptions
|
||||||
'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
|
|
||||||
(pos : source_position array)
|
(pos : source_position array)
|
||||||
(exceptions : 'a Eoption.t array)
|
(exceptions : 'a Eoption.t array) : 'a Eoption.t =
|
||||||
(just : unit -> bool)
|
|
||||||
(cons : unit -> 'a Eoption.t) : 'a Eoption.t =
|
|
||||||
let len = Array.length exceptions in
|
let len = Array.length exceptions in
|
||||||
let rec filt_except i =
|
let rec filt_except i =
|
||||||
if i < len then
|
if i < len then
|
||||||
@ -751,7 +728,7 @@ let handle_default_opt
|
|||||||
else []
|
else []
|
||||||
in
|
in
|
||||||
match filt_except 0 with
|
match filt_except 0 with
|
||||||
| [] -> if just () then cons () else Eoption.ENone ()
|
| [] -> Eoption.ENone ()
|
||||||
| [(res, _)] -> res
|
| [(res, _)] -> res
|
||||||
| res -> error Conflict (List.map (fun (_, i) -> pos.(i)) res)
|
| res -> error Conflict (List.map (fun (_, i) -> pos.(i)) res)
|
||||||
|
|
||||||
|
@ -335,21 +335,8 @@ val duration_to_string : duration -> string
|
|||||||
|
|
||||||
(**{1 Defaults} *)
|
(**{1 Defaults} *)
|
||||||
|
|
||||||
val handle_default :
|
val handle_exceptions :
|
||||||
source_position array ->
|
source_position array -> 'a Eoption.t array -> 'a Eoption.t
|
||||||
(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
|
|
||||||
(** @raise Error Conflict *)
|
(** @raise Error Conflict *)
|
||||||
|
|
||||||
(**{1 Operators} *)
|
(**{1 Operators} *)
|
||||||
|
@ -383,9 +383,9 @@ class NoValue(CatalaError):
|
|||||||
source_position)
|
source_position)
|
||||||
|
|
||||||
class Conflict(CatalaError):
|
class Conflict(CatalaError):
|
||||||
def __init__(self, source_position: SourcePosition) -> None:
|
def __init__(self, pos1: SourcePosition, pos2: SourcePosition) -> None:
|
||||||
super().__init__("two or more concurring valid computations",
|
super().__init__("two or more concurring valid computations:\nAt {}".format(pos2),
|
||||||
source_position)
|
pos1)
|
||||||
|
|
||||||
class DivisionByZero(CatalaError):
|
class DivisionByZero(CatalaError):
|
||||||
def __init__(self, source_position: SourcePosition) -> None:
|
def __init__(self, source_position: SourcePosition) -> None:
|
||||||
@ -606,56 +606,20 @@ def list_length(l: List[Alpha]) -> Integer:
|
|||||||
# ========
|
# ========
|
||||||
|
|
||||||
|
|
||||||
def handle_default(
|
def handle_exceptions(
|
||||||
pos: SourcePosition,
|
pos: List[SourcePosition],
|
||||||
exceptions: List[Callable[[Unit], Alpha]],
|
exceptions: List[Optional[Alpha]]) -> Optional[Alpha]:
|
||||||
just: Callable[[Unit], Alpha],
|
|
||||||
cons: Callable[[Unit], Alpha]
|
|
||||||
) -> Alpha:
|
|
||||||
acc: Optional[Alpha] = None
|
acc: Optional[Alpha] = None
|
||||||
for exception in exceptions:
|
acc_pos: Optional[pos] = None
|
||||||
new_val: Optional[Alpha]
|
for exception, pos in zip(exceptions, pos):
|
||||||
try:
|
if exception is None:
|
||||||
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:
|
|
||||||
pass # acc stays the same
|
pass # acc stays the same
|
||||||
elif not (acc is None) and not (new_val is None):
|
elif acc 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:
|
|
||||||
acc = exception
|
acc = exception
|
||||||
elif not (acc is None) and exception is None:
|
acc_pos = pos
|
||||||
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())
|
|
||||||
else:
|
else:
|
||||||
return None
|
raise Conflict(acc_pos,pos)
|
||||||
else:
|
return acc
|
||||||
return acc
|
|
||||||
|
|
||||||
|
|
||||||
def no_input() -> Callable[[Unit], Alpha]:
|
def no_input() -> Callable[[Unit], Alpha]:
|
||||||
|
@ -16,7 +16,6 @@ export(catala_decimal_to_numeric)
|
|||||||
export(catala_duration_from_ymd)
|
export(catala_duration_from_ymd)
|
||||||
export(catala_duration_to_ymd)
|
export(catala_duration_to_ymd)
|
||||||
export(catala_empty_error)
|
export(catala_empty_error)
|
||||||
export(catala_handle_default)
|
|
||||||
export(catala_integer_from_numeric)
|
export(catala_integer_from_numeric)
|
||||||
export(catala_integer_from_string)
|
export(catala_integer_from_string)
|
||||||
export(catala_integer_to_numeric)
|
export(catala_integer_to_numeric)
|
||||||
|
@ -363,36 +363,6 @@ catala_assertion_failure <- function(pos) {
|
|||||||
|
|
||||||
################ Defaults #################
|
################ 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
|
# 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
|
# 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
|
# definition, R could complains that the later dead code will not know what
|
||||||
|
@ -86,114 +86,116 @@ typedef struct array_1_struct {
|
|||||||
int length_field;
|
int length_field;
|
||||||
} array_1_struct;
|
} 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);
|
option_1_enum (*elt_0_field)(void * /* closure_env */ arg_0_typ, void* /* unit */ arg_1_typ);
|
||||||
void * /* closure_env */ elt_1_field;
|
void * /* closure_env */ elt_1_field;
|
||||||
} tuple_0_struct;
|
} tuple_1_struct;
|
||||||
|
|
||||||
typedef struct baz_in_struct {
|
typedef struct baz_in_struct {
|
||||||
tuple_0_struct a_in_field;
|
tuple_1_struct a_in_field;
|
||||||
} baz_in_struct;
|
} baz_in_struct;
|
||||||
|
|
||||||
|
|
||||||
baz_struct baz_func(baz_in_struct baz_in) {
|
baz_struct baz_func(baz_in_struct baz_in) {
|
||||||
tuple_0_struct a;
|
tuple_1_struct a;
|
||||||
a = baz_in.a_in_field;
|
a = baz_in.a_in_field;
|
||||||
bar_enum temp_a;
|
bar_enum temp_a;
|
||||||
option_1_enum temp_a_1;
|
option_1_enum temp_a_1;
|
||||||
tuple_0_struct code_and_env;
|
tuple_1_struct code_and_env;
|
||||||
code_and_env = a;
|
code_and_env = a;
|
||||||
option_1_enum (*code)(void * /* closure_env */ arg_0_typ, void* /* unit */ arg_1_typ);
|
option_1_enum (*code)(void * /* closure_env */ arg_0_typ, void* /* unit */ arg_1_typ);
|
||||||
void * /* closure_env */ env;
|
void * /* closure_env */ env;
|
||||||
code = code_and_env.elt_0_field;
|
code = code_and_env.elt_0_field;
|
||||||
env = code_and_env.elt_1_field;
|
env = code_and_env.elt_1_field;
|
||||||
option_1_enum exception_acc = {option_1_enum_none_1_cons,
|
array_1_struct temp_a_2;
|
||||||
{none_1_cons: NULL}};
|
temp_a_2.content_field = catala_malloc(sizeof(array_1_struct));
|
||||||
option_1_enum exception_current;
|
temp_a_2.content_field[0] = code(env, NULL);
|
||||||
char exception_conflict = 0;
|
option_1_enum match_arg = catala_handle_exceptions(temp_a_2);
|
||||||
exception_current = code(env, NULL);
|
switch (match_arg.code) {
|
||||||
if (exception_current.code == option_1_enum_some_1_cons) {
|
case option_1_enum_none_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;
|
|
||||||
if (1 /* TRUE */) {
|
if (1 /* TRUE */) {
|
||||||
bar_enum temp_a_5 = {bar_enum_no_cons, {no_cons: NULL}};
|
bar_enum temp_a_3;
|
||||||
option_1_enum temp_a_6 = {option_1_enum_some_1_cons,
|
option_1_enum temp_a_4;
|
||||||
{some_1_cons: temp_a_5}};
|
option_1_enum temp_a_5;
|
||||||
temp_a_4 = temp_a_6;
|
array_1_struct temp_a_6;
|
||||||
} else {
|
temp_a_6.content_field = catala_malloc(sizeof(array_1_struct));
|
||||||
temp_a_4.code = option_1_enum_none_1_cons;
|
|
||||||
temp_a_4.payload.none_1_cons = NULL;
|
option_1_enum match_arg_1 = catala_handle_exceptions(temp_a_6);
|
||||||
}
|
switch (match_arg_1.code) {
|
||||||
option_1_enum exception_acc_1 = {option_1_enum_none_1_cons,
|
case option_1_enum_none_1_cons:
|
||||||
{none_1_cons: NULL}};
|
if (1 /* TRUE */) {
|
||||||
option_1_enum exception_current_1;
|
bar_enum temp_a_7 = {bar_enum_no_cons, {no_cons: NULL}};
|
||||||
char exception_conflict_1 = 0;
|
option_1_enum temp_a_5 = {option_1_enum_some_1_cons,
|
||||||
exception_current_1 = temp_a_4;
|
{some_1_cons: temp_a_7}};
|
||||||
if (exception_current_1.code == option_1_enum_some_1_cons) {
|
|
||||||
if (exception_acc_1.code == option_1_enum_some_1_cons) {
|
} else {
|
||||||
exception_conflict_1 = 1;
|
option_1_enum temp_a_5 = {option_1_enum_none_1_cons,
|
||||||
} else {
|
{none_1_cons: NULL}};
|
||||||
exception_acc_1 = exception_current_1;
|
|
||||||
|
}
|
||||||
|
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;
|
||||||
}
|
}
|
||||||
}
|
array_1_struct temp_a_8;
|
||||||
if (exception_conflict_1) {
|
temp_a_8.content_field = catala_malloc(sizeof(array_1_struct));
|
||||||
catala_raise_fatal_error(catala_conflict,
|
temp_a_8.content_field[0] = temp_a_5;
|
||||||
"tests/backends/simple.catala_en", 11, 11, 11, 12);
|
option_1_enum match_arg_2 = catala_handle_exceptions(temp_a_8);
|
||||||
}
|
switch (match_arg_2.code) {
|
||||||
if (exception_acc_1.code == option_1_enum_some_1_cons) {
|
case option_1_enum_none_1_cons:
|
||||||
temp_a_3 = exception_acc_1;
|
if (0 /* FALSE */) {
|
||||||
} else {
|
option_1_enum temp_a_4 = {option_1_enum_none_1_cons,
|
||||||
if (0 /* FALSE */) {
|
{none_1_cons: NULL}};
|
||||||
option_1_enum temp_a_7 = {option_1_enum_none_1_cons,
|
|
||||||
{none_1_cons: NULL}};
|
} else {
|
||||||
temp_a_3 = temp_a_7;
|
option_1_enum temp_a_4 = {option_1_enum_none_1_cons,
|
||||||
} else {
|
{none_1_cons: NULL}};
|
||||||
temp_a_3.code = option_1_enum_none_1_cons;
|
|
||||||
temp_a_3.payload.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;
|
break;
|
||||||
switch (match_arg.code) {
|
case option_1_enum_some_1_cons:
|
||||||
case option_1_enum_none_1_cons:
|
bar_enum x_2 = match_arg.payload.some_1_cons;
|
||||||
catala_raise_fatal_error (catala_no_value,
|
option_1_enum temp_a_1 = {option_1_enum_some_1_cons,
|
||||||
"tests/backends/simple.catala_en", 11, 11, 11, 12);
|
{some_1_cons: x_2}};
|
||||||
break;
|
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;
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
option_1_enum match_arg_1 = temp_a_1;
|
option_1_enum match_arg_4 = temp_a_1;
|
||||||
switch (match_arg_1.code) {
|
switch (match_arg_4.code) {
|
||||||
case option_1_enum_none_1_cons:
|
case option_1_enum_none_1_cons:
|
||||||
catala_raise_fatal_error (catala_no_value,
|
catala_raise_fatal_error (catala_no_value,
|
||||||
"tests/backends/simple.catala_en", 11, 11, 11, 12);
|
"tests/backends/simple.catala_en", 11, 11, 11, 12);
|
||||||
break;
|
break;
|
||||||
case option_1_enum_some_1_cons:
|
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;
|
temp_a = arg_1;
|
||||||
break;
|
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_1;
|
||||||
option_2_enum temp_b_2;
|
option_2_enum temp_b_2;
|
||||||
option_2_enum temp_b_3;
|
option_2_enum temp_b_3;
|
||||||
char /* bool */ temp_b_4;
|
array_2_struct temp_b_4;
|
||||||
bar_enum match_arg_2 = a_1;
|
temp_b_4.content_field = catala_malloc(sizeof(array_2_struct));
|
||||||
switch (match_arg_2.code) {
|
|
||||||
case bar_enum_no_cons: temp_b_4 = 1 /* TRUE */; break;
|
option_2_enum match_arg_5 = catala_handle_exceptions(temp_b_4);
|
||||||
case bar_enum_yes_cons:
|
switch (match_arg_5.code) {
|
||||||
foo_struct dummy_var = match_arg_2.payload.yes_cons;
|
case option_2_enum_none_2_cons:
|
||||||
temp_b_4 = 0 /* FALSE */;
|
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;
|
break;
|
||||||
}
|
}
|
||||||
if (temp_b_4) {
|
array_2_struct temp_b_6;
|
||||||
option_2_enum temp_b_5 = {option_2_enum_some_2_cons, {some_2_cons: 42.}};
|
temp_b_6.content_field = catala_malloc(sizeof(array_2_struct));
|
||||||
temp_b_3 = temp_b_5;
|
temp_b_6.content_field[0] = temp_b_3;
|
||||||
} else {
|
option_2_enum match_arg_7 = catala_handle_exceptions(temp_b_6);
|
||||||
temp_b_3.code = option_2_enum_none_2_cons;
|
switch (match_arg_7.code) {
|
||||||
temp_b_3.payload.none_2_cons = NULL;
|
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,
|
array_2_struct temp_b_7;
|
||||||
{none_2_cons: NULL}};
|
temp_b_7.content_field = catala_malloc(sizeof(array_2_struct));
|
||||||
option_2_enum exception_current_2;
|
temp_b_7.content_field[0] = temp_b_2;
|
||||||
char exception_conflict_2 = 0;
|
option_2_enum match_arg_8 = catala_handle_exceptions(temp_b_7);
|
||||||
exception_current_2 = temp_b_3;
|
switch (match_arg_8.code) {
|
||||||
if (exception_current_2.code == option_2_enum_some_2_cons) {
|
case option_2_enum_none_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;
|
|
||||||
if (1 /* TRUE */) {
|
if (1 /* TRUE */) {
|
||||||
double temp_b_9;
|
option_2_enum temp_b_8;
|
||||||
bar_enum match_arg_3 = a_1;
|
array_2_struct temp_b_9;
|
||||||
switch (match_arg_3.code) {
|
temp_b_9.content_field = catala_malloc(sizeof(array_2_struct));
|
||||||
case bar_enum_no_cons: temp_b_9 = 0.; break;
|
|
||||||
case bar_enum_yes_cons:
|
option_2_enum match_arg_9 = catala_handle_exceptions(temp_b_9);
|
||||||
foo_struct foo = match_arg_3.payload.yes_cons;
|
switch (match_arg_9.code) {
|
||||||
double temp_b_10;
|
case option_2_enum_none_2_cons:
|
||||||
if (foo.x_field) {temp_b_10 = 1.; } else {temp_b_10 = 0.; }
|
if (1 /* TRUE */) {
|
||||||
temp_b_9 = (foo.y_field + temp_b_10);
|
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;
|
break;
|
||||||
}
|
}
|
||||||
option_2_enum temp_b_11 = {option_2_enum_some_2_cons,
|
array_2_struct temp_b_12;
|
||||||
{some_2_cons: temp_b_9}};
|
temp_b_12.content_field = catala_malloc(sizeof(array_2_struct));
|
||||||
temp_b_8 = temp_b_11;
|
temp_b_12.content_field[0] = temp_b_8;
|
||||||
} else {
|
option_2_enum match_arg_11 = catala_handle_exceptions(temp_b_12);
|
||||||
temp_b_8.code = option_2_enum_none_2_cons;
|
switch (match_arg_11.code) {
|
||||||
temp_b_8.payload.none_2_cons = NULL;
|
case option_2_enum_none_2_cons:
|
||||||
}
|
if (0 /* FALSE */) {
|
||||||
option_2_enum exception_acc_4 = {option_2_enum_none_2_cons,
|
option_2_enum temp_b_1 = {option_2_enum_none_2_cons,
|
||||||
{none_2_cons: NULL}};
|
{none_2_cons: NULL}};
|
||||||
option_2_enum exception_current_4;
|
|
||||||
char exception_conflict_4 = 0;
|
} else {
|
||||||
exception_current_4 = temp_b_8;
|
option_2_enum temp_b_1 = {option_2_enum_none_2_cons,
|
||||||
if (exception_current_4.code == option_2_enum_some_2_cons) {
|
{none_2_cons: NULL}};
|
||||||
if (exception_acc_4.code == option_2_enum_some_2_cons) {
|
|
||||||
exception_conflict_4 = 1;
|
}
|
||||||
} else {
|
break;
|
||||||
exception_acc_4 = exception_current_4;
|
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 {
|
} else {
|
||||||
if (0 /* FALSE */) {
|
option_2_enum temp_b_1 = {option_2_enum_none_2_cons,
|
||||||
option_2_enum temp_b_12 = {option_2_enum_none_2_cons,
|
{none_2_cons: NULL}};
|
||||||
{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;
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
temp_b_1 = temp_b_7;
|
break;
|
||||||
} else {
|
case option_2_enum_some_2_cons:
|
||||||
temp_b_1.code = option_2_enum_none_2_cons;
|
double x_7 = match_arg_8.payload.some_2_cons;
|
||||||
temp_b_1.payload.none_2_cons = NULL;
|
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;
|
option_2_enum match_arg_12 = temp_b_1;
|
||||||
switch (match_arg_4.code) {
|
switch (match_arg_12.code) {
|
||||||
case option_2_enum_none_2_cons:
|
case option_2_enum_none_2_cons:
|
||||||
catala_raise_fatal_error (catala_no_value,
|
catala_raise_fatal_error (catala_no_value,
|
||||||
"tests/backends/simple.catala_en", 12, 10, 12, 11);
|
"tests/backends/simple.catala_en", 12, 10, 12, 11);
|
||||||
break;
|
break;
|
||||||
case option_2_enum_some_2_cons:
|
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;
|
temp_b = arg_2;
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
@ -338,54 +350,62 @@ baz_struct baz_func(baz_in_struct baz_in) {
|
|||||||
array_3_struct temp_c;
|
array_3_struct temp_c;
|
||||||
option_3_enum temp_c_1;
|
option_3_enum temp_c_1;
|
||||||
option_3_enum temp_c_2;
|
option_3_enum temp_c_2;
|
||||||
if (1 /* TRUE */) {
|
array_4_struct temp_c_3;
|
||||||
array_3_struct temp_c_3;
|
temp_c_3.content_field = catala_malloc(sizeof(array_4_struct));
|
||||||
temp_c_3.content_field = catala_malloc(sizeof(array_3_struct));
|
|
||||||
temp_c_3.content_field[0] = b;
|
option_3_enum match_arg_13 = catala_handle_exceptions(temp_c_3);
|
||||||
temp_c_3.content_field[1] = b;
|
switch (match_arg_13.code) {
|
||||||
option_3_enum temp_c_4 = {option_3_enum_some_3_cons,
|
case option_3_enum_none_3_cons:
|
||||||
{some_3_cons: temp_c_3}};
|
if (1 /* TRUE */) {
|
||||||
temp_c_2 = temp_c_4;
|
array_3_struct temp_c_4;
|
||||||
} else {
|
temp_c_4.content_field = catala_malloc(sizeof(array_3_struct));
|
||||||
temp_c_2.code = option_3_enum_none_3_cons;
|
temp_c_4.content_field[0] = b;
|
||||||
temp_c_2.payload.none_3_cons = NULL;
|
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,
|
array_4_struct temp_c_5;
|
||||||
{none_3_cons: NULL}};
|
temp_c_5.content_field = catala_malloc(sizeof(array_4_struct));
|
||||||
option_3_enum exception_current_5;
|
temp_c_5.content_field[0] = temp_c_2;
|
||||||
char exception_conflict_5 = 0;
|
option_3_enum match_arg_14 = catala_handle_exceptions(temp_c_5);
|
||||||
exception_current_5 = temp_c_2;
|
switch (match_arg_14.code) {
|
||||||
if (exception_current_5.code == option_3_enum_some_3_cons) {
|
case option_3_enum_none_3_cons:
|
||||||
if (exception_acc_5.code == option_3_enum_some_3_cons) {
|
if (0 /* FALSE */) {
|
||||||
exception_conflict_5 = 1;
|
option_3_enum temp_c_1 = {option_3_enum_none_3_cons,
|
||||||
} else {
|
{none_3_cons: NULL}};
|
||||||
exception_acc_5 = exception_current_5;
|
|
||||||
}
|
} 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) {
|
option_3_enum match_arg_15 = temp_c_1;
|
||||||
catala_raise_fatal_error(catala_conflict,
|
switch (match_arg_15.code) {
|
||||||
"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) {
|
|
||||||
case option_3_enum_none_3_cons:
|
case option_3_enum_none_3_cons:
|
||||||
catala_raise_fatal_error (catala_no_value,
|
catala_raise_fatal_error (catala_no_value,
|
||||||
"tests/backends/simple.catala_en", 13, 10, 13, 11);
|
"tests/backends/simple.catala_en", 13, 10, 13, 11);
|
||||||
break;
|
break;
|
||||||
case option_3_enum_some_3_cons:
|
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;
|
temp_c = arg_3;
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
@ -91,60 +91,79 @@ class BIn:
|
|||||||
|
|
||||||
def some_name(some_name_in:SomeNameIn):
|
def some_name(some_name_in:SomeNameIn):
|
||||||
i = some_name_in.i_in
|
i = some_name_in.i_in
|
||||||
try:
|
perhaps_none_arg = handle_exceptions([], [])
|
||||||
def temp_o(_:Unit):
|
if perhaps_none_arg is None:
|
||||||
def temp_o_1(_:Unit):
|
if True:
|
||||||
return True
|
temp_o = (i + integer_of_string("1"))
|
||||||
def temp_o_2(_:Unit):
|
else:
|
||||||
return (i + integer_of_string("1"))
|
temp_o = None
|
||||||
return handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
|
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,
|
start_line=10, start_column=23,
|
||||||
end_line=10, end_column=28,
|
end_line=10, end_column=28, law_headings=[]
|
||||||
law_headings=[]), [], temp_o_1, temp_o_2)
|
)],
|
||||||
def temp_o_3(_:Unit):
|
[temp_o]
|
||||||
return False
|
)
|
||||||
def temp_o_4(_:Unit):
|
if perhaps_none_arg_1 is None:
|
||||||
raise Empty
|
if False:
|
||||||
temp_o_5 = handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
|
temp_o_1 = None
|
||||||
start_line=7, start_column=10,
|
else:
|
||||||
end_line=7, end_column=11,
|
temp_o_1 = None
|
||||||
law_headings=[]), [temp_o], temp_o_3,
|
else:
|
||||||
temp_o_4)
|
x_1 = perhaps_none_arg_1
|
||||||
except Empty:
|
temp_o_1 = x_1
|
||||||
|
perhaps_none_arg_2 = temp_o_1
|
||||||
|
if perhaps_none_arg_2 is None:
|
||||||
raise NoValue(SourcePosition(
|
raise NoValue(SourcePosition(
|
||||||
filename="tests/backends/python_name_clash.catala_en",
|
filename="tests/backends/python_name_clash.catala_en",
|
||||||
start_line=7, start_column=10,
|
start_line=7, start_column=10,
|
||||||
end_line=7, end_column=11, law_headings=[]))
|
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)
|
return SomeName(o = o)
|
||||||
|
|
||||||
def b(b_in:BIn):
|
def b(b_in:BIn):
|
||||||
try:
|
perhaps_none_arg_3 = handle_exceptions([], [])
|
||||||
def temp_result(_:Unit):
|
if perhaps_none_arg_3 is None:
|
||||||
def temp_result_1(_:Unit):
|
if True:
|
||||||
return True
|
temp_result = integer_of_string("1")
|
||||||
def temp_result_2(_:Unit):
|
else:
|
||||||
return integer_of_string("1")
|
temp_result = None
|
||||||
return handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
|
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,
|
start_line=16, start_column=33,
|
||||||
end_line=16, end_column=34,
|
end_line=16, end_column=34, law_headings=[]
|
||||||
law_headings=[]), [], temp_result_1,
|
)],
|
||||||
temp_result_2)
|
[temp_result]
|
||||||
def temp_result_3(_:Unit):
|
)
|
||||||
return False
|
if perhaps_none_arg_4 is None:
|
||||||
def temp_result_4(_:Unit):
|
if False:
|
||||||
raise Empty
|
temp_result_1 = None
|
||||||
temp_result_5 = handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
|
else:
|
||||||
start_line=16, start_column=14,
|
temp_result_1 = None
|
||||||
end_line=16, end_column=25,
|
else:
|
||||||
law_headings=[]), [temp_result],
|
x_3 = perhaps_none_arg_4
|
||||||
temp_result_3, temp_result_4)
|
temp_result_1 = x_3
|
||||||
except Empty:
|
perhaps_none_arg_5 = temp_result_1
|
||||||
|
if perhaps_none_arg_5 is None:
|
||||||
raise NoValue(SourcePosition(
|
raise NoValue(SourcePosition(
|
||||||
filename="tests/backends/python_name_clash.catala_en",
|
filename="tests/backends/python_name_clash.catala_en",
|
||||||
start_line=16, start_column=14,
|
start_line=16, start_column=14,
|
||||||
end_line=16, end_column=25, law_headings=[]))
|
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)
|
result_1 = SomeName(o = result.o)
|
||||||
if True:
|
if True:
|
||||||
temp_some_name = result_1
|
temp_some_name = result_1
|
||||||
|
@ -24,14 +24,16 @@ $ catala Typecheck --check-invariants
|
|||||||
```
|
```
|
||||||
|
|
||||||
```catala-test-inline
|
```catala-test-inline
|
||||||
$ catala Lcalc --avoid-exceptions -O --closure-conversion
|
$ catala Lcalc -O --closure-conversion
|
||||||
type Eoption = | ENone of unit | ESome of any
|
type Eoption = | ENone of unit | ESome of any
|
||||||
|
|
||||||
type S_in = { x_in: bool; }
|
type S_in = { x_in: bool; }
|
||||||
type S = { z: integer; }
|
type S = { z: integer; }
|
||||||
|
|
||||||
let topval closure_f1 : (closure_env, integer) → integer =
|
let topval closure_f1 : (closure_env, integer) → integer =
|
||||||
λ (env: closure_env) (y: integer) →
|
λ (env: closure_env) (y: integer) →
|
||||||
if (from_closure_env env).0 then y else - y
|
if (from_closure_env env).0 then y else - y
|
||||||
|
|
||||||
let scope S (S_in: S_in {x_in: bool}): S {z: integer} =
|
let scope S (S_in: S_in {x_in: bool}): S {z: integer} =
|
||||||
let get x : bool = S_in.x_in in
|
let get x : bool = S_in.x_in in
|
||||||
let set f : ((closure_env, integer) → integer, closure_env) =
|
let set f : ((closure_env, integer) → integer, closure_env) =
|
||||||
@ -65,7 +67,7 @@ scope S2Use:
|
|||||||
```
|
```
|
||||||
|
|
||||||
```catala-test-inline
|
```catala-test-inline
|
||||||
$ catala Lcalc --avoid-exceptions -O --closure-conversion -s S2Use
|
$ catala Lcalc -O --closure-conversion -s S2Use
|
||||||
let scope S2Use
|
let scope S2Use
|
||||||
(S2Use_in: S2Use_in)
|
(S2Use_in: S2Use_in)
|
||||||
: S2Use {
|
: S2Use {
|
||||||
|
@ -24,7 +24,7 @@ $ catala Typecheck --check-invariants
|
|||||||
```
|
```
|
||||||
|
|
||||||
```catala-test-inline
|
```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 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 get x : list of integer = S_in.x_in in
|
||||||
let set y : integer =
|
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
|
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
|
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
|
to reduce or other special operators relies on pattern matching the special
|
||||||
operator and its EAbs argument. However without exceptions on, because the
|
operator and its EAbs argument. However without exceptions on, because the
|
||||||
--avoid-exceptions pass is not optimized and produces more options than needed,
|
lcalc translation pass is not optimized and produces more options than needed,
|
||||||
the closures that are arguments to special operators are let-binded with an
|
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
|
option. This let-binding is reduced by partial evaluation, which is why the test
|
||||||
with optimizations on passes.
|
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 get x : list of integer = S_in.x_in in
|
||||||
let set y : integer =
|
let set y : integer =
|
||||||
match
|
match
|
||||||
(handle_default_opt
|
(match
|
||||||
[
|
(handle_exceptions
|
||||||
handle_default_opt
|
[
|
||||||
[]
|
match (handle_exceptions []) with
|
||||||
(λ () → true)
|
| ENone →
|
||||||
(λ () →
|
if true then
|
||||||
ESome
|
ESome
|
||||||
(let weights : list of (integer, integer) =
|
(let weights : list of (integer, integer) =
|
||||||
map (λ (potential_max: integer) →
|
map (λ (potential_max: integer) →
|
||||||
(potential_max,
|
(potential_max,
|
||||||
let potential_max1 : integer = potential_max in
|
let potential_max1 : integer = potential_max in
|
||||||
potential_max1))
|
potential_max1))
|
||||||
x
|
x
|
||||||
in
|
in
|
||||||
reduce
|
reduce
|
||||||
(λ (x1: (integer, integer)) (x2: (integer, integer)) →
|
(λ (x1: (integer, integer)) (x2: (integer, integer)) →
|
||||||
if x1.1 < x2.1 then x1 else x2)
|
if x1.1 < x2.1 then x1 else x2)
|
||||||
let potential_max : integer = -1 in
|
let potential_max : integer = -1 in
|
||||||
(potential_max,
|
(potential_max,
|
||||||
let potential_max1 : integer = potential_max in
|
let potential_max1 : integer = potential_max in
|
||||||
potential_max1)
|
potential_max1)
|
||||||
weights).0)
|
weights).0
|
||||||
]
|
else ENone ()
|
||||||
(λ () → false)
|
| ESome x → ESome x
|
||||||
(λ () → ENone ()))
|
])
|
||||||
|
with
|
||||||
|
| ENone → if false then ENone () else ENone ()
|
||||||
|
| ESome x → ESome x)
|
||||||
with
|
with
|
||||||
| ENone → error NoValue
|
| ENone → error NoValue
|
||||||
| ESome arg → arg
|
| ESome arg → arg
|
||||||
|
@ -22,14 +22,16 @@ $ catala Typecheck --check-invariants
|
|||||||
```
|
```
|
||||||
|
|
||||||
```catala-test-inline
|
```catala-test-inline
|
||||||
$ catala Lcalc --avoid-exceptions -O --closure-conversion
|
$ catala Lcalc -O --closure-conversion
|
||||||
type Eoption = | ENone of unit | ESome of any
|
type Eoption = | ENone of unit | ESome of any
|
||||||
|
|
||||||
type S_in = { x_in: bool; }
|
type S_in = { x_in: bool; }
|
||||||
type S = { f: ((closure_env, integer) → integer, closure_env); }
|
type S = { f: ((closure_env, integer) → integer, closure_env); }
|
||||||
|
|
||||||
let topval closure_f1 : (closure_env, integer) → integer =
|
let topval closure_f1 : (closure_env, integer) → integer =
|
||||||
λ (env: closure_env) (y: integer) →
|
λ (env: closure_env) (y: integer) →
|
||||||
if (from_closure_env env).0 then y else - y
|
if (from_closure_env env).0 then y else - y
|
||||||
|
|
||||||
let scope S
|
let scope S
|
||||||
(S_in: S_in {x_in: bool})
|
(S_in: S_in {x_in: bool})
|
||||||
: S {f: ((closure_env, integer) → integer, closure_env)}
|
: S {f: ((closure_env, integer) → integer, closure_env)}
|
||||||
|
@ -30,7 +30,7 @@ $ catala Typecheck --check-invariants
|
|||||||
```
|
```
|
||||||
|
|
||||||
```catala-test-inline
|
```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 scope T (T_in: T_in): T {y: integer} =
|
||||||
let set s : S {f: ((closure_env, integer) → integer, closure_env)} =
|
let set s : S {f: ((closure_env, integer) → integer, closure_env)} =
|
||||||
{ S f = (closure_s1, to_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-test-inline
|
||||||
$ catala Interpret --lcalc -s T --avoid-exceptions -O --closure-conversion
|
$ catala Interpret --lcalc -s T -O --closure-conversion
|
||||||
┌─[RESULT]─
|
┌─[RESULT]─
|
||||||
│ y = -2
|
│ y = -2
|
||||||
└─
|
└─
|
||||||
|
@ -53,8 +53,9 @@ $ catala Typecheck --check-invariants
|
|||||||
```
|
```
|
||||||
|
|
||||||
```catala-test-inline
|
```catala-test-inline
|
||||||
$ catala Lcalc --avoid-exceptions -O --closure-conversion
|
$ catala Lcalc -O --closure-conversion
|
||||||
type Eoption = | ENone of unit | ESome of any
|
type Eoption = | ENone of unit | ESome of any
|
||||||
|
|
||||||
type Result = {
|
type Result = {
|
||||||
r: ((closure_env, integer) → integer, closure_env);
|
r: ((closure_env, integer) → integer, closure_env);
|
||||||
q: integer;
|
q: integer;
|
||||||
@ -69,12 +70,13 @@ type SubFoo2 = {
|
|||||||
x1: integer;
|
x1: integer;
|
||||||
y: ((closure_env, integer) → integer, closure_env);
|
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; }
|
type Foo = { z: integer; }
|
||||||
|
|
||||||
let topval closure_y1 : (closure_env, integer) → integer =
|
let topval closure_y1 : (closure_env, integer) → integer =
|
||||||
λ (env: closure_env) (z: integer) →
|
λ (env: closure_env) (z: integer) →
|
||||||
(from_closure_env env).0 + z
|
(from_closure_env env).0 + z
|
||||||
|
|
||||||
let scope SubFoo1
|
let scope SubFoo1
|
||||||
(SubFoo1_in: SubFoo1_in {x_in: integer})
|
(SubFoo1_in: SubFoo1_in {x_in: integer})
|
||||||
: SubFoo1 {
|
: SubFoo1 {
|
||||||
@ -87,10 +89,12 @@ let scope SubFoo1
|
|||||||
(closure_y1, to_closure_env (x))
|
(closure_y1, to_closure_env (x))
|
||||||
in
|
in
|
||||||
return { SubFoo1 x = x; y = y; }
|
return { SubFoo1 x = x; y = y; }
|
||||||
|
|
||||||
let topval closure_y1 : (closure_env, integer) → integer =
|
let topval closure_y1 : (closure_env, integer) → integer =
|
||||||
λ (env: closure_env) (z: integer) →
|
λ (env: closure_env) (z: integer) →
|
||||||
let env1 : (integer, integer) = from_closure_env env in
|
let env1 : (integer, integer) = from_closure_env env in
|
||||||
((env1.1 + env1.0 + z))
|
((env1.1 + env1.0 + z))
|
||||||
|
|
||||||
let scope SubFoo2
|
let scope SubFoo2
|
||||||
(SubFoo2_in: SubFoo2_in {x1_in: integer; x2_in: integer})
|
(SubFoo2_in: SubFoo2_in {x1_in: integer; x2_in: integer})
|
||||||
: SubFoo2 {
|
: SubFoo2 {
|
||||||
@ -104,29 +108,33 @@ let scope SubFoo2
|
|||||||
(closure_y1, to_closure_env (x2, x1))
|
(closure_y1, to_closure_env (x2, x1))
|
||||||
in
|
in
|
||||||
return { SubFoo2 x1 = x1; y = y; }
|
return { SubFoo2 x1 = x1; y = y; }
|
||||||
|
|
||||||
let topval closure_r2 : (closure_env, integer) → integer =
|
let topval closure_r2 : (closure_env, integer) → integer =
|
||||||
λ (env: closure_env) (param0: integer) →
|
λ (env: closure_env) (param0: integer) →
|
||||||
let code_and_env : ((closure_env, integer) → integer, closure_env) =
|
let code_and_env : ((closure_env, integer) → integer, closure_env) =
|
||||||
(from_closure_env env).0.y
|
(from_closure_env env).0.y
|
||||||
in
|
in
|
||||||
code_and_env.0 code_and_env.1 param0
|
code_and_env.0 code_and_env.1 param0
|
||||||
|
|
||||||
let topval closure_r1 : (closure_env, integer) → integer =
|
let topval closure_r1 : (closure_env, integer) → integer =
|
||||||
λ (env: closure_env) (param0: integer) →
|
λ (env: closure_env) (param0: integer) →
|
||||||
let code_and_env : ((closure_env, integer) → integer, closure_env) =
|
let code_and_env : ((closure_env, integer) → integer, closure_env) =
|
||||||
(from_closure_env env).0.y
|
(from_closure_env env).0.y
|
||||||
in
|
in
|
||||||
code_and_env.0 code_and_env.1 param0
|
code_and_env.0 code_and_env.1 param0
|
||||||
|
|
||||||
let scope Foo
|
let scope Foo
|
||||||
(Foo_in:
|
(Foo_in: Foo_in {b_in: ((closure_env, unit) → option bool, closure_env)})
|
||||||
Foo_in {b_in: ((closure_env, unit) → eoption bool, closure_env)})
|
|
||||||
: Foo {z: integer}
|
: 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
|
Foo_in.b_in
|
||||||
in
|
in
|
||||||
let set b : bool =
|
let set b : bool =
|
||||||
match
|
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
|
with
|
||||||
| ENone → error NoValue
|
| ENone → error NoValue
|
||||||
| ESome arg → arg
|
| ESome arg → arg
|
||||||
@ -165,7 +173,7 @@ let scope Foo
|
|||||||
```
|
```
|
||||||
|
|
||||||
```catala-test-inline
|
```catala-test-inline
|
||||||
$ catala Interpret --lcalc -s Foo --avoid-exceptions -O --closure-conversion
|
$ catala Interpret --lcalc -s Foo -O --closure-conversion
|
||||||
┌─[RESULT]─
|
┌─[RESULT]─
|
||||||
│ z = 11
|
│ z = 11
|
||||||
└─
|
└─
|
||||||
|
@ -27,39 +27,66 @@ end
|
|||||||
|
|
||||||
let s (s_in: S_in.t) : S.t =
|
let s (s_in: S_in.t) : S.t =
|
||||||
let sr_: money =
|
let sr_: money =
|
||||||
try
|
match
|
||||||
(handle_default
|
(match
|
||||||
[|{filename="tests/modules/good/mod_def.catala_en";
|
(handle_exceptions
|
||||||
start_line=29; start_column=24; end_line=29; end_column=30;
|
[|{filename="tests/modules/good/mod_def.catala_en";
|
||||||
law_headings=["Test modules + inclusions 1"]}|]
|
start_line=16; start_column=10; end_line=16; end_column=12;
|
||||||
([|(fun (_: unit) ->
|
law_headings=["Test modules + inclusions 1"]}|]
|
||||||
handle_default [||] ([||]) (fun (_: unit) -> true)
|
([|(match
|
||||||
(fun (_: unit) -> money_of_cents_string "100000"))|])
|
(handle_exceptions
|
||||||
(fun (_: unit) -> false) (fun (_: unit) -> raise Empty))
|
[|{filename="tests/modules/good/mod_def.catala_en";
|
||||||
with Empty ->
|
start_line=29; start_column=24;
|
||||||
(raise
|
end_line=29; end_column=30;
|
||||||
(Runtime_ocaml.Runtime.Error (NoValue, [{filename="tests/modules/good/mod_def.catala_en";
|
law_headings=["Test modules + inclusions 1"]}|]
|
||||||
start_line=16; start_column=10;
|
([||]))
|
||||||
end_line=16; end_column=12;
|
with
|
||||||
law_headings=["Test modules + inclusions 1"]}])))
|
| Eoption.ENone _ ->
|
||||||
in
|
( 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 =
|
let e1_: Enum1.t =
|
||||||
try
|
match
|
||||||
(handle_default
|
(match
|
||||||
[|{filename="tests/modules/good/mod_def.catala_en";
|
(handle_exceptions
|
||||||
start_line=30; start_column=24; end_line=30; end_column=29;
|
[|{filename="tests/modules/good/mod_def.catala_en";
|
||||||
law_headings=["Test modules + inclusions 1"]}|]
|
start_line=17; start_column=10; end_line=17; end_column=12;
|
||||||
([|(fun (_: unit) ->
|
law_headings=["Test modules + inclusions 1"]}|]
|
||||||
handle_default [||] ([||]) (fun (_: unit) -> true)
|
([|(match
|
||||||
(fun (_: unit) -> Enum1.Maybe ()))|])
|
(handle_exceptions
|
||||||
(fun (_: unit) -> false) (fun (_: unit) -> raise Empty))
|
[|{filename="tests/modules/good/mod_def.catala_en";
|
||||||
with Empty ->
|
start_line=30; start_column=24;
|
||||||
(raise
|
end_line=30; end_column=29;
|
||||||
(Runtime_ocaml.Runtime.Error (NoValue, [{filename="tests/modules/good/mod_def.catala_en";
|
law_headings=["Test modules + inclusions 1"]}|]
|
||||||
start_line=17; start_column=10;
|
([||]))
|
||||||
end_line=17; end_column=12;
|
with
|
||||||
law_headings=["Test modules + inclusions 1"]}])))
|
| Eoption.ENone _ ->
|
||||||
in
|
( 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_}
|
{S.sr = sr_; S.e1 = e1_}
|
||||||
|
|
||||||
let half_ : integer -> decimal =
|
let half_ : integer -> decimal =
|
||||||
|
111
tests/monomorphisation/context_var.catala_en
Normal file
111
tests/monomorphisation/context_var.catala_en
Normal 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; }
|
||||||
|
```
|
||||||
|
|
@ -47,44 +47,66 @@ module S = struct
|
|||||||
end
|
end
|
||||||
|
|
||||||
module S_in = struct
|
module S_in = struct
|
||||||
type t = {a_in: unit -> bool}
|
type t = {a_in: unit -> (bool) Eoption.t}
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
let s (s_in: S_in.t) : S.t =
|
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 =
|
let a_: bool =
|
||||||
try
|
match
|
||||||
(handle_default
|
(match
|
||||||
[|{filename="tests/name_resolution/good/let_in2.catala_en";
|
(handle_exceptions
|
||||||
start_line=7; start_column=18; end_line=7; end_column=19;
|
[|{filename="tests/name_resolution/good/let_in2.catala_en";
|
||||||
law_headings=["Article"]}|] ([|(fun (_: unit) -> a_ ())|])
|
start_line=7; start_column=18; end_line=7; end_column=19;
|
||||||
(fun (_: unit) -> true)
|
law_headings=["Article"]}|] ([|(a_ ())|]))
|
||||||
(fun (_: unit) ->
|
with
|
||||||
try
|
| Eoption.ENone _ ->
|
||||||
(handle_default
|
( if true then
|
||||||
[|{filename="tests/name_resolution/good/let_in2.catala_en";
|
(Eoption.ESome
|
||||||
start_line=11; start_column=5; end_line=13; end_column=6;
|
(match
|
||||||
law_headings=["Article"]}|]
|
(match
|
||||||
([|(fun (_: unit) ->
|
(handle_exceptions
|
||||||
handle_default [||] ([||]) (fun (_: unit) -> true)
|
[|{filename="tests/name_resolution/good/let_in2.catala_en";
|
||||||
(fun (_: unit) -> (let a_ : bool = false
|
start_line=7; start_column=18;
|
||||||
in
|
end_line=7; end_column=19;
|
||||||
(let a_ : bool = (o_or a_ true) in
|
law_headings=["Article"]}|]
|
||||||
a_))))|]) (fun (_: unit) -> false)
|
([|(match
|
||||||
(fun (_: unit) -> raise Empty))
|
(handle_exceptions
|
||||||
with Empty ->
|
[|{filename="tests/name_resolution/good/let_in2.catala_en";
|
||||||
(raise
|
start_line=11; start_column=5;
|
||||||
(Runtime_ocaml.Runtime.Error (NoValue, [{filename="tests/name_resolution/good/let_in2.catala_en";
|
end_line=13; end_column=6;
|
||||||
start_line=7; start_column=18;
|
law_headings=["Article"]}|] ([||]))
|
||||||
end_line=7; end_column=19;
|
with
|
||||||
law_headings=["Article"]}])))))
|
| Eoption.ENone _ ->
|
||||||
with Empty ->
|
( if true then
|
||||||
(raise
|
(Eoption.ESome (let a_ : bool = false
|
||||||
(Runtime_ocaml.Runtime.Error (NoValue, [{filename="tests/name_resolution/good/let_in2.catala_en";
|
in
|
||||||
start_line=7; start_column=18;
|
(let a_ : bool = (o_or a_ true)
|
||||||
end_line=7; end_column=19;
|
in
|
||||||
law_headings=["Article"]}]))) 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_}
|
{S.a = a_}
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
|
@ -107,144 +107,164 @@ $ catala test-scope S4
|
|||||||
|
|
||||||
```catala-test-inline
|
```catala-test-inline
|
||||||
$ catala scalc
|
$ 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 =
|
let glob5_aux_3 =
|
||||||
decl x_7 : decimal;
|
decl x_6 : decimal;
|
||||||
x_7 = to_rat 2 * 3.;
|
x_6 = to_rat 2 * 3.;
|
||||||
decl y_8 : decimal;
|
decl y_7 : decimal;
|
||||||
y_8 = 1000.;
|
y_7 = 1000.;
|
||||||
return x_7 * y_8
|
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) =
|
let S2_4 (S2_in_9: S2_in) =
|
||||||
decl temp_a_12 : decimal;
|
decl temp_a_11 : decimal;
|
||||||
try:
|
decl temp_a_12 : option decimal;
|
||||||
decl temp_a_13 : unit → decimal;
|
decl temp_a_13 : option decimal;
|
||||||
let func temp_a_13 (__14 : unit) =
|
switch handle_exceptions []:
|
||||||
decl temp_a_15 : unit → bool;
|
| ENone __14 →
|
||||||
let func temp_a_15 (__16 : unit) =
|
if true:
|
||||||
return true;
|
temp_a_13 = ESome glob3_1 ¤44.00 + 100.
|
||||||
decl temp_a_17 : unit → decimal;
|
else:
|
||||||
let func temp_a_17 (__18 : unit) =
|
temp_a_13 = ENone ()
|
||||||
return glob3_3 ¤44.00 + 100.;
|
| ESome x_15 →
|
||||||
return handle_default [] temp_a_15 temp_a_17;
|
temp_a_13 = ESome x_15;
|
||||||
decl temp_a_19 : unit → bool;
|
switch handle_exceptions [temp_a_13]:
|
||||||
let func temp_a_19 (__20 : unit) =
|
| ENone __16 →
|
||||||
return false;
|
if false:
|
||||||
decl temp_a_21 : unit → decimal;
|
temp_a_12 = ENone ()
|
||||||
let func temp_a_21 (__22 : unit) =
|
else:
|
||||||
raise Empty;
|
temp_a_12 = ENone ()
|
||||||
temp_a_12 = handle_default [temp_a_13] temp_a_19 temp_a_21
|
| ESome x_17 →
|
||||||
with Empty:
|
temp_a_12 = ESome x_17;
|
||||||
fatal NoValue;
|
switch temp_a_12:
|
||||||
decl a_11 : decimal;
|
| ENone __18 →
|
||||||
a_11 = temp_a_12;
|
fatal NoValue
|
||||||
return S2 {"a": a_11}
|
| 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) =
|
let S3_5 (S3_in_20: S3_in) =
|
||||||
decl temp_a_25 : decimal;
|
decl temp_a_22 : decimal;
|
||||||
try:
|
decl temp_a_23 : option decimal;
|
||||||
decl temp_a_26 : unit → decimal;
|
decl temp_a_24 : option decimal;
|
||||||
let func temp_a_26 (__27 : unit) =
|
switch handle_exceptions []:
|
||||||
decl temp_a_28 : unit → bool;
|
| ENone __25 →
|
||||||
let func temp_a_28 (__29 : unit) =
|
if true:
|
||||||
return true;
|
temp_a_24 = ESome 50. + glob4_2 ¤44.00 55.
|
||||||
decl temp_a_30 : unit → decimal;
|
else:
|
||||||
let func temp_a_30 (__31 : unit) =
|
temp_a_24 = ENone ()
|
||||||
return 50. + glob4_4 ¤44.00 55.;
|
| ESome x_26 →
|
||||||
return handle_default [] temp_a_28 temp_a_30;
|
temp_a_24 = ESome x_26;
|
||||||
decl temp_a_32 : unit → bool;
|
switch handle_exceptions [temp_a_24]:
|
||||||
let func temp_a_32 (__33 : unit) =
|
| ENone __27 →
|
||||||
return false;
|
if false:
|
||||||
decl temp_a_34 : unit → decimal;
|
temp_a_23 = ENone ()
|
||||||
let func temp_a_34 (__35 : unit) =
|
else:
|
||||||
raise Empty;
|
temp_a_23 = ENone ()
|
||||||
temp_a_25 = handle_default [temp_a_26] temp_a_32 temp_a_34
|
| ESome x_28 →
|
||||||
with Empty:
|
temp_a_23 = ESome x_28;
|
||||||
fatal NoValue;
|
switch temp_a_23:
|
||||||
decl a_24 : decimal;
|
| ENone __29 →
|
||||||
a_24 = temp_a_25;
|
fatal NoValue
|
||||||
return S3 {"a": a_24}
|
| 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) =
|
let S4_6 (S4_in_31: S4_in) =
|
||||||
decl temp_a_38 : decimal;
|
decl temp_a_33 : decimal;
|
||||||
try:
|
decl temp_a_34 : option decimal;
|
||||||
decl temp_a_39 : unit → decimal;
|
decl temp_a_35 : option decimal;
|
||||||
let func temp_a_39 (__40 : unit) =
|
switch handle_exceptions []:
|
||||||
decl temp_a_41 : unit → bool;
|
| ENone __36 →
|
||||||
let func temp_a_41 (__42 : unit) =
|
if true:
|
||||||
return true;
|
temp_a_35 = ESome glob5_5 + 1.
|
||||||
decl temp_a_43 : unit → decimal;
|
else:
|
||||||
let func temp_a_43 (__44 : unit) =
|
temp_a_35 = ENone ()
|
||||||
return glob5_6 + 1.;
|
| ESome x_37 →
|
||||||
return handle_default [] temp_a_41 temp_a_43;
|
temp_a_35 = ESome x_37;
|
||||||
decl temp_a_45 : unit → bool;
|
switch handle_exceptions [temp_a_35]:
|
||||||
let func temp_a_45 (__46 : unit) =
|
| ENone __38 →
|
||||||
return false;
|
if false:
|
||||||
decl temp_a_47 : unit → decimal;
|
temp_a_34 = ENone ()
|
||||||
let func temp_a_47 (__48 : unit) =
|
else:
|
||||||
raise Empty;
|
temp_a_34 = ENone ()
|
||||||
temp_a_38 = handle_default [temp_a_39] temp_a_45 temp_a_47
|
| ESome x_39 →
|
||||||
with Empty:
|
temp_a_34 = ESome x_39;
|
||||||
fatal NoValue;
|
switch temp_a_34:
|
||||||
decl a_37 : decimal;
|
| ENone __40 →
|
||||||
a_37 = temp_a_38;
|
fatal NoValue
|
||||||
return S4 {"a": a_37}
|
| 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) =
|
let S_7 (S_in_42: S_in) =
|
||||||
decl temp_a_63 : decimal;
|
decl temp_a_54 : decimal;
|
||||||
try:
|
decl temp_a_55 : option decimal;
|
||||||
decl temp_a_64 : unit → decimal;
|
decl temp_a_56 : option decimal;
|
||||||
let func temp_a_64 (__65 : unit) =
|
switch handle_exceptions []:
|
||||||
decl temp_a_66 : unit → bool;
|
| ENone __57 →
|
||||||
let func temp_a_66 (__67 : unit) =
|
if true:
|
||||||
return true;
|
temp_a_56 = ESome glob1_1 * glob1_1
|
||||||
decl temp_a_68 : unit → decimal;
|
else:
|
||||||
let func temp_a_68 (__69 : unit) =
|
temp_a_56 = ENone ()
|
||||||
return glob1_2 * glob1_2;
|
| ESome x_58 →
|
||||||
return handle_default [] temp_a_66 temp_a_68;
|
temp_a_56 = ESome x_58;
|
||||||
decl temp_a_70 : unit → bool;
|
switch handle_exceptions [temp_a_56]:
|
||||||
let func temp_a_70 (__71 : unit) =
|
| ENone __59 →
|
||||||
return false;
|
if false:
|
||||||
decl temp_a_72 : unit → decimal;
|
temp_a_55 = ENone ()
|
||||||
let func temp_a_72 (__73 : unit) =
|
else:
|
||||||
raise Empty;
|
temp_a_55 = ENone ()
|
||||||
temp_a_63 = handle_default [temp_a_64] temp_a_70 temp_a_72
|
| ESome x_60 →
|
||||||
with Empty:
|
temp_a_55 = ESome x_60;
|
||||||
fatal NoValue;
|
switch temp_a_55:
|
||||||
decl a_50 : decimal;
|
| ENone __61 →
|
||||||
a_50 = temp_a_63;
|
fatal NoValue
|
||||||
decl temp_b_52 : A {y: bool; z: decimal};
|
| ESome arg_62 →
|
||||||
try:
|
temp_a_54 = arg_62;
|
||||||
decl temp_b_53 : unit → A {y: bool; z: decimal};
|
decl a_43 : decimal;
|
||||||
let func temp_b_53 (__54 : unit) =
|
a_43 = temp_a_54;
|
||||||
decl temp_b_55 : unit → bool;
|
decl temp_b_45 : A {y: bool; z: decimal};
|
||||||
let func temp_b_55 (__56 : unit) =
|
decl temp_b_46 : option A {y: bool; z: decimal};
|
||||||
return true;
|
decl temp_b_47 : option A {y: bool; z: decimal};
|
||||||
decl temp_b_57 : unit → A {y: bool; z: decimal};
|
switch handle_exceptions []:
|
||||||
let func temp_b_57 (__58 : unit) =
|
| ENone __48 →
|
||||||
return glob2_9;
|
if true:
|
||||||
return handle_default [] temp_b_55 temp_b_57;
|
temp_b_47 = ESome glob2_8
|
||||||
decl temp_b_59 : unit → bool;
|
else:
|
||||||
let func temp_b_59 (__60 : unit) =
|
temp_b_47 = ENone ()
|
||||||
return false;
|
| ESome x_49 →
|
||||||
decl temp_b_61 : unit → A {y: bool; z: decimal};
|
temp_b_47 = ESome x_49;
|
||||||
let func temp_b_61 (__62 : unit) =
|
switch handle_exceptions [temp_b_47]:
|
||||||
raise Empty;
|
| ENone __50 →
|
||||||
temp_b_52 = handle_default [temp_b_53] temp_b_59 temp_b_61
|
if false:
|
||||||
with Empty:
|
temp_b_46 = ENone ()
|
||||||
fatal NoValue;
|
else:
|
||||||
decl b_51 : A {y: bool; z: decimal};
|
temp_b_46 = ENone ()
|
||||||
b_51 = temp_b_52;
|
| ESome x_51 →
|
||||||
return S {"a": a_50, "b": b_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
|
```catala-test-inline
|
||||||
@ -423,155 +443,205 @@ glob2 = (
|
|||||||
decimal_of_string("30.")),
|
decimal_of_string("30.")),
|
||||||
z = (decimal_of_string("123.") *
|
z = (decimal_of_string("123.") *
|
||||||
decimal_of_string("17.")))
|
decimal_of_string("17.")))
|
||||||
)
|
)
|
||||||
|
|
||||||
def s2(s2_in:S2In):
|
def s2(s2_in:S2In):
|
||||||
try:
|
perhaps_none_arg = handle_exceptions([], [])
|
||||||
def temp_a(_:Unit):
|
if perhaps_none_arg is None:
|
||||||
def temp_a_1(_:Unit):
|
if True:
|
||||||
return True
|
temp_a = (glob3(money_of_cents_string("4400")) +
|
||||||
def temp_a_2(_:Unit):
|
decimal_of_string("100."))
|
||||||
return (glob3(money_of_cents_string("4400")) +
|
else:
|
||||||
decimal_of_string("100."))
|
temp_a = None
|
||||||
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
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,
|
start_line=53, start_column=24,
|
||||||
end_line=53, end_column=43,
|
end_line=53, end_column=43,
|
||||||
law_headings=["Test toplevel function defs"]), [],
|
law_headings=["Test toplevel function defs"]
|
||||||
temp_a_1, temp_a_2)
|
)],
|
||||||
def temp_a_3(_:Unit):
|
[temp_a]
|
||||||
return False
|
)
|
||||||
def temp_a_4(_:Unit):
|
if perhaps_none_arg_1 is None:
|
||||||
raise Empty
|
if False:
|
||||||
temp_a_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
temp_a_1 = None
|
||||||
start_line=50, start_column=10,
|
else:
|
||||||
end_line=50, end_column=11,
|
temp_a_1 = None
|
||||||
law_headings=["Test toplevel function defs"]), [temp_a],
|
else:
|
||||||
temp_a_3, temp_a_4)
|
x_4 = perhaps_none_arg_1
|
||||||
except Empty:
|
temp_a_1 = x_4
|
||||||
|
perhaps_none_arg_2 = temp_a_1
|
||||||
|
if perhaps_none_arg_2 is None:
|
||||||
raise NoValue(SourcePosition(
|
raise NoValue(SourcePosition(
|
||||||
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
||||||
start_line=50, start_column=10,
|
start_line=50, start_column=10,
|
||||||
end_line=50, end_column=11,
|
end_line=50, end_column=11,
|
||||||
law_headings=["Test toplevel function defs"]))
|
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)
|
return S2(a = a)
|
||||||
|
|
||||||
def s3(s3_in:S3In):
|
def s3(s3_in:S3In):
|
||||||
try:
|
perhaps_none_arg_3 = handle_exceptions([], [])
|
||||||
def temp_a_6(_:Unit):
|
if perhaps_none_arg_3 is None:
|
||||||
def temp_a_7(_:Unit):
|
if True:
|
||||||
return True
|
temp_a_3 = (decimal_of_string("50.") +
|
||||||
def temp_a_8(_:Unit):
|
glob4(money_of_cents_string("4400"),
|
||||||
return (decimal_of_string("50.") +
|
decimal_of_string("55.")))
|
||||||
glob4(money_of_cents_string("4400"),
|
else:
|
||||||
decimal_of_string("55.")))
|
temp_a_3 = None
|
||||||
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
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,
|
start_line=74, start_column=24,
|
||||||
end_line=74, end_column=47,
|
end_line=74, end_column=47,
|
||||||
law_headings=["Test function def with two args"]), [],
|
law_headings=["Test function def with two args"]
|
||||||
temp_a_7, temp_a_8)
|
)],
|
||||||
def temp_a_9(_:Unit):
|
[temp_a_3]
|
||||||
return False
|
)
|
||||||
def temp_a_10(_:Unit):
|
if perhaps_none_arg_4 is None:
|
||||||
raise Empty
|
if False:
|
||||||
temp_a_11 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
temp_a_4 = None
|
||||||
start_line=71, start_column=10,
|
else:
|
||||||
end_line=71, end_column=11,
|
temp_a_4 = None
|
||||||
law_headings=["Test function def with two args"]), [temp_a_6],
|
else:
|
||||||
temp_a_9, temp_a_10)
|
x_6 = perhaps_none_arg_4
|
||||||
except Empty:
|
temp_a_4 = x_6
|
||||||
|
perhaps_none_arg_5 = temp_a_4
|
||||||
|
if perhaps_none_arg_5 is None:
|
||||||
raise NoValue(SourcePosition(
|
raise NoValue(SourcePosition(
|
||||||
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
||||||
start_line=71, start_column=10,
|
start_line=71, start_column=10,
|
||||||
end_line=71, end_column=11,
|
end_line=71, end_column=11,
|
||||||
law_headings=["Test function def with two args"]))
|
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)
|
return S3(a = a_1)
|
||||||
|
|
||||||
def s4(s4_in:S4In):
|
def s4(s4_in:S4In):
|
||||||
try:
|
perhaps_none_arg_6 = handle_exceptions([], [])
|
||||||
def temp_a_12(_:Unit):
|
if perhaps_none_arg_6 is None:
|
||||||
def temp_a_13(_:Unit):
|
if True:
|
||||||
return True
|
temp_a_6 = (glob5 + decimal_of_string("1."))
|
||||||
def temp_a_14(_:Unit):
|
else:
|
||||||
return (glob5 + decimal_of_string("1."))
|
temp_a_6 = None
|
||||||
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
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,
|
start_line=98, start_column=24,
|
||||||
end_line=98, end_column=34,
|
end_line=98, end_column=34,
|
||||||
law_headings=["Test inline defs in toplevel defs"]), [],
|
law_headings=["Test inline defs in toplevel defs"]
|
||||||
temp_a_13, temp_a_14)
|
)],
|
||||||
def temp_a_15(_:Unit):
|
[temp_a_6]
|
||||||
return False
|
)
|
||||||
def temp_a_16(_:Unit):
|
if perhaps_none_arg_7 is None:
|
||||||
raise Empty
|
if False:
|
||||||
temp_a_17 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
temp_a_7 = None
|
||||||
start_line=95, start_column=10,
|
else:
|
||||||
end_line=95, end_column=11,
|
temp_a_7 = None
|
||||||
law_headings=["Test inline defs in toplevel defs"]), [temp_a_12],
|
else:
|
||||||
temp_a_15, temp_a_16)
|
x_8 = perhaps_none_arg_7
|
||||||
except Empty:
|
temp_a_7 = x_8
|
||||||
|
perhaps_none_arg_8 = temp_a_7
|
||||||
|
if perhaps_none_arg_8 is None:
|
||||||
raise NoValue(SourcePosition(
|
raise NoValue(SourcePosition(
|
||||||
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
||||||
start_line=95, start_column=10,
|
start_line=95, start_column=10,
|
||||||
end_line=95, end_column=11,
|
end_line=95, end_column=11,
|
||||||
law_headings=["Test inline defs in toplevel defs"]))
|
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)
|
return S4(a = a_2)
|
||||||
|
|
||||||
def s(s_in:SIn):
|
def s(s_in:SIn):
|
||||||
try:
|
perhaps_none_arg_9 = handle_exceptions([], [])
|
||||||
def temp_a_18(_:Unit):
|
if perhaps_none_arg_9 is None:
|
||||||
def temp_a_19(_:Unit):
|
if True:
|
||||||
return True
|
temp_a_9 = (glob1 * glob1)
|
||||||
def temp_a_20(_:Unit):
|
else:
|
||||||
return (glob1 * glob1)
|
temp_a_9 = None
|
||||||
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
else:
|
||||||
start_line=18, start_column=24,
|
x_9 = perhaps_none_arg_9
|
||||||
end_line=18, end_column=37,
|
temp_a_9 = x_9
|
||||||
law_headings=["Test basic toplevel values defs"]), [],
|
perhaps_none_arg_10 = handle_exceptions(
|
||||||
temp_a_19, temp_a_20)
|
[SourcePosition(
|
||||||
def temp_a_21(_:Unit):
|
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
||||||
return False
|
start_line=18, start_column=24,
|
||||||
def temp_a_22(_:Unit):
|
end_line=18, end_column=37,
|
||||||
raise Empty
|
law_headings=["Test basic toplevel values defs"]
|
||||||
temp_a_23 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
)],
|
||||||
start_line=7, start_column=10,
|
[temp_a_9]
|
||||||
end_line=7, end_column=11,
|
)
|
||||||
law_headings=["Test basic toplevel values defs"]), [temp_a_18],
|
if perhaps_none_arg_10 is None:
|
||||||
temp_a_21, temp_a_22)
|
if False:
|
||||||
except Empty:
|
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(
|
raise NoValue(SourcePosition(
|
||||||
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
||||||
start_line=7, start_column=10,
|
start_line=7, start_column=10,
|
||||||
end_line=7, end_column=11,
|
end_line=7, end_column=11,
|
||||||
law_headings=["Test basic toplevel values defs"]))
|
law_headings=["Test basic toplevel values defs"]))
|
||||||
a_3 = temp_a_23
|
else:
|
||||||
try:
|
arg_3 = perhaps_none_arg_11
|
||||||
def temp_b(_:Unit):
|
temp_a_11 = arg_3
|
||||||
def temp_b_1(_:Unit):
|
a_3 = temp_a_11
|
||||||
return True
|
perhaps_none_arg_12 = handle_exceptions([], [])
|
||||||
def temp_b_2(_:Unit):
|
if perhaps_none_arg_12 is None:
|
||||||
return glob2
|
if True:
|
||||||
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
temp_b = glob2
|
||||||
start_line=19, start_column=24,
|
else:
|
||||||
end_line=19, end_column=29,
|
temp_b = None
|
||||||
law_headings=["Test basic toplevel values defs"]), [],
|
else:
|
||||||
temp_b_1, temp_b_2)
|
x_11 = perhaps_none_arg_12
|
||||||
def temp_b_3(_:Unit):
|
temp_b = x_11
|
||||||
return False
|
perhaps_none_arg_13 = handle_exceptions(
|
||||||
def temp_b_4(_:Unit):
|
[SourcePosition(
|
||||||
raise Empty
|
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
||||||
temp_b_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
start_line=19, start_column=24,
|
||||||
start_line=8, start_column=10,
|
end_line=19, end_column=29,
|
||||||
end_line=8, end_column=11,
|
law_headings=["Test basic toplevel values defs"]
|
||||||
law_headings=["Test basic toplevel values defs"]), [temp_b],
|
)],
|
||||||
temp_b_3, temp_b_4)
|
[temp_b]
|
||||||
except Empty:
|
)
|
||||||
|
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(
|
raise NoValue(SourcePosition(
|
||||||
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
filename="tests/name_resolution/good/toplevel_defs.catala_en",
|
||||||
start_line=8, start_column=10,
|
start_line=8, start_column=10,
|
||||||
end_line=8, end_column=11,
|
end_line=8, end_column=11,
|
||||||
law_headings=["Test basic toplevel values defs"]))
|
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)
|
return S(a = a_3, b = b)
|
||||||
```
|
```
|
||||||
|
@ -39,11 +39,11 @@ $ catala Scalc -s Foo2 -O -t
|
|||||||
│ 5 │ output bar content integer
|
│ 5 │ output bar content integer
|
||||||
│ │ ‾‾‾
|
│ │ ‾‾‾
|
||||||
└─ Test
|
└─ Test
|
||||||
let Foo2_3 (Foo2_in_2: Foo2_in) =
|
let Foo2_1 (Foo2_in_1: Foo2_in) =
|
||||||
decl temp_bar_4 : integer;
|
decl temp_bar_3 : integer;
|
||||||
fatal NoValue;
|
fatal NoValue;
|
||||||
decl bar_3 : integer;
|
decl bar_2 : integer;
|
||||||
bar_3 = temp_bar_4;
|
bar_2 = temp_bar_3;
|
||||||
return Foo2 {"bar": bar_3}
|
return Foo2 {"bar": bar_2}
|
||||||
|
|
||||||
```
|
```
|
||||||
|
@ -68,7 +68,7 @@ $ catala interpret -s RentComputation --debug
|
|||||||
```
|
```
|
||||||
|
|
||||||
```catala-test-inline
|
```catala-test-inline
|
||||||
$ catala Interpret --lcalc -s RentComputation --avoid-exceptions --optimize --debug
|
$ catala Interpret --lcalc -s RentComputation --optimize --debug
|
||||||
[DEBUG] = INIT =
|
[DEBUG] = INIT =
|
||||||
[DEBUG] = SURFACE =
|
[DEBUG] = SURFACE =
|
||||||
[DEBUG] Parsing "tests/scope/good/scope_call4.catala_en"
|
[DEBUG] Parsing "tests/scope/good/scope_call4.catala_en"
|
||||||
|
@ -24,12 +24,20 @@ $ catala Typecheck --check-invariants
|
|||||||
$ catala Lcalc -s Foo
|
$ catala Lcalc -s Foo
|
||||||
let scope Foo (Foo_in: Foo_in): Foo {bar: integer} =
|
let scope Foo (Foo_in: Foo_in): Foo {bar: integer} =
|
||||||
let set bar : integer =
|
let set bar : integer =
|
||||||
try
|
match
|
||||||
handle_default
|
(match
|
||||||
[λ () → handle_default [] (λ () → true) (λ () → 0)]
|
(handle_exceptions
|
||||||
(λ () → false)
|
[
|
||||||
(λ () → raise Empty)
|
match (handle_exceptions []) with
|
||||||
with Empty -> error NoValue
|
| 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
|
in
|
||||||
return { Foo bar = bar; }
|
return { Foo bar = bar; }
|
||||||
```
|
```
|
||||||
|
Loading…
Reference in New Issue
Block a user