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

Fix some statement orderings in scalc (#608)

Browse Source
This commit is contained in:
Louis Gesbert 2024-04-23 16:40:31 +02:00 committed by GitHub
commit 3e2aa54b81
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
11 changed files with 380 additions and 362 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
build_system/clerk_driver.ml
View File

@ -357,11 +357,11 @@ module Poll = struct
running from the root of a compiled source tree.@]"
d)
let ocaml_link_flags : string list Lazy.t =
let ocaml_include_and_lib_flags : (string list * string list) Lazy.t =
lazy
(let link_libs = ["zarith"; "dates_calc"] in
let link_libs_flags =
List.concat_map
let includes_libs =
List.map
(fun lib ->
match File.(check_directory (Lazy.force ocaml_libdir / lib)) with
| None ->
@ -372,15 +372,19 @@ module Poll = struct
File.(Lazy.force ocaml_libdir / lib)
lib
| Some d ->
[
"-I";
d;
String.map (function '-' -> '_' | c -> c) lib ^ ".cmxa";
])
( ["-I"; d],
String.map (function '-' -> '_' | c -> c) lib ^ ".cmxa" ))
link_libs
in
let runtime_dir = Lazy.force ocaml_runtime_dir in
link_libs_flags @ [File.(runtime_dir / "runtime_ocaml.cmxa")])
let includes, libs = List.split includes_libs in
( List.concat includes @ ["-I"; Lazy.force ocaml_runtime_dir],
libs @ [File.(Lazy.force ocaml_runtime_dir / "runtime_ocaml.cmxa")] ))
let ocaml_include_flags : string list Lazy.t =
lazy (fst (Lazy.force ocaml_include_and_lib_flags))
let ocaml_link_flags : string list Lazy.t =
lazy (snd (Lazy.force ocaml_include_and_lib_flags))
let has_command cmd =
let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in
@ -471,7 +475,7 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
| _ -> false)
test_flags
in
let ocaml_flags = ["-I"; Lazy.force Poll.ocaml_runtime_dir] in
let ocaml_flags = Lazy.force Poll.ocaml_include_flags in
[
Nj.binding Var.ninja_required_version ["1.7"];
(* use of implicit outputs *)
@ -528,7 +532,7 @@ let[@ocamlformat "disable"] static_base_rules =
Nj.rule "ocaml-exec"
~command: [
!ocamlopt_exe; !runtime_ocaml_libs; !ocaml_flags;
!ocamlopt_exe; !ocaml_flags; !runtime_ocaml_libs;
shellout [!catala_exe; "depends";
"--prefix="^ !builddir; "--extension=cmx";
!catala_flags; !orig_src];

21
compiler/driver.ml
View File

@ -244,19 +244,20 @@ module Passes = struct
let avoid_exceptions = avoid_exceptions || closure_conversion in
(* --closure-conversion implies --avoid-exceptions *)
let prg =
match avoid_exceptions, options.trace, typed with
| true, true, _ ->
Message.error
"Option --avoid-exceptions is not compatible with option --trace"
| true, _, Untyped _ ->
if avoid_exceptions && options.trace then
Message.warning
"It is discouraged to use option @{<yellow>--avoid-exceptions@} if \
you@ also@ need@ @{<yellow>--trace@},@ the@ resulting@ trace@ may@ \
be@ unreliable@ at@ the@ moment.";
match avoid_exceptions, typed with
| true, Untyped _ ->
Lcalc.From_dcalc.translate_program_without_exceptions prg
| true, _, Typed _ ->
| true, Typed _ ->
Lcalc.From_dcalc.translate_program_without_exceptions prg
| false, _, Typed _ ->
| false, Typed _ -> Lcalc.From_dcalc.translate_program_with_exceptions prg
| false, Untyped _ ->
Lcalc.From_dcalc.translate_program_with_exceptions prg
| false, _, Untyped _ ->
Lcalc.From_dcalc.translate_program_with_exceptions prg
| _, _, Custom _ -> invalid_arg "Driver.Passes.lcalc"
| _, Custom _ -> invalid_arg "Driver.Passes.lcalc"
in
let prg =
if optimize then begin

6
compiler/plugins/api_web.ml
View File

@ -74,8 +74,7 @@ module To_jsoo = struct
(* Tuples are encoded as an javascript polymorphic array. *)
Format.fprintf fmt "Js.Unsafe.any_js_array Js.t "
| TOption t ->
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
format_enum_name Expr.option_enum
Format.fprintf fmt "@[<hov 2>(%a)@] Js.opt" format_typ_with_parens t
| TDefault t -> format_typ fmt t
| TEnum e -> Format.fprintf fmt "%a Js.t" format_enum_name e
| TArray t1 ->
@ -116,7 +115,8 @@ module To_jsoo = struct
elts
| TOption t ->
Format.fprintf fmt
"(function Eoption.ENone -> Js.null | Eoption.ESome x -> %a x)"
"(function Eoption.ENone () -> Js.null | Eoption.ESome x -> Js.some \
(%a x))"
format_to_js t
| TAny -> Format.fprintf fmt "Js.Unsafe.inject"
| TArrow _ | TClosureEnv -> ()

429
compiler/scalc/from_lcalc.ml
View File

@ -49,7 +49,40 @@ exception NotAnExpr of { needs_a_local_decl : bool }
(** Contains the LocalDecl of the temporary variable that will be defined by the
next block is it's here *)
let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
(** Blocks are constructed as reverse ordered lists. This module abstracts this
and avoids confusion in ordering of statements (also opening the opportunity
for more optimisations) *)
module RevBlock : sig
type t = private A.block
val empty : t
val append : t -> A.stmt Mark.pos -> t
val make : A.block -> t
val seq : t -> t -> t
val rebuild : t -> tail:A.block -> A.block
end = struct
type t = A.block
let empty = []
let append t st = st :: t
let make st = List.rev st
let seq t1 t2 = t2 @ t1
let rebuild t ~tail = List.rev_append t tail
end
let ( ++ ) = RevBlock.seq
let rec translate_expr_list ctxt args =
let stmts, args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
args_stmts ++ arg_stmts, new_arg :: new_args)
(RevBlock.empty, []) args
in
stmts, List.rev args
and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr =
try
match Mark.remove expr with
| EVar v ->
@ -65,7 +98,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
Print.var_debug ppf v))
(Var.Map.keys ctxt.var_dict))
in
[], (local_var, Expr.pos expr)
RevBlock.empty, (local_var, Expr.pos expr)
| EStruct { fields; name } ->
if ctxt.config.no_struct_literals then
(* In C89, struct literates have to be initialized at variable
@ -75,11 +108,10 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
StructField.Map.fold
(fun field arg (args_stmts, new_args) ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, StructField.Map.add field new_arg new_args)
args_stmts ++ arg_stmts, StructField.Map.add field new_arg new_args)
fields
([], StructField.Map.empty)
(RevBlock.empty, StructField.Map.empty)
in
let args_stmts = List.rev args_stmts in
args_stmts, (A.EStruct { fields = new_args; name }, Expr.pos expr)
| EInj { e = e1; cons; name } ->
if ctxt.config.no_struct_literals then
@ -97,14 +129,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
},
Expr.pos expr ) )
| ETuple args ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
([], []) args
in
let new_args = List.rev new_args in
let args_stmts, new_args = translate_expr_list ctxt args in
args_stmts, (A.ETuple new_args, Expr.pos expr)
| EStructAccess { e = e1; field; name } ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
@ -123,15 +148,8 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
(* This should be translated as a statement *)
raise (NotAnExpr { needs_a_local_decl = true })
| EAppOp { op; args; tys = _ } ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
([], []) 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 ? *)
let new_args = List.rev new_args in
args_stmts, (A.EAppOp { op; args = new_args }, Expr.pos expr)
| EApp { f = EAbs { binder; tys }, binder_mark; args; tys = _ } ->
(* This defines multiple local variables at the time *)
@ -151,12 +169,13 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
}
in
let local_decls =
List.map
(fun (x, tau) ->
( A.SLocalDecl
{ name = Var.Map.find x ctxt.var_dict, binder_pos; typ = tau },
binder_pos ))
vars_tau
List.fold_left
(fun acc (x, tau) ->
RevBlock.append acc
( A.SLocalDecl
{ name = Var.Map.find x ctxt.var_dict, binder_pos; typ = tau },
binder_pos ))
RevBlock.empty vars_tau
in
let vars_args =
List.map2
@ -165,8 +184,8 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
vars_tau args
in
let def_blocks =
List.map
(fun (x, _tau, arg) ->
List.fold_left
(fun acc (x, _tau, arg) ->
let ctxt =
{
ctxt with
@ -175,44 +194,28 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
}
in
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts
@ [
( A.SLocalDef
{
name = x;
expr = new_arg;
typ = Expr.maybe_ty (Mark.get arg);
},
binder_pos );
])
vars_args
RevBlock.append (acc ++ arg_stmts)
( A.SLocalDef
{
name = x;
expr = new_arg;
typ = Expr.maybe_ty (Mark.get arg);
},
binder_pos ))
RevBlock.empty vars_args
in
let rest_of_expr_stmts, rest_of_expr = translate_expr ctxt body in
local_decls @ List.flatten def_blocks @ rest_of_expr_stmts, rest_of_expr
local_decls ++ def_blocks ++ rest_of_expr_stmts, rest_of_expr
| EApp { f; args; tys = _ } ->
let f_stmts, new_f = translate_expr ctxt f in
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
([], []) 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 ? *)
let new_args = List.rev new_args in
( f_stmts @ args_stmts,
( f_stmts ++ args_stmts,
(A.EApp { f = new_f; args = new_args }, Expr.pos expr) )
| EArray args ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
([], []) args
in
let new_args = List.rev new_args in
let args_stmts, new_args = translate_expr_list ctxt args in
args_stmts, (A.EArray new_args, Expr.pos expr)
| ELit l -> [], (A.ELit l, Expr.pos expr)
| ELit l -> RevBlock.empty, (A.ELit l, Expr.pos expr)
| EExternal { name } ->
let path, name =
match Mark.remove name with
@ -223,7 +226,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
( ModuleName.Map.find (List.hd (List.rev path)) ctxt.program_ctx.modules,
Expr.pos expr )
in
[], (EExternal { modname; name }, Expr.pos expr)
RevBlock.empty, (EExternal { modname; name }, Expr.pos expr)
| ECatch _ | EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ | ERaise _ ->
raise (NotAnExpr { needs_a_local_decl = true })
| _ -> .
@ -250,16 +253,15 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
in
let tmp_stmts = translate_statements ctxt expr in
( (if needs_a_local_decl then
[
( A.SLocalDecl
{
name = tmp_var, Expr.pos expr;
typ = Expr.maybe_ty (Mark.get expr);
},
Expr.pos expr );
]
else [])
@ tmp_stmts,
RevBlock.make
(( A.SLocalDecl
{
name = tmp_var, Expr.pos expr;
typ = Expr.maybe_ty (Mark.get expr);
},
Expr.pos expr )
:: tmp_stmts)
else RevBlock.make tmp_stmts),
(A.EVar tmp_var, Expr.pos expr) )
and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
@ -267,7 +269,9 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
| EAssert e ->
(* Assertions are always encapsulated in a unit-typed let binding *)
let e_stmts, new_e = translate_expr ctxt e in
e_stmts @ [A.SAssert (Mark.remove new_e), Expr.pos block_expr]
RevBlock.rebuild
~tail:[A.SAssert (Mark.remove new_e), Expr.pos block_expr]
e_stmts
| EAppOp
{ op = Op.HandleDefaultOpt; tys = _; args = [exceptions; just; cons] }
when ctxt.config.keep_special_ops ->
@ -288,40 +292,40 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
let just = unthunk just in
let cons = unthunk cons in
let exceptions_stmts, new_exceptions =
List.fold_left
(fun (exceptions_stmts, new_exceptions) except ->
let except_stmts, new_except = translate_expr ctxt except in
except_stmts @ exceptions_stmts, new_except :: new_exceptions)
([], []) exceptions
translate_expr_list ctxt exceptions
in
let just_stmts, new_just = translate_expr ctxt just in
let cons_stmts, new_cons = translate_expr ctxt cons in
exceptions_stmts
@ just_stmts
@ [
( A.SSpecialOp
(OHandleDefaultOpt
{
exceptions = new_exceptions;
just = new_just;
cons =
cons_stmts
@ [
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Mark.remove new_cons)
| Some x ->
A.SLocalDef
{
name = Mark.copy new_cons x;
expr = new_cons;
typ = Expr.maybe_ty (Mark.get block_expr);
}),
Expr.pos block_expr );
];
return_typ = Expr.maybe_ty (Mark.get block_expr);
}),
Expr.pos block_expr );
]
RevBlock.rebuild exceptions_stmts
~tail:
(RevBlock.rebuild just_stmts
~tail:
[
( A.SSpecialOp
(OHandleDefaultOpt
{
exceptions = new_exceptions;
just = new_just;
cons =
RevBlock.rebuild cons_stmts
~tail:
[
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Mark.remove new_cons)
| Some x ->
A.SLocalDef
{
name = Mark.copy new_cons x;
expr = new_cons;
typ =
Expr.maybe_ty (Mark.get block_expr);
}),
Expr.pos block_expr );
];
return_typ = Expr.maybe_ty (Mark.get block_expr);
}),
Expr.pos block_expr );
])
| EApp { f = EAbs { binder; tys }, binder_mark; args; _ } ->
(* This defines multiple local variables at the time *)
let binder_pos = Expr.mark_pos binder_mark in
@ -364,16 +368,17 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
}
in
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts
@ [
( A.SLocalDef
{
name = x;
expr = new_arg;
typ = Expr.maybe_ty (Mark.get arg);
},
binder_pos );
])
RevBlock.rebuild arg_stmts
~tail:
[
( A.SLocalDef
{
name = x;
expr = new_arg;
typ = Expr.maybe_ty (Mark.get arg);
},
binder_pos );
])
vars_args
in
let rest_of_block = translate_statements ctxt body in
@ -417,7 +422,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
(match Expr.maybe_ty (Mark.get block_expr) with
| TArrow (_, t2), _ -> t2
| TAny, pos_any -> TAny, pos_any
| _ -> failwith "should not happen");
| _ -> assert false);
};
},
binder_pos );
@ -445,32 +450,37 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
payload_var_typ = List.hd tys;
}
:: new_args
| _ -> assert false
(* should not happen *))
| _ -> assert false)
cases []
in
let new_args = List.rev new_cases in
e1_stmts
@ [
( A.SSwitch
{
switch_expr = new_e1;
switch_expr_typ = Expr.maybe_ty (Mark.get e1);
enum_name = name;
switch_cases = new_args;
},
Expr.pos block_expr );
]
RevBlock.rebuild e1_stmts
~tail:
[
( A.SSwitch
{
switch_expr = new_e1;
switch_expr_typ = Expr.maybe_ty (Mark.get e1);
enum_name = name;
switch_cases = new_args;
},
Expr.pos block_expr );
]
| EIfThenElse { cond; etrue; efalse } ->
let cond_stmts, s_cond = translate_expr ctxt cond in
let s_e_true = translate_statements ctxt etrue in
let s_e_false = translate_statements ctxt efalse in
cond_stmts
@ [
( A.SIfThenElse
{ if_expr = s_cond; then_block = s_e_true; else_block = s_e_false },
Expr.pos block_expr );
]
RevBlock.rebuild cond_stmts
~tail:
[
( A.SIfThenElse
{
if_expr = s_cond;
then_block = s_e_true;
else_block = s_e_false;
},
Expr.pos block_expr );
]
| ECatch { body; exn; handler } ->
let s_e_try = translate_statements ctxt body in
let s_e_catch = translate_statements ctxt handler in
@ -514,28 +524,28 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
},
Expr.pos block_expr )
in
e1_stmts
@ [
( A.SLocalInit
{
name = tmp_struct_var_name;
expr = inj_expr;
typ =
( Mark.remove (Expr.maybe_ty (Mark.get block_expr)),
Expr.pos block_expr );
},
Expr.pos block_expr );
]
RevBlock.rebuild e1_stmts
~tail:
[
( A.SLocalInit
{
name = tmp_struct_var_name;
expr = inj_expr;
typ =
( Mark.remove (Expr.maybe_ty (Mark.get block_expr)),
Expr.pos block_expr );
},
Expr.pos block_expr );
]
| EStruct { fields; name } when ctxt.config.no_struct_literals ->
let args_stmts, new_args =
StructField.Map.fold
(fun field arg (args_stmts, new_args) ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, StructField.Map.add field new_arg new_args)
args_stmts ++ arg_stmts, StructField.Map.add field new_arg new_args)
fields
([], StructField.Map.empty)
(RevBlock.empty, StructField.Map.empty)
in
let args_stmts = List.rev args_stmts in
let struct_expr =
A.EStruct { fields = new_args; name }, Expr.pos block_expr
in
@ -546,40 +556,42 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
(* [translate_expr] should create this [inside_definition_of]*)
| Some x -> x, Expr.pos block_expr
in
args_stmts
@ [
( A.SLocalInit
{
name = tmp_struct_var_name;
expr = struct_expr;
typ = TStruct name, Expr.pos block_expr;
},
Expr.pos block_expr );
]
| ELit _ | EAppOp _ | EArray _ | EVar _ | EStruct _ | EInj _ | ETuple _
| ETupleAccess _ | EStructAccess _ | EExternal _ | EApp _ -> (
let e_stmts, new_e = translate_expr ctxt block_expr in
e_stmts
@
match e_stmts with
| (A.SRaise _, _) :: _ ->
(* if the last statement raises an exception, then we don't need to return
or to define the current variable since this code will be
unreachable *)
[]
| _ ->
[
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Mark.remove new_e)
| Some x ->
A.SLocalDef
RevBlock.rebuild args_stmts
~tail:
[
( A.SLocalInit
{
name = Mark.copy new_e x;
expr = new_e;
typ = Expr.maybe_ty (Mark.get block_expr);
}),
Expr.pos block_expr );
])
name = tmp_struct_var_name;
expr = struct_expr;
typ = TStruct name, Expr.pos block_expr;
},
Expr.pos block_expr );
]
| ELit _ | EAppOp _ | EArray _ | EVar _ | EStruct _ | EInj _ | ETuple _
| ETupleAccess _ | EStructAccess _ | EExternal _ | EApp _ ->
let e_stmts, new_e = translate_expr ctxt block_expr in
let tail =
match (e_stmts :> (A.stmt * Pos.t) list) with
| (A.SRaise _, _) :: _ ->
(* if the last statement raises an exception, then we don't need to
return or to define the current variable since this code will be
unreachable *)
[]
| _ ->
[
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Mark.remove new_e)
| Some x ->
A.SLocalDef
{
name = Mark.copy new_e x;
expr = new_e;
typ = Expr.maybe_ty (Mark.get block_expr);
}),
Expr.pos block_expr );
]
in
RevBlock.rebuild e_stmts ~tail
| _ -> .
let rec translate_scope_body_expr
@ -602,42 +614,45 @@ let rec translate_scope_body_expr
match scope_expr with
| Last e ->
let block, new_e = translate_expr ctx e in
block @ [A.SReturn (Mark.remove new_e), Mark.get new_e]
| Cons (scope_let, next_bnd) ->
RevBlock.rebuild block ~tail:[A.SReturn (Mark.remove new_e), Mark.get new_e]
| Cons (scope_let, next_bnd) -> (
let let_var, scope_let_next = Bindlib.unbind next_bnd in
let let_var_id =
A.VarName.fresh (Bindlib.name_of let_var, scope_let.scope_let_pos)
in
let new_var_dict = Var.Map.add let_var let_var_id var_dict in
(match scope_let.scope_let_kind with
let next =
translate_scope_body_expr ~config scope_name program_ctx new_var_dict
func_dict scope_let_next
in
match scope_let.scope_let_kind with
| Assertion ->
translate_statements
{ ctx with inside_definition_of = Some let_var_id }
scope_let.scope_let_expr
@ next
| _ ->
let let_expr_stmts, new_let_expr =
translate_expr
{ ctx with inside_definition_of = Some let_var_id }
scope_let.scope_let_expr
in
let_expr_stmts
@ [
( A.SLocalDecl
{
name = let_var_id, scope_let.scope_let_pos;
typ = scope_let.scope_let_typ;
},
scope_let.scope_let_pos );
( A.SLocalDef
{
name = let_var_id, scope_let.scope_let_pos;
expr = new_let_expr;
typ = scope_let.scope_let_typ;
},
scope_let.scope_let_pos );
])
@ translate_scope_body_expr ~config scope_name program_ctx new_var_dict
func_dict scope_let_next
RevBlock.rebuild let_expr_stmts
~tail:
(( A.SLocalDecl
{
name = let_var_id, scope_let.scope_let_pos;
typ = scope_let.scope_let_typ;
},
scope_let.scope_let_pos )
:: ( A.SLocalDef
{
name = let_var_id, scope_let.scope_let_pos;
expr = new_let_expr;
typ = scope_let.scope_let_typ;
},
scope_let.scope_let_pos )
:: next))
let translate_program ~(config : translation_config) (p : 'm L.program) :
A.program =
@ -723,7 +738,8 @@ let translate_program ~(config : translation_config) (p : 'm L.program) :
translate_expr ctxt expr
in
let body_block =
block @ [A.SReturn (Mark.remove expr), Mark.get expr]
RevBlock.rebuild block
~tail:[A.SReturn (Mark.remove expr), Mark.get expr]
in
( Var.Map.add var func_id func_dict,
var_dict,
@ -761,9 +777,9 @@ let translate_program ~(config : translation_config) (p : 'm L.program) :
(* If the evaluation of the toplevel expr requires preliminary
statements, we lift its computation into an auxiliary function *)
let rev_items =
match block with
| [] -> A.SVar { var = var_id; expr; typ = topdef_ty } :: rev_items
| block ->
if (block :> (A.stmt * Pos.t) list) = [] then
A.SVar { var = var_id; expr; typ = topdef_ty } :: rev_items
else
let pos = Mark.get expr in
let func_id =
A.FuncName.fresh (Bindlib.name_of var ^ "_aux", pos)
@ -783,7 +799,8 @@ let translate_program ~(config : translation_config) (p : 'm L.program) :
{
A.func_params = [];
A.func_body =
block @ [A.SReturn (Mark.remove expr), Mark.get expr];
RevBlock.rebuild block
~tail:[A.SReturn (Mark.remove expr), Mark.get expr];
A.func_return_typ = topdef_ty;
};
}

16
compiler/scalc/to_python.ml
View File

@ -447,16 +447,12 @@ let rec format_statement ctx (fmt : Format.formatter) (s : stmt Mark.pos) : unit
when EnumName.equal e_name Expr.option_enum ->
(* We translate the option type with an overloading by Python's [None] *)
let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in
Format.fprintf fmt
"%a = %a@\n\
@[<hov 4>if %a is None:@\n\
%a@]@\n\
@[<hov 4>else:@\n\
%a = %a@\n\
%a@]"
format_var tmp_var (format_expression ctx) e1 format_var tmp_var
(format_block ctx) case_none format_var case_some_var format_var tmp_var
(format_block ctx) case_some
Format.fprintf fmt "%a = %a@\n" format_var tmp_var (format_expression ctx)
e1;
Format.fprintf fmt "@[<v 4>if %a is None:@\n%a@]@\n" format_var tmp_var
(format_block ctx) case_none;
Format.fprintf fmt "@[<v 4>else:@\n%a = %a@\n%a@]" format_var case_some_var
format_var tmp_var (format_block ctx) case_some
| SSwitch { switch_expr = e1; enum_name = e_name; switch_cases = cases; _ } ->
let cons_map = EnumName.Map.find e_name ctx.decl_ctx.ctx_enums in
let cases =

2
doc/syntax/syntax_en.catala_en
View File

@ -241,7 +241,7 @@ declaration x content integer equals
in
let x equals
content of x among lst
such that (x * x) is minimum
such that x * x is minimum
or if list empty then -1
in
0

4
doc/syntax/syntax_en.tex
View File

@ -187,7 +187,7 @@
\begin{catala}
> Using Mdl as M
\end{catala}
& Module import w/ alias
& Module import+alias
\\
\begin{catala}
> Include: foo.catala_en
@ -733,7 +733,7 @@
\begin{catala}
```catala
content of x among lst
such that (x * x) is minimum
such that x * x is minimum
or if list empty then -1
```
\end{catala}

2
doc/syntax/syntax_fr.catala_fr
View File

@ -239,7 +239,7 @@ déclaration x contenu entier égal à
dans
soit x égal à
contenu de x parmi lst
tel que (x * x) est minimum
tel que x * x est minimum
ou si liste vide alors -1
dans
0

2
doc/syntax/syntax_fr.tex
View File

@ -738,7 +738,7 @@
\begin{catala}
```catala
contenu de x parmi lst
tel que (x * x) est minimum
tel que x * x est minimum
ou si liste vide alors -1
```
\end{catala}

42
tests/backends/python_name_clash.catala_en
View File

@ -93,23 +93,23 @@ def some_name(some_name_in:SomeNameIn):
i = some_name_in.i_in
try:
def temp_o(_:Unit):
raise EmptyError
def temp_o_1(_:Unit):
return False
def temp_o_2(_:Unit):
def temp_o_3(_:Unit):
return (i + integer_of_string("1"))
def temp_o_4(_:Unit):
def temp_o_1(_:Unit):
return True
def temp_o_2(_:Unit):
return (i + integer_of_string("1"))
return handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
start_line=7, start_column=10,
end_line=7, end_column=11,
law_headings=[]), [], temp_o_4, temp_o_3)
law_headings=[]), [], temp_o_1, temp_o_2)
def temp_o_3(_:Unit):
return False
def temp_o_4(_:Unit):
raise EmptyError
temp_o_5 = handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
start_line=7, start_column=10,
end_line=7, end_column=11,
law_headings=[]), [temp_o_2], temp_o_1,
temp_o)
law_headings=[]), [temp_o], temp_o_3,
temp_o_4)
except EmptyError:
temp_o_5 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
@ -122,24 +122,24 @@ def some_name(some_name_in:SomeNameIn):
def b(b_in:BIn):
try:
def temp_result(_:Unit):
raise EmptyError
def temp_result_1(_:Unit):
return False
def temp_result_2(_:Unit):
def temp_result_3(_:Unit):
return integer_of_string("1")
def temp_result_4(_:Unit):
def temp_result_1(_:Unit):
return True
def temp_result_2(_:Unit):
return integer_of_string("1")
return handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
start_line=16, start_column=14,
end_line=16, end_column=25,
law_headings=[]), [], temp_result_4,
temp_result_3)
law_headings=[]), [], temp_result_1,
temp_result_2)
def temp_result_3(_:Unit):
return False
def temp_result_4(_:Unit):
raise EmptyError
temp_result_5 = handle_default(SourcePosition(filename="tests/backends/python_name_clash.catala_en",
start_line=16, start_column=14,
end_line=16, end_column=25,
law_headings=[]), [temp_result_2],
temp_result_1, temp_result)
law_headings=[]), [temp_result],
temp_result_3, temp_result_4)
except EmptyError:
temp_result_5 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/backends/python_name_clash.catala_en",

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

@ -119,21 +119,21 @@ let glob2_9 = A {"y": glob1_2 >= 30., "z": 123. * 17.}
let S2_6 (S2_in_10: S2_in) =
decl temp_a_12 : decimal;
try:
decl temp_a_21 : unit → decimal;
let func temp_a_21 (__22 : unit) =
raise EmptyError;
decl temp_a_19 : unit → bool;
let func temp_a_19 (__20 : unit) =
return false;
decl temp_a_13 : unit → decimal;
let func temp_a_13 (__14 : unit) =
decl temp_a_17 : unit → decimal;
let func temp_a_17 (__18 : unit) =
return glob3_3 ¤44.00 + 100.;
decl temp_a_15 : unit → bool;
let func temp_a_15 (__16 : unit) =
return true;
decl temp_a_17 : unit → decimal;
let func temp_a_17 (__18 : unit) =
return glob3_3 ¤44.00 + 100.;
return handle_default [] temp_a_15 temp_a_17;
decl temp_a_19 : unit → bool;
let func temp_a_19 (__20 : unit) =
return false;
decl temp_a_21 : unit → decimal;
let func temp_a_21 (__22 : unit) =
raise EmptyError;
temp_a_12 = handle_default [temp_a_13] temp_a_19 temp_a_21
with EmptyError:
raise NoValueProvided;
@ -144,21 +144,21 @@ let S2_6 (S2_in_10: S2_in) =
let S3_7 (S3_in_23: S3_in) =
decl temp_a_25 : decimal;
try:
decl temp_a_34 : unit → decimal;
let func temp_a_34 (__35 : unit) =
raise EmptyError;
decl temp_a_32 : unit → bool;
let func temp_a_32 (__33 : unit) =
return false;
decl temp_a_26 : unit → decimal;
let func temp_a_26 (__27 : unit) =
decl temp_a_30 : unit → decimal;
let func temp_a_30 (__31 : unit) =
return 50. + glob4_4 ¤44.00 55.;
decl temp_a_28 : unit → bool;
let func temp_a_28 (__29 : unit) =
return true;
decl temp_a_30 : unit → decimal;
let func temp_a_30 (__31 : unit) =
return 50. + glob4_4 ¤44.00 55.;
return handle_default [] temp_a_28 temp_a_30;
decl temp_a_32 : unit → bool;
let func temp_a_32 (__33 : unit) =
return false;
decl temp_a_34 : unit → decimal;
let func temp_a_34 (__35 : unit) =
raise EmptyError;
temp_a_25 = handle_default [temp_a_26] temp_a_32 temp_a_34
with EmptyError:
raise NoValueProvided;
@ -169,21 +169,21 @@ let S3_7 (S3_in_23: S3_in) =
let S4_8 (S4_in_36: S4_in) =
decl temp_a_38 : decimal;
try:
decl temp_a_47 : unit → decimal;
let func temp_a_47 (__48 : unit) =
raise EmptyError;
decl temp_a_45 : unit → bool;
let func temp_a_45 (__46 : unit) =
return false;
decl temp_a_39 : unit → decimal;
let func temp_a_39 (__40 : unit) =
decl temp_a_43 : unit → decimal;
let func temp_a_43 (__44 : unit) =
return glob5_6 + 1.;
decl temp_a_41 : unit → bool;
let func temp_a_41 (__42 : unit) =
return true;
decl temp_a_43 : unit → decimal;
let func temp_a_43 (__44 : unit) =
return glob5_6 + 1.;
return handle_default [] temp_a_41 temp_a_43;
decl temp_a_45 : unit → bool;
let func temp_a_45 (__46 : unit) =
return false;
decl temp_a_47 : unit → decimal;
let func temp_a_47 (__48 : unit) =
raise EmptyError;
temp_a_38 = handle_default [temp_a_39] temp_a_45 temp_a_47
with EmptyError:
raise NoValueProvided;
@ -194,21 +194,21 @@ let S4_8 (S4_in_36: S4_in) =
let S_9 (S_in_49: S_in) =
decl temp_a_63 : decimal;
try:
decl temp_a_72 : unit → decimal;
let func temp_a_72 (__73 : unit) =
raise EmptyError;
decl temp_a_70 : unit → bool;
let func temp_a_70 (__71 : unit) =
return false;
decl temp_a_64 : unit → decimal;
let func temp_a_64 (__65 : unit) =
decl temp_a_68 : unit → decimal;
let func temp_a_68 (__69 : unit) =
return glob1_2 * glob1_2;
decl temp_a_66 : unit → bool;
let func temp_a_66 (__67 : unit) =
return true;
decl temp_a_68 : unit → decimal;
let func temp_a_68 (__69 : unit) =
return glob1_2 * glob1_2;
return handle_default [] temp_a_66 temp_a_68;
decl temp_a_70 : unit → bool;
let func temp_a_70 (__71 : unit) =
return false;
decl temp_a_72 : unit → decimal;
let func temp_a_72 (__73 : unit) =
raise EmptyError;
temp_a_63 = handle_default [temp_a_64] temp_a_70 temp_a_72
with EmptyError:
raise NoValueProvided;
@ -216,21 +216,21 @@ let S_9 (S_in_49: S_in) =
a_50 = temp_a_63;
decl temp_b_52 : A {y: bool; z: decimal};
try:
decl temp_b_61 : unit → A {y: bool; z: decimal};
let func temp_b_61 (__62 : unit) =
raise EmptyError;
decl temp_b_59 : unit → bool;
let func temp_b_59 (__60 : unit) =
return false;
decl temp_b_53 : unit → A {y: bool; z: decimal};
let func temp_b_53 (__54 : unit) =
decl temp_b_57 : unit → A {y: bool; z: decimal};
let func temp_b_57 (__58 : unit) =
return glob2_9;
decl temp_b_55 : unit → bool;
let func temp_b_55 (__56 : unit) =
return true;
decl temp_b_57 : unit → A {y: bool; z: decimal};
let func temp_b_57 (__58 : unit) =
return glob2_9;
return handle_default [] temp_b_55 temp_b_57;
decl temp_b_59 : unit → bool;
let func temp_b_59 (__60 : unit) =
return false;
decl temp_b_61 : unit → A {y: bool; z: decimal};
let func temp_b_61 (__62 : unit) =
raise EmptyError;
temp_b_52 = handle_default [temp_b_53] temp_b_59 temp_b_61
with EmptyError:
raise NoValueProvided;
@ -420,25 +420,25 @@ glob2 = (
def s2(s2_in:S2In):
try:
def temp_a(_:Unit):
raise EmptyError
def temp_a_1(_:Unit):
return False
def temp_a_2(_:Unit):
def temp_a_3(_:Unit):
def temp_a_1(_:Unit):
return True
def temp_a_2(_:Unit):
return (glob3(money_of_cents_string("4400")) +
decimal_of_string("100."))
def temp_a_4(_:Unit):
return True
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=45, start_column=10,
end_line=45, end_column=11,
law_headings=["Test toplevel function defs"]), [],
temp_a_4, temp_a_3)
temp_a_1, temp_a_2)
def temp_a_3(_:Unit):
return False
def temp_a_4(_:Unit):
raise EmptyError
temp_a_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=45, start_column=10,
end_line=45, end_column=11,
law_headings=["Test toplevel function defs"]), [temp_a_2],
temp_a_1, temp_a)
law_headings=["Test toplevel function defs"]), [temp_a],
temp_a_3, temp_a_4)
except EmptyError:
temp_a_5 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
@ -451,26 +451,26 @@ def s2(s2_in:S2In):
def s3(s3_in:S3In):
try:
def temp_a_6(_:Unit):
raise EmptyError
def temp_a_7(_:Unit):
return False
def temp_a_8(_:Unit):
def temp_a_9(_:Unit):
def temp_a_7(_:Unit):
return True
def temp_a_8(_:Unit):
return (decimal_of_string("50.") +
glob4(money_of_cents_string("4400"),
decimal_of_string("55.")))
def temp_a_10(_:Unit):
return True
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=65, start_column=10,
end_line=65, end_column=11,
law_headings=["Test function def with two args"]), [],
temp_a_10, temp_a_9)
temp_a_7, temp_a_8)
def temp_a_9(_:Unit):
return False
def temp_a_10(_:Unit):
raise EmptyError
temp_a_11 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=65, start_column=10,
end_line=65, end_column=11,
law_headings=["Test function def with two args"]), [temp_a_8],
temp_a_7, temp_a_6)
law_headings=["Test function def with two args"]), [temp_a_6],
temp_a_9, temp_a_10)
except EmptyError:
temp_a_11 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
@ -483,24 +483,24 @@ def s3(s3_in:S3In):
def s4(s4_in:S4In):
try:
def temp_a_12(_:Unit):
raise EmptyError
def temp_a_13(_:Unit):
return False
def temp_a_14(_:Unit):
def temp_a_15(_:Unit):
return (glob5 + decimal_of_string("1."))
def temp_a_16(_:Unit):
def temp_a_13(_:Unit):
return True
def temp_a_14(_:Unit):
return (glob5 + decimal_of_string("1."))
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=88, start_column=10,
end_line=88, end_column=11,
law_headings=["Test inline defs in toplevel defs"]), [],
temp_a_16, temp_a_15)
temp_a_13, temp_a_14)
def temp_a_15(_:Unit):
return False
def temp_a_16(_:Unit):
raise EmptyError
temp_a_17 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=88, start_column=10,
end_line=88, end_column=11,
law_headings=["Test inline defs in toplevel defs"]), [temp_a_14],
temp_a_13, temp_a_12)
law_headings=["Test inline defs in toplevel defs"]), [temp_a_12],
temp_a_15, temp_a_16)
except EmptyError:
temp_a_17 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
@ -513,24 +513,24 @@ def s4(s4_in:S4In):
def s(s_in:SIn):
try:
def temp_a_18(_:Unit):
raise EmptyError
def temp_a_19(_:Unit):
return False
def temp_a_20(_:Unit):
def temp_a_21(_:Unit):
return (glob1 * glob1)
def temp_a_22(_:Unit):
def temp_a_19(_:Unit):
return True
def temp_a_20(_:Unit):
return (glob1 * glob1)
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=7, start_column=10,
end_line=7, end_column=11,
law_headings=["Test basic toplevel values defs"]), [],
temp_a_22, temp_a_21)
temp_a_19, temp_a_20)
def temp_a_21(_:Unit):
return False
def temp_a_22(_:Unit):
raise EmptyError
temp_a_23 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=7, start_column=10,
end_line=7, end_column=11,
law_headings=["Test basic toplevel values defs"]), [temp_a_20],
temp_a_19, temp_a_18)
law_headings=["Test basic toplevel values defs"]), [temp_a_18],
temp_a_21, temp_a_22)
except EmptyError:
temp_a_23 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
@ -540,24 +540,24 @@ def s(s_in:SIn):
a_3 = temp_a_23
try:
def temp_b(_:Unit):
raise EmptyError
def temp_b_1(_:Unit):
return False
def temp_b_2(_:Unit):
def temp_b_3(_:Unit):
return glob2
def temp_b_4(_:Unit):
def temp_b_1(_:Unit):
return True
def temp_b_2(_:Unit):
return glob2
return handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=8, start_column=10,
end_line=8, end_column=11,
law_headings=["Test basic toplevel values defs"]), [],
temp_b_4, temp_b_3)
temp_b_1, temp_b_2)
def temp_b_3(_:Unit):
return False
def temp_b_4(_:Unit):
raise EmptyError
temp_b_5 = handle_default(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",
start_line=8, start_column=10,
end_line=8, end_column=11,
law_headings=["Test basic toplevel values defs"]), [temp_b_2],
temp_b_1, temp_b)
law_headings=["Test basic toplevel values defs"]), [temp_b],
temp_b_3, temp_b_4)
except EmptyError:
temp_b_5 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/name_resolution/good/toplevel_defs.catala_en",