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

Reformat

Browse Source
This commit is contained in:
Louis Gesbert 2024-08-08 15:51:52 +02:00
parent e9abbf9bd8
commit 5d61963a93
4 changed files with 288 additions and 272 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
compiler/scalc/from_lcalc.ml
View File

@ -37,13 +37,6 @@ type 'm ctxt = {
ren_ctx : Renaming.context;
}
(* Expressions can spill out side effect, hence this function also returns a
list of statements to be prepended before the expression is evaluated *)
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 *)
(** 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) *)
@ -101,14 +94,17 @@ let rec translate_expr_list ctxt args =
let stmts, args, ren_ctx =
List.fold_left
(fun (args_stmts, new_args, ren_ctx) arg ->
let arg_stmts, new_arg, ren_ctx = translate_expr { ctxt with ren_ctx } arg in
let arg_stmts, new_arg, ren_ctx =
translate_expr { ctxt with ren_ctx } arg
in
args_stmts ++ arg_stmts, new_arg :: new_args, ren_ctx)
(RevBlock.empty, [], ctxt.ren_ctx) args
(RevBlock.empty, [], ctxt.ren_ctx)
args
in
stmts, List.rev args, ren_ctx
and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr * Renaming.context =
try
and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) :
RevBlock.t * A.expr * Renaming.context =
match Mark.remove expr with
| EVar v ->
let local_var =
@ -128,21 +124,29 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr * R
if ctxt.config.no_struct_literals then
(* In C89, struct literates have to be initialized at variable
definition... *)
raise (NotAnExpr { needs_a_local_decl = false });
spill_expr ~needs_a_local_decl:false ctxt expr
else
let args_stmts, new_args, ren_ctx =
StructField.Map.fold
(fun field arg (args_stmts, new_args, ren_ctx) ->
let arg_stmts, new_arg, ren_ctx = translate_expr { ctxt with ren_ctx } arg in
args_stmts ++ arg_stmts, StructField.Map.add field new_arg new_args, ren_ctx)
let arg_stmts, new_arg, ren_ctx =
translate_expr { ctxt with ren_ctx } arg
in
( args_stmts ++ arg_stmts,
StructField.Map.add field new_arg new_args,
ren_ctx ))
fields
(RevBlock.empty, StructField.Map.empty, ctxt.ren_ctx)
in
args_stmts, (A.EStruct { fields = new_args; name }, Expr.pos expr), ren_ctx
( args_stmts,
(A.EStruct { fields = new_args; name }, Expr.pos expr),
ren_ctx )
| EInj { e = e1; cons; name } ->
if ctxt.config.no_struct_literals then
(* In C89, struct literates have to be initialized at variable
definition... *)
raise (NotAnExpr { needs_a_local_decl = false });
spill_expr ~needs_a_local_decl:false ctxt expr
else
let e1_stmts, new_e1, ren_ctx = translate_expr ctxt e1 in
( e1_stmts,
( A.EInj
@ -204,7 +208,7 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr * R
}
in
let arg_stmts, new_arg, ren_ctx = translate_expr ctxt arg in
RevBlock.append (rblock ++ arg_stmts)
( RevBlock.append (rblock ++ arg_stmts)
( A.SLocalDef
{
name = x;
@ -212,14 +216,19 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr * R
typ = Expr.maybe_ty (Mark.get arg);
},
binder_pos ),
ren_ctx)
(RevBlock.empty, ctxt.ren_ctx) vars_args
ren_ctx ))
(RevBlock.empty, ctxt.ren_ctx)
vars_args
in
let rest_of_expr_stmts, rest_of_expr, ren_ctx =
translate_expr { ctxt with ren_ctx } body
in
let rest_of_expr_stmts, rest_of_expr, ren_ctx = translate_expr { ctxt with ren_ctx } body in
local_decls ++ def_blocks ++ rest_of_expr_stmts, rest_of_expr, ren_ctx
| EApp { f; args; tys = _ } ->
let f_stmts, new_f, ren_ctx = translate_expr ctxt f in
let args_stmts, new_args, ren_ctx = translate_expr_list { ctxt with ren_ctx } args in
let args_stmts, new_args, ren_ctx =
translate_expr_list { ctxt with ren_ctx } args
in
(* FIXME: what happens if [arg] is not a tuple but reduces to one ? *)
( f_stmts ++ args_stmts,
(A.EApp { f = new_f; args = new_args }, Expr.pos expr),
@ -240,9 +249,10 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr * R
in
RevBlock.empty, (EExternal { modname; name }, Expr.pos expr), ctxt.ren_ctx
| EAbs _ | EIfThenElse _ | EMatch _ | EAssert _ | EFatalError _ ->
raise (NotAnExpr { needs_a_local_decl = true })
spill_expr ~needs_a_local_decl:true ctxt expr
| _ -> .
with NotAnExpr { needs_a_local_decl } ->
and spill_expr ~needs_a_local_decl ctxt expr =
let tmp_var, ctxt =
let name =
match ctxt.inside_definition_of with
@ -272,15 +282,16 @@ and translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : RevBlock.t * A.expr * R
(A.EVar tmp_var, Expr.pos expr),
ren_ctx )
and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * Renaming.context =
and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) :
A.block * Renaming.context =
match Mark.remove block_expr with
| EAssert e ->
(* Assertions are always encapsulated in a unit-typed let binding *)
let e_stmts, new_e, ren_ctx = translate_expr ctxt e in
RevBlock.rebuild
( RevBlock.rebuild
~tail:[A.SAssert (Mark.remove new_e), Expr.pos block_expr]
e_stmts,
ren_ctx
ren_ctx )
| EFatalError err -> [SFatalError err, Expr.pos block_expr], ctxt.ren_ctx
(* | EAppOp
* { op = Op.HandleDefaultOpt, _; tys = _; args = [exceptions; just; cons] }
@ -369,8 +380,10 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
ren_ctx;
}
in
let arg_stmts, new_arg, ren_ctx = translate_expr { ctxt with ren_ctx } arg in
RevBlock.append (def_blocks ++ arg_stmts)
let arg_stmts, new_arg, ren_ctx =
translate_expr { ctxt with ren_ctx } arg
in
( RevBlock.append (def_blocks ++ arg_stmts)
( A.SLocalDef
{
name = x;
@ -378,10 +391,13 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
typ = Expr.maybe_ty (Mark.get arg);
},
binder_pos ),
ren_ctx)
(RevBlock.empty, ctxt.ren_ctx) vars_args
ren_ctx ))
(RevBlock.empty, ctxt.ren_ctx)
vars_args
in
let rest_of_block, ren_ctx =
translate_statements { ctxt with ren_ctx } body
in
let rest_of_block, ren_ctx = translate_statements { ctxt with ren_ctx } body in
local_decls @ RevBlock.rebuild def_blocks ~tail:rest_of_block, ren_ctx
| EAbs { binder; tys } ->
let closure_name, ctxt =
@ -399,7 +415,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
vars_tau
in
let new_body, _ren_ctx = translate_statements ctxt body in
[
( [
( A.SInnerFuncDef
{
name = closure_name, binder_pos;
@ -419,7 +435,8 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
};
},
binder_pos );
], ctxt.ren_ctx
],
ctxt.ren_ctx )
| EMatch { e = e1; cases; name } ->
let typ = Expr.maybe_ty (Mark.get e1) in
let e1_stmts, new_e1, ren_ctx = translate_expr ctxt e1 in
@ -429,14 +446,11 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
| A.EVar v, _ -> e1_stmts, v, ctxt
| _ ->
let v, ctxt = fresh_var ctxt ctxt.context_name ~pos:(Expr.pos e1) in
RevBlock.append e1_stmts
( A.SLocalInit
{ name = v, Expr.pos e1;
expr = new_e1;
typ },
( RevBlock.append e1_stmts
( A.SLocalInit { name = v, Expr.pos e1; expr = new_e1; typ },
Expr.pos e1 ),
v,
ctxt
ctxt )
in
let new_cases =
EnumConstructor.Map.fold
@ -459,7 +473,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
| _ -> assert false)
cases []
in
RevBlock.rebuild e1_stmts
( RevBlock.rebuild e1_stmts
~tail:
[
( A.SSwitch
@ -471,12 +485,12 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
},
Expr.pos block_expr );
],
ctxt.ren_ctx
ctxt.ren_ctx )
| EIfThenElse { cond; etrue; efalse } ->
let cond_stmts, s_cond, ren_ctx = translate_expr ctxt cond in
let s_e_true, _ = translate_statements ctxt etrue in
let s_e_false, _ = translate_statements ctxt efalse in
RevBlock.rebuild cond_stmts
( RevBlock.rebuild cond_stmts
~tail:
[
( A.SIfThenElse
@ -487,7 +501,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
},
Expr.pos block_expr );
],
ren_ctx
ren_ctx )
| EInj { e = e1; cons; name } when ctxt.config.no_struct_literals ->
let e1_stmts, new_e1, ren_ctx = translate_expr ctxt e1 in
let tmp_struct_var_name =
@ -506,7 +520,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
},
Expr.pos block_expr )
in
RevBlock.rebuild e1_stmts
( RevBlock.rebuild e1_stmts
~tail:
[
( A.SLocalInit
@ -519,13 +533,17 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
},
Expr.pos block_expr );
],
ren_ctx
ren_ctx )
| EStruct { fields; name } when ctxt.config.no_struct_literals ->
let args_stmts, new_args, ren_ctx =
StructField.Map.fold
(fun field arg (args_stmts, new_args, ren_ctx) ->
let arg_stmts, new_arg, ren_ctx = translate_expr { ctxt with ren_ctx } arg in
args_stmts ++ arg_stmts, StructField.Map.add field new_arg new_args, ren_ctx)
let arg_stmts, new_arg, ren_ctx =
translate_expr { ctxt with ren_ctx } arg
in
( args_stmts ++ arg_stmts,
StructField.Map.add field new_arg new_args,
ren_ctx ))
fields
(RevBlock.empty, StructField.Map.empty, ctxt.ren_ctx)
in
@ -539,7 +557,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
(* [translate_expr] should create this [inside_definition_of]*)
| Some x -> x, Expr.pos block_expr
in
RevBlock.rebuild args_stmts
( RevBlock.rebuild args_stmts
~tail:
[
( A.SLocalInit
@ -550,7 +568,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
},
Expr.pos block_expr );
],
ren_ctx
ren_ctx )
| ELit _ | EAppOp _ | EArray _ | EVar _ | EStruct _ | EInj _ | ETuple _
| ETupleAccess _ | EStructAccess _ | EExternal _ | EApp _ ->
let e_stmts, new_e, ren_ctx = translate_expr ctxt block_expr in
@ -575,8 +593,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block * R
Expr.pos block_expr );
]
in
RevBlock.rebuild e_stmts ~tail,
ren_ctx
RevBlock.rebuild e_stmts ~tail, ren_ctx
| _ -> .
let rec translate_scope_body_expr ctx (scope_expr : 'm L.expr scope_body_expr) :
@ -607,21 +624,21 @@ let rec translate_scope_body_expr ctx (scope_expr : 'm L.expr scope_body_expr) :
scope_let.scope_let_expr
in
let ( +> ) = RevBlock.append in
let_expr_stmts +>
( A.SLocalDecl
( 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
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 ),
ren_ctx
ren_ctx )
in
let tail = translate_scope_body_expr { ctx with ren_ctx } scope_let_next in
RevBlock.rebuild statements ~tail

3
compiler/scalc/print.ml
View File

@ -173,8 +173,7 @@ let rec format_statement
->
let cons = EnumName.Map.find enum decl_ctx.ctx_enums in
Format.fprintf fmt "@[<v 0>%a @[<hov 2>%a@]%a@,@]%a" Print.keyword "switch"
format_var_name v_switch
Print.punctuation ":"
format_var_name v_switch Print.punctuation ":"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt ((case, _), switch_case_data) ->

3
compiler/scalc/to_c.ml
View File

@ -397,7 +397,8 @@ let rec format_statement
(EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums))
in
Format.pp_open_vbox fmt 2;
Format.fprintf fmt "@[<hov 4>switch (%a.code) {@]@," VarName.format switch_var;
Format.fprintf fmt "@[<hov 4>switch (%a.code) {@]@," VarName.format
switch_var;
Format.pp_print_list
(fun fmt ({ case_block; payload_var_name; payload_var_typ }, cons_name) ->
Format.fprintf fmt "@[<hv 2>case %a_%a:@ " EnumName.format e_name

3
compiler/scalc/to_python.ml
View File

@ -159,8 +159,7 @@ let renaming =
(* TODO: add catala runtime built-ins as reserved as well ? *)
~reset_context_for_closed_terms:false ~skip_constant_binders:false
~constant_binder_name:None ~namespaced_fields_constrs:true
~f_struct:String.to_camel_case
~f_enum:String.to_camel_case
~f_struct:String.to_camel_case ~f_enum:String.to_camel_case
let typ_needs_parens (e : typ) : bool =
match Mark.remove e with TArrow _ | TArray _ -> true | _ -> false