From 5c49581207af0d4f2951879f01d71b55bc23c2af Mon Sep 17 00:00:00 2001 From: Denis Merigoux Date: Wed, 13 Dec 2023 11:07:08 +0100 Subject: [PATCH] Compiling simple program correctly to C --- compiler/scalc/from_lcalc.ml | 78 ++++++++++++++++++++++++++++-------- compiler/scalc/to_c.ml | 20 +++++---- 2 files changed, 73 insertions(+), 25 deletions(-) diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index 49173564..2fec2fb3 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -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 diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 60e40a77..308076b1 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -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 "@[%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;