Merge branch 'topic/machu/preprocessor-support' into 'master'

Preprocessing support in generated code

See merge request eng/ide/libadalang-tools!249

src/test-actions.adb

@@ -38,6 +38,7 @@ with GNATCOLL.Traces;
 
 with Libadalang;     use Libadalang;
 with Libadalang.Project_Provider;
+with Libadalang.Preprocessing;
 
 with Utils.Command_Lines.Common; use Utils; use Utils.Command_Lines.Common;
 pragma Unreferenced (Utils.Command_Lines.Common); -- ????
@@ -132,10 +133,13 @@ package body Test.Actions is
    procedure Init
      (Tool : in out Test_Tool; Cmd : in out Command_Line)
    is
+      package LAL_Prep renames Libadalang.Preprocessing;
       Tmp   : GNAT.OS_Lib.String_Access;
       Files : File_Array_Access;
 
       Root_Prj : Project_Type;
+      File_Config : LAL_Prep.File_Config;
+      File_Configs : LAL_Prep.File_Config_Maps.Map;
 
       type Output_Mode_Type is (Root_Mode, Subdir_Mode, Direct_Mode);
       Output_Mode : Output_Mode_Type := Direct_Mode;
@@ -866,6 +870,18 @@ package body Test.Actions is
             & GNAT.OS_Lib.Directory_Separator & "tgen"
             & GNAT.OS_Lib.Directory_Separator & "templates"));
 
+      LAL_Prep.Extract_Preprocessor_Data_From_Project
+         (Tree => Tool.Project_Tree.all,
+          Default_Config => File_Config,
+          File_Configs => File_Configs);
+      declare
+         Preprocessor_Data : constant LAL_Prep.Preprocessor_Data :=
+            LAL_Prep.Create_Preprocessor_Data (File_Config, File_Configs);
+      begin
+         TGen.Libgen.Set_Preprocessing_Definitions
+            (Test.Common.TGen_Libgen_Ctx, Preprocessor_Data);
+      end;
+
       if Arg (Cmd, Gen_Test_Vectors) then
          Test.Common.Generate_Test_Vectors := True;
          Test.Common.Request_Lib_Support;

src/tgen/tgen-libgen.adb

@@ -921,11 +921,13 @@ package body TGen.Libgen is
          Put_Line (Prj_File, "   package Compiler is");
          Put_Line (Prj_File, "      case Build_Mode is");
          Put_Line (Prj_File, "         when ""dev"" =>");
-         Put_Line (Prj_File, "            for Default_Switches (""Ada"") use"
-                   & " (""-g"", ""-gnatg"", ""-gnatyN"", ""-gnatws"");");
+         Put (Prj_File, "            for Default_Switches (""Ada"") use"
+                   & " (""-g"", ""-gnatg"", ""-gnatyN"", ""-gnatws""");
+         Write_Preprocessor_Config (Ctx, Prj_File);
          Put_Line (Prj_File, "         when ""prod"" =>");
          Put_Line (Prj_File, "            for Default_Switches (""Ada"") use"
-                   & " (""-gnatg"", ""-gnatyN"", ""-gnatws"");");
+                   & " (""-gnatg"", ""-gnatyN"", ""-gnatws""");
+         Write_Preprocessor_Config (Ctx, Prj_File);
          Put_Line (Prj_File, "      end case;");
          Put_Line (Prj_File, "   end Compiler;");
          New_Line (Prj_File);
@@ -1265,6 +1267,39 @@ package body TGen.Libgen is
             raise;
    end Generate_Harness_Unit;
 
+   -------------------------------
+   -- Write_Preprocessor_Config --
+   -------------------------------
+
+   procedure Write_Preprocessor_Config
+      (Ctx : Libgen_Context;
+       Prj_File : Ada.Text_IO.File_Type;
+       Append_Flags : Boolean := True)
+   is
+      Preprocessor_File : constant String := To_String (Ctx.Output_Dir)
+         & GNAT.OS_Lib.Directory_Separator
+         & "preprocessor.def";
+   begin
+      if not Ctx.Preprocessor_Definitions.Default_Config.Enabled
+         and Ctx.Preprocessor_Definitions.File_Configs.Is_Empty
+      then
+         Put_Line (Prj_File, ");");
+         return;
+      end if;
+
+      Libadalang.Preprocessing.Write_Preprocessor_Data_File
+         (Ctx.Preprocessor_Definitions,
+          Preprocessor_File,
+          To_String (Ctx.Output_Dir));
+
+      if Append_Flags then
+         Put (Prj_File, ", ");
+      end if;
+      Put (Prj_File, """-gnatep=");
+      Put (Prj_File, Preprocessor_File);
+      Put_Line (Prj_File, """);");
+   end Write_Preprocessor_Config;
+
    ----------------------
    -- Generate_Harness --
    ----------------------
@@ -1320,6 +1355,13 @@ package body TGen.Libgen is
       Put_Line (Prj_File, "project TGen_Generation_Harness is");
       Put_Line (Prj_File, "   for Main use (""generation_main.adb"");");
       Put_Line (Prj_File, "   for Object_Dir use ""obj"";");
+      Ada.Text_IO.Put_Line (Prj_File, "package Compiler is");
+      Ada.Text_IO.Put
+         (Prj_File,
+          "   for Default_Switches (""Ada"") use (");
+      Write_Preprocessor_Config (Ctx, Prj_File, Append_Flags => False);
+      Ada.Text_IO.Put_Line (Prj_File, "end Compiler;");
+
       Put_Line (Prj_File, "end TGen_Generation_Harness;");
       Close (Prj_File);
 
@@ -1371,4 +1413,14 @@ package body TGen.Libgen is
       TGen.Marshalling.Set_Array_Size_Limit (Limit);
    end Set_Array_Size_Limit;
 
+   -----------------------------------
+   -- Set_Preprocessing_Definitions --
+   -----------------------------------
+
+   procedure Set_Preprocessing_Definitions
+      (Ctx : out Libgen_Context;
+       Data : Libadalang.Preprocessing.Preprocessor_Data) is
+   begin
+      Ctx.Preprocessor_Definitions := Data;
+   end Set_Preprocessing_Definitions;
 end TGen.Libgen;

src/tgen/tgen-libgen.ads

@@ -27,10 +27,12 @@
 with Ada.Containers.Ordered_Maps;
 with Ada.Containers.Vectors;
 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Text_IO;
 
 with GNATCOLL.VFS;
 
 with Libadalang.Analysis;
+with Libadalang.Preprocessing;
 
 with TGen.Context;
 with TGen.Marshalling;
@@ -128,6 +130,13 @@ package TGen.Libgen is
    --  This returns False when every included subprogram is not supported by
    --  TGen, or when no subprogram was included.
 
+   procedure Write_Preprocessor_Config
+      (Ctx : Libgen_Context;
+       Prj_File : Ada.Text_IO.File_Type;
+       Append_Flags : Boolean := True);
+   --  Generate a preprocessor file from the context and enable pre-processing
+   --  in the given Project_File by adding `-gnatep=<file>`.
+
    procedure Generate_Harness
      (Ctx              : in out Libgen_Context;
       Harness_Dir      : String;
@@ -160,6 +169,10 @@ package TGen.Libgen is
    --  Supported_Subprogram to ensure consistency of the array limit used in
    --  all the marshallers, otherwise Constraint_Error is raised.
 
+   procedure Set_Preprocessing_Definitions
+      (Ctx : out Libgen_Context;
+       Data : Libadalang.Preprocessing.Preprocessor_Data);
+   --  Set preprocessor definitions to the context.
 private
    use TGen.Strings;
    use TGen.Context;
@@ -226,6 +239,9 @@ private
       Array_Index_Types : Typ_Set;
       --  Set of types used to instantiate array index constraints
 
+      Preprocessor_Definitions : Libadalang.Preprocessing.Preprocessor_Data;
+      --  Preprocessor defintions to add in projects files
+
    end record;
 
 end TGen.Libgen;

testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb

@@ -29,6 +29,7 @@ with GNATCOLL.Opt_Parse; use GNATCOLL.Opt_Parse;
 with Libadalang.Analysis;
 with Libadalang.Common;   use Libadalang.Common;
 with Libadalang.Helpers;
+with Libadalang.Preprocessing;
 
 with TGen.LAL_Utils; use TGen.LAL_Utils;
 with TGen.Libgen;    use TGen.Libgen;
@@ -101,10 +102,15 @@ procedure TGen_Marshalling is
       Jobs    : Libadalang.Helpers.App_Job_Context_Array)
    is
       pragma Unreferenced (Context, Jobs);
+      package LAL_Prep renames Libadalang.Preprocessing;
       User_Project_Path : constant Unbounded_String :=
         App.Args.Project_File.Get;
       Templates_Dir     : Unbounded_String := Templates_Dirs.Get;
       Output_Dir        : Unbounded_String := Output_Dirs.Get;
+      File_Config : LAL_Prep.File_Config;
+      File_Configs : LAL_Prep.File_Config_Maps.Map;
+      Preprocessor_Data : constant LAL_Prep.Preprocessor_Data :=
+         LAL_Prep.Create_Preprocessor_Data (File_Config, File_Configs);
    begin
       if User_Project_Path = Null_Unbounded_String then
          Libadalang.Helpers.Abort_App ("Project file required");
@@ -118,6 +124,8 @@ procedure TGen_Marshalling is
         (Output_Dir         => To_String (Output_Dir),
          User_Project_Path  => To_String (User_Project_Path),
          Root_Templates_Dir => To_String (Templates_Dir));
+         TGen.Libgen.Set_Preprocessing_Definitions
+            (Gen_Ctx, Preprocessor_Data);
    end App_Setup;
 
    ------------------

testsuite/tests/test/tgen_preprocessor_definitions/src/procedure_under_test.adb

@@ -0,0 +1,20 @@
+with Text_IO; use Text_IO;
+
+package body Procedure_Under_Test is
+
+   procedure Test (Some_Value : Integer) is
+   begin
+      #if debug
+      #if debug_symbol="true"
+      if Some_Value > 0 and Some_Public_Value_1  = 0 and Some_Public_Value_2 = 0 then
+         Put_Line (Some_Public_String);
+      end if;
+      #else
+      Put_Line (Some_Public_String);
+      #end if;
+      #else
+      Put_Line (Test_Failed);
+      #end if;
+   end Test;
+
+end Procedure_Under_Test;

testsuite/tests/test/tgen_preprocessor_definitions/src/procedure_under_test.ads

@@ -0,0 +1,19 @@
+package Procedure_Under_Test is
+
+   Some_Public_String : String := $debug_string;
+
+   #if debug
+   Some_Public_Value_1 : Integer := 0;
+   #else
+   Some_Public_Value_1 : Integer := 200;
+   #end if;
+
+   #if debug_symbol="true"
+   Some_Public_Value_2 : Integer := 0;
+   #else
+   Some_Public_Value_2 : Integer := 200;
+   #end if;
+
+   procedure Test (Some_Value : Integer);
+
+end Procedure_Under_Test;

testsuite/tests/test/tgen_preprocessor_definitions/test.sh

@@ -0,0 +1,4 @@
+#!/usr/bin/env bash
+
+rm -rf obj
+gnattest -q -P user_project.gpr --gen-test-vectors

testsuite/tests/test/tgen_preprocessor_definitions/test.yaml

@@ -0,0 +1,3 @@
+description: Check that preprocessing is being handled properly by TGen
+
+driver: shell_script

testsuite/tests/test/tgen_preprocessor_definitions/user_project.gpr

@@ -0,0 +1,11 @@
+project User_Project is
+
+   for Source_Dirs use ("src");
+   for Create_Missing_Dirs use "True";
+   for Object_Dir use "obj";
+
+   package Compiler is
+      for Default_Switches ("Ada") use ("-gnateDdebug", "-gnateDdebug_symbol=true", "-gnateDdebug_string=""hello""");
+   end Compiler;
+
+end User_Project;