Compiling simple program correctly to C

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
+    let cons_stmts, new_cons = translate_expr 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... *)
     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

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"
+      Format.fprintf fmt "{%a_%a,@ {none_cons: NULL}}" format_enum_name e_name
-    else Format.fprintf fmt "SOME"
+        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;