C backend: generate .h files and use them for imported modules

Also includes some fixes to the propagation of visibility info of types.

Author: AltGr

compiler/dcalc/from_scopelang.ml

@@ -921,7 +921,14 @@ let translate_program (prgm : 'm S.program) : 'm Ast.program =
         StructName.Map.add scope_sig_ctx.scope_sig_input_struct fields acc)
       scopes_parameters decl_ctx.ctx_structs
   in
-  let decl_ctx = { decl_ctx with ctx_structs } in
+  let ctx_public_types =
+    ScopeName.Map.fold (fun scope sig_ctx acc ->
+        if (ScopeName.Map.find scope decl_ctx.ctx_scopes).visibility = Public
+        then TypeIdent.Set.add (Struct sig_ctx.scope_sig_input_struct) acc
+        else acc)
+      scopes_parameters decl_ctx.ctx_public_types
+  in
+  let decl_ctx = { decl_ctx with ctx_structs; ctx_public_types } in
   let toplevel_vars =
     TopdefName.Map.mapi
       (fun name (_, ty, _vis) ->

compiler/driver.ml

@@ -996,10 +996,21 @@ module Commands = struct
         ~renaming:(Some Scalc.To_c.renaming)
     in
     let output_file, with_output = get_output_format options ~ext:".c" output in
+    let out_intf, with_output_intf =
+      match output_file with
+      | Some f when prg.module_name <> None ->
+        let f = File.(f -.- "h") in
+        File.get_formatter_of_out_channel ~source_file:options.Global.input_src ~output_file:(Some f)
+          ~ext:".h" ()
+      | _ -> None, fun pp -> pp (Format.make_formatter (fun _ _ _ -> ()) ignore)
+    in
     Message.debug "Compiling program into C...";
-    Message.debug "Writing to %s..."
-      (Option.value ~default:"stdout" output_file);
-    with_output @@ fun fmt -> Scalc.To_c.format_program fmt prg type_ordering
+    Message.debug "Writing to %s / %s..."
+      (Option.value ~default:"stdout" output_file)
+      (Option.value ~default:"no interface output" out_intf);
+    with_output @@ fun ppf_src ->
+    with_output_intf @@ fun ppf_intf ->
+    Scalc.To_c.format_program ~ppf_src ~ppf_intf prg type_ordering
 
   let c_cmd =
     Cmd.v

compiler/scalc/to_c.ml

@@ -147,7 +147,7 @@ let rec format_typ
 
 let format_ctx
     (type_ordering : TypeIdent.t list)
-    (fmt : Format.formatter)
+    ~ppc ~pph
     (ctx : decl_ctx) : unit =
   let format_struct_decl fmt (struct_name, struct_fields) =
     let fields = StructField.Map.bindings struct_fields in
@@ -171,16 +171,15 @@ let format_ctx
     if EnumConstructor.Map.is_empty enum_cons then
       failwith "no constructors in the enum"
     else
-      Format.fprintf fmt "@,@[<v 2>enum %s_code {@,%a@;<0 -2>}@] %s__code;@,"
+      Format.fprintf fmt "@,@[<v 2>enum %s__code {@,%a@;<0 -2>}@];@,"
         (EnumName.base enum_name)
         (Format.pp_print_list
            ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
            (fun fmt (enum_cons, _) -> EnumConstructor.format fmt enum_cons))
-        (EnumConstructor.Map.bindings enum_cons)
-        (EnumName.base enum_name);
+        (EnumConstructor.Map.bindings enum_cons);
     Format.fprintf fmt
       "@,\
-       @[<v 2>typedef struct %s {@ enum %s_code code;@ @[<v 2>union {@ %a@]@,\
+       @[<v 2>typedef struct %s {@ enum %s__code code;@ @[<v 2>union {@ %a@]@,\
        } payload;@]@,\
        } %s;" (EnumName.base enum_name) (EnumName.base enum_name)
       (Format.pp_print_list
@@ -194,36 +193,32 @@ let format_ctx
       (EnumConstructor.Map.bindings enum_cons)
       (EnumName.base enum_name)
   in
-
-  let is_in_type_ordering s =
-    List.exists
-      (fun struct_or_enum ->
-        match struct_or_enum with
-        | TypeIdent.Enum _ -> false
-        | TypeIdent.Struct s' -> s = s')
-      type_ordering
-  in
   let scope_structs =
-    List.map
-      (fun (s, _) -> TypeIdent.Struct s)
-      (StructName.Map.bindings
-         (StructName.Map.filter
-            (fun s _ -> not (is_in_type_ordering s))
-            ctx.ctx_structs))
+    List.fold_left (fun acc -> function
+        | TypeIdent.Struct s -> StructName.Map.remove s acc
+        | _ -> acc)
+      ctx.ctx_structs type_ordering
+    |> StructName.Map.keys
+    |> List.map (fun s -> TypeIdent.Struct s)
   in
-  Format.pp_print_list
-    ~pp_sep:(fun _ () -> ())
-    (fun fmt struct_or_enum ->
+  List.iter
+    (fun struct_or_enum ->
       match struct_or_enum with
-      | TypeIdent.Struct s ->
+      | TypeIdent.Struct s as tid ->
         if StructName.path s = [] then
-          Format.fprintf fmt "@,%a" format_struct_decl
-            (s, StructName.Map.find s ctx.ctx_structs)
-      | TypeIdent.Enum e ->
+          let def = StructName.Map.find s ctx.ctx_structs in
+          Format.fprintf ppc "@,%a" format_struct_decl (s, def);
+          if TypeIdent.Set.mem tid ctx.ctx_public_types
+          then Format.fprintf pph "@,%a" format_struct_decl (s, def)
+          else Format.eprintf "NOT PUB: %a (pub: %a)@."
+              StructName.format s
+              (Format.pp_print_seq ~pp_sep:Format.pp_print_space TypeIdent.format) (TypeIdent.Set.to_seq ctx.ctx_public_types)
+      | TypeIdent.Enum e as tid ->
         if EnumName.path e = [] then
-          Format.fprintf fmt "@,%a" format_enum_decl
-            (e, EnumName.Map.find e ctx.ctx_enums))
-    fmt
+          let def = EnumName.Map.find e ctx.ctx_enums in
+          Format.fprintf ppc "@,%a" format_enum_decl (e, def);
+          if TypeIdent.Set.mem tid ctx.ctx_public_types
+          then Format.fprintf pph "@,%a" format_enum_decl (e, def))
     (type_ordering @ scope_structs)
 
 let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
@@ -714,26 +709,36 @@ let format_main (fmt : Format.formatter) (p : Ast.program) =
   Format.fprintf fmt "@,return 0;@;<1 -2>}@]"
 
 let format_program
-    (fmt : Format.formatter)
+    ~ppf_src:ppc
+    ~ppf_intf:pph
     (p : Ast.program)
     (type_ordering : TypeIdent.t list) : unit =
-  Fun.protect ~finally:(Format.pp_print_newline fmt)
+  let ppboth f = f ppc; f pph in
+  let ppboth_if condition f = f ppc; if condition then f pph in
+  Fun.protect ~finally:(fun () -> ppboth (fun ppf -> Format.pp_print_newline ppf ()))
   @@ fun () ->
-  Format.pp_open_vbox fmt 0;
-  Format.fprintf fmt
-    "/* This file has been generated by the Catala compiler, do not edit! */@,\
-     @,\
-     #include <stdio.h>@,\
+  ppboth (fun ppf -> Format.pp_open_vbox ppf 0);
+  ppboth (fun ppf -> Format.fprintf ppf
+             "/* This file has been generated by the Catala compiler, do not edit! */@,@,");
+  Format.fprintf ppc
+    "#include <stdio.h>@,\
      #include <stdlib.h>@,\
      #include <catala_runtime.h>@,\
      @,";
+  let module_id =
+    match p.module_name with
+    | None -> "MAIN"
+    | Some (m, _) -> String.uppercase_ascii (String.to_ascii (ModuleName.to_string m))
+  in
+  Format.fprintf pph "#ifndef __%s_H__@,#define __%s_H__@," module_id module_id;
   List.iter
     (fun (m, _intf_id) ->
-      Format.fprintf fmt "#include \"%s.c\"@,"
-        (String.uncapitalize_ascii (ModuleName.to_string m)))
+       ppboth @@ fun ppf -> Format.fprintf ppf "@,#include \"%s.h\""
+         (String.uncapitalize_ascii (ModuleName.to_string m)))
     (Program.modules_to_list p.ctx.decl_ctx.ctx_modules);
-  format_ctx type_ordering fmt p.ctx.decl_ctx;
-  Format.pp_print_cut fmt ();
+  (* TODO: check the module hash ? *)
+  format_ctx type_ordering ~ppc ~pph p.ctx.decl_ctx;
+  ppboth (fun ppf -> Format.pp_print_cut ppf ());
   let ctx = { decl_ctx = p.ctx.decl_ctx } in
   let _env =
     List.fold_left
@@ -744,21 +749,27 @@ let format_program
              parameters that perform lazy evaluation: {[ inline foo_type foo() {
              static foo_type foo = NULL; return (foo ? foo : foo = foo_init());
              } ]} NOTE: "inline" is not defined in C89 *)
-          Format.fprintf fmt "@[<v 2>@[<hov 4>%a () {@]@,"
-            (format_typ ~const:true p.ctx.decl_ctx (fun fmt ->
-                 Format.pp_print_space fmt ();
-                 VarName.format fmt var))
-            typ;
-          Format.fprintf fmt "@[<hov 2>static %a = NULL;@]@,"
+          let public = (* TODO: Ugh! Pass this info into scalc ! *)
+            Re.(execp (compile (seq [str "__"; diff any digit])) (VarName.to_string var))
+          in
+          ppboth_if public (fun ppf ->
+              Format.fprintf ppf "@,@[<v 2>@[<hov 4>%a"
+                (format_typ ~const:true p.ctx.decl_ctx (fun fmt ->
+                     Format.pp_print_space fmt ();
+                     VarName.format fmt var))
+                typ);
+          if public then Format.fprintf pph ";@]@]@,";
+          Format.fprintf ppc " () {@]@,";
+          Format.fprintf ppc "@[<hov 2>static %a = NULL;@]@,"
             (format_typ ~const:true p.ctx.decl_ctx (fun fmt ->
                  Format.pp_print_space fmt ();
                  VarName.format fmt var))
             typ;
-          Format.fprintf fmt "@[<hov 2>return (%a ? %a : (%a = %a));@]"
+          Format.fprintf ppc "@[<hov 2>return (%a ? %a : (%a = %a));@]"
             VarName.format var VarName.format var VarName.format var
             (format_expression ctx env)
             expr;
-          Format.fprintf fmt "@;<1 -2>}@]@,@,";
+          Format.fprintf ppc "@;<1 -2>}@]@,";
           { env with global_vars = VarName.Set.add var env.global_vars }
         | SFunc { var; func }
         | SScope { scope_body_var = var; scope_body_func = func; _ } ->
@@ -767,29 +778,36 @@ let format_program
             VarName.Set.of_list
               (List.map (fun (v, _) -> Mark.remove v) func_params)
           in
-          Format.fprintf fmt
-            "@,@[<v 2>@[<hov 4>%a@ @[<hv 1>(%a)@]@]@;<1 -2>{%a@]@,}@,"
-            (format_typ ~const:true ctx.decl_ctx (fun fmt ->
-                 Format.pp_print_space fmt ();
-                 FuncName.format fmt var))
-            func_return_typ
-            (Format.pp_print_list
-               ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
-               (fun fmt (var, typ) ->
-                 Format.pp_open_hovbox fmt 2;
-                 (format_typ ~const:true p.ctx.decl_ctx (fun fmt ->
-                      Format.pp_print_space fmt ();
-                      VarName.format fmt (Mark.remove var)))
-                   fmt typ;
-                 Format.pp_close_box fmt ()))
-            func_params
+          let public = (* TODO: Ugh! Pass this info into scalc ! *)
+            Re.(execp (compile (seq [str "__"; diff any digit])) (FuncName.to_string var))
+          in
+          ppboth_if public (fun ppf ->
+              Format.fprintf ppf
+                "@,@[<v 2>@[<hov 4>%a@ @[<hv 1>(%a)@]@]"
+                (format_typ ~const:true ctx.decl_ctx (fun fmt ->
+                     Format.pp_print_space fmt ();
+                     FuncName.format fmt var))
+                func_return_typ
+                (Format.pp_print_list
+                   ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
+                   (fun fmt (var, typ) ->
+                      Format.pp_open_hovbox fmt 2;
+                      (format_typ ~const:true p.ctx.decl_ctx (fun fmt ->
+                           Format.pp_print_space fmt ();
+                           VarName.format fmt (Mark.remove var)))
+                        fmt typ;
+                      Format.pp_close_box fmt ()))
+                func_params);
+          if public then Format.fprintf pph "@];@,";
+          Format.fprintf ppc "@;<1 -2>{%a@]@,}@,"
             (format_block ctx { env with local_vars })
             func_body;
           env)
       { global_vars = VarName.Set.empty; local_vars = VarName.Set.empty }
       p.code_items
   in
   if p.module_name = None then (
-    Format.pp_print_cut fmt ();
-    format_main fmt p);
-  Format.pp_close_box fmt ()
+    Format.pp_print_cut ppc ();
+    format_main ppc p);
+  Format.fprintf pph "@,#endif /* __%s_H__ */" module_id;
+  ppboth (fun ppf -> Format.pp_close_box ppf ())

compiler/scalc/to_c.mli

@@ -20,5 +20,5 @@ open Shared_ast
 
 val renaming : Renaming.t
 
-val format_program : Format.formatter -> Ast.program -> TypeIdent.t list -> unit
+val format_program : ppf_src:Format.formatter -> ppf_intf:Format.formatter -> Ast.program -> TypeIdent.t list -> unit
 (** Usage [format_program fmt p type_dependencies_ordering] *)

compiler/shared_ast/renaming.ml

@@ -652,13 +652,20 @@ let program
       ~constrs:(fun n ->
         EnumConstructor.Map.find n type_renaming_ctx.constrs_map)
   in
+  let ctx_public_types =
+    TypeIdent.Set.map (function
+        | Struct s -> Struct (StructName.Map.find s type_renaming_ctx.structs_map)
+        | Enum s -> Enum (EnumName.Map.find s type_renaming_ctx.enums_map))
+      p.decl_ctx.ctx_public_types
+  in
   let decl_ctx =
     {
       p.decl_ctx with
       ctx_enums = type_renaming_ctx.ctx_enums;
       ctx_structs = type_renaming_ctx.ctx_structs;
       ctx_scopes;
       ctx_topdefs;
+      ctx_public_types;
     }
   in
   let decl_ctx = Program.map_decl_ctx ~f:(typ ctx) decl_ctx in