CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 00:15:39 +03:00
Code Issues Projects Releases Wiki Activity

Compiling simple program correctly to C

Browse Source
This commit is contained in:
Denis Merigoux 2023-12-13 11:07:08 +01:00
parent 827fcef469
commit 5c49581207
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
2 changed files with 73 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
compiler/scalc/from_lcalc.ml
View File

@ -81,6 +81,21 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
(* In C89, struct literates have to be initialized at variable
definition... *)
raise (NotAnExpr { needs_a_local_decl = false })
| EInj { e = e1; cons; name } when not ctxt.config.no_struct_literals ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
( e1_stmts,
( A.EInj
{
e1 = new_e1;
cons;
name;
expr_typ = Expr.maybe_ty (Mark.get expr);
},
Expr.pos expr ) )
| EInj _ when ctxt.config.no_struct_literals ->
(* In C89, struct literates have to be initialized at variable
definition... *)
raise (NotAnExpr { needs_a_local_decl = false })
| ETuple args ->
let args_stmts, new_args =
List.fold_left
@ -98,17 +113,6 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
| ETupleAccess { e = e1; index; _ } ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
e1_stmts, (A.ETupleAccess { e1 = new_e1; index }, Expr.pos expr)
| EInj { e = e1; cons; name } ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
( e1_stmts,
( A.EInj
{
e1 = new_e1;
cons;
name;
expr_typ = Expr.maybe_ty (Mark.get expr);
},
Expr.pos expr ) )
| EApp
{
f = EOp { op = Op.HandleDefaultOpt; tys = _ }, _binder_mark;
@ -204,11 +208,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
([], []) exceptions
in
let just_stmts, new_just = translate_expr ctxt just in
let new_cons = translate_statements ctxt cons in
(* Be careful ! Here, [new_cons]'s last statement is the definition of the
final value we want from this expression. However, this final value is of
type [tau] instead of type [option tau]. We need to inject it
correctly... *)
let cons_stmts, new_cons = translate_expr ctxt cons in
exceptions_stmts
@ just_stmts
@ [
@ -217,7 +217,20 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
{
exceptions = new_exceptions;
just = new_just;
cons = new_cons;
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 );
@ -395,6 +408,37 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
]
| _ -> [])
@ [A.SRaise except, Expr.pos block_expr]
| EInj { e = e1; cons; name } when ctxt.config.no_struct_literals ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let tmp_struct_var_name =
match ctxt.inside_definition_of with
| None ->
failwith "should not happen"
(* [translate_expr] should create this [inside_definition_of]*)
| Some x -> x, Expr.pos block_expr
in
let inj_expr =
( A.EInj
{
e1 = new_e1;
cons;
name;
expr_typ = Expr.maybe_ty (Mark.get block_expr);
},
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 );
]
| EStruct { fields; name } when ctxt.config.no_struct_literals ->
let args_stmts, new_args =
StructField.Map.fold

20
compiler/scalc/to_c.ml
View File

@ -355,7 +355,8 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
| EStructFieldAccess { e1; field; _ } ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
format_struct_field_name field
| EInj { e1 = _e; cons; name = e_name; expr_typ }
| EInj { e1 = e; cons; name = e_name; expr_typ }
(* These should only appear when initializing a variable definition *)
when EnumName.equal e_name Expr.option_enum ->
let e_name =
TypMap.find
@ -368,14 +369,17 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
List.map fst
(EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums))
in
let _some_cons, _none_cons =
let some_cons, none_cons =
match option_config with
| [some_cons; none_cons] -> some_cons, none_cons
| _ -> failwith "should not happen"
in
if EnumConstructor.equal cons Expr.none_constr then
Format.fprintf fmt "NONE"
else Format.fprintf fmt "SOME"
Format.fprintf fmt "{%a_%a,@ {none_cons: NULL}}" format_enum_name e_name
format_enum_cons_name none_cons
else
Format.fprintf fmt "{%a_%a,@ {some_cons: %a}}" format_enum_name e_name
format_enum_cons_name some_cons (format_expression ctx) e
| EInj { e1 = e; cons; name = enum_name; _ } ->
Format.fprintf fmt "new(\"catala_enum_%a\", code = \"%a\",@ value = %a)"
format_enum_name enum_name format_enum_cons_name cons
@ -582,7 +586,7 @@ let rec format_statement
List.map fst
(EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums))
in
let some_cons, _none_cons =
let some_cons, none_cons =
match option_config with
| [some_cons; none_cons] -> some_cons, none_cons
| _ -> failwith "should not happen"
@ -594,12 +598,12 @@ let rec format_statement
let variable_defined_in_cons =
match List.hd (List.rev cons) with
| SReturn (EVar v), _ -> v
| SLocalDef { name; _ }, _ -> Mark.remove name
| SLocalDef { name; _ }, _ | SLocalInit { name; _ }, _ -> Mark.remove name
| _ -> failwith "should not happen"
in
Format.fprintf fmt "%a = {0,{NULL}};@,"
Format.fprintf fmt "@[<hov 2>%a = {%a_%a,@ {none_cons: NULL}};@]@,"
(format_typ ctx (fun fmt -> format_var fmt exception_acc_var))
return_typ;
return_typ format_enum_name e_name format_enum_cons_name none_cons;
Format.fprintf fmt "%a;@,"
(format_typ ctx (fun fmt -> format_var fmt exception_current))
return_typ;