From d4986d0019d54795ad43c03213bc685cbf58b910 Mon Sep 17 00:00:00 2001 From: Corentin Machu Date: Wed, 9 Oct 2024 11:38:59 +0200 Subject: [PATCH 1/2] Add preprocessing test --- .../src/procedure_under_test.adb | 20 +++++++++++++++++++ .../src/procedure_under_test.ads | 19 ++++++++++++++++++ .../test/tgen_preprocessor_definitons/test.sh | 4 ++++ .../tgen_preprocessor_definitons/test.yaml | 3 +++ .../user_project.gpr | 11 ++++++++++ 5 files changed, 57 insertions(+) create mode 100644 testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.adb create mode 100644 testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.ads create mode 100644 testsuite/tests/test/tgen_preprocessor_definitons/test.sh create mode 100644 testsuite/tests/test/tgen_preprocessor_definitons/test.yaml create mode 100644 testsuite/tests/test/tgen_preprocessor_definitons/user_project.gpr diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.adb b/testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.adb new file mode 100644 index 00000000..efaff580 --- /dev/null +++ b/testsuite/tests/test/tgen_preprocessor_definitons/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; diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.ads b/testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.ads new file mode 100644 index 00000000..a1539ea5 --- /dev/null +++ b/testsuite/tests/test/tgen_preprocessor_definitons/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; diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/test.sh b/testsuite/tests/test/tgen_preprocessor_definitons/test.sh new file mode 100644 index 00000000..069ec732 --- /dev/null +++ b/testsuite/tests/test/tgen_preprocessor_definitons/test.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +rm -rf obj +gnattest -q -P user_project.gpr --gen-test-vectors diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/test.yaml b/testsuite/tests/test/tgen_preprocessor_definitons/test.yaml new file mode 100644 index 00000000..6ed357e5 --- /dev/null +++ b/testsuite/tests/test/tgen_preprocessor_definitons/test.yaml @@ -0,0 +1,3 @@ +description: Check that preprocessing is being handled properly by TGen + +driver: shell_script diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/user_project.gpr b/testsuite/tests/test/tgen_preprocessor_definitons/user_project.gpr new file mode 100644 index 00000000..9667a195 --- /dev/null +++ b/testsuite/tests/test/tgen_preprocessor_definitons/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; From 3f7b7297f7379bd6ca17ed0be5f4d850835e6a12 Mon Sep 17 00:00:00 2001 From: Corentin Machu Date: Wed, 9 Oct 2024 11:39:19 +0200 Subject: [PATCH 2/2] Add user preprocessor definition support --- src/test-actions.adb | 16 +++++ src/tgen/tgen-libgen.adb | 58 ++++++++++++++++++- src/tgen/tgen-libgen.ads | 16 +++++ .../src/tgen_marshalling.adb | 8 +++ .../src/procedure_under_test.adb | 0 .../src/procedure_under_test.ads | 0 .../test.sh | 0 .../test.yaml | 0 .../user_project.gpr | 0 9 files changed, 95 insertions(+), 3 deletions(-) rename testsuite/tests/test/{tgen_preprocessor_definitons => tgen_preprocessor_definitions}/src/procedure_under_test.adb (100%) rename testsuite/tests/test/{tgen_preprocessor_definitons => tgen_preprocessor_definitions}/src/procedure_under_test.ads (100%) rename testsuite/tests/test/{tgen_preprocessor_definitons => tgen_preprocessor_definitions}/test.sh (100%) mode change 100644 => 100755 rename testsuite/tests/test/{tgen_preprocessor_definitons => tgen_preprocessor_definitions}/test.yaml (100%) rename testsuite/tests/test/{tgen_preprocessor_definitons => tgen_preprocessor_definitions}/user_project.gpr (100%) diff --git a/src/test-actions.adb b/src/test-actions.adb index 0c0b3871..224b9333 100644 --- a/src/test-actions.adb +++ b/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; diff --git a/src/tgen/tgen-libgen.adb b/src/tgen/tgen-libgen.adb index dc8019a5..91b4cb5a 100644 --- a/src/tgen/tgen-libgen.adb +++ b/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; diff --git a/src/tgen/tgen-libgen.ads b/src/tgen/tgen-libgen.ads index ba861fcf..c16a8ba1 100644 --- a/src/tgen/tgen-libgen.ads +++ b/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=`. + 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; diff --git a/testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb b/testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb index b25ab429..2f11a21e 100644 --- a/testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb +++ b/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; ------------------ diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.adb b/testsuite/tests/test/tgen_preprocessor_definitions/src/procedure_under_test.adb similarity index 100% rename from testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.adb rename to testsuite/tests/test/tgen_preprocessor_definitions/src/procedure_under_test.adb diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.ads b/testsuite/tests/test/tgen_preprocessor_definitions/src/procedure_under_test.ads similarity index 100% rename from testsuite/tests/test/tgen_preprocessor_definitons/src/procedure_under_test.ads rename to testsuite/tests/test/tgen_preprocessor_definitions/src/procedure_under_test.ads diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/test.sh b/testsuite/tests/test/tgen_preprocessor_definitions/test.sh old mode 100644 new mode 100755 similarity index 100% rename from testsuite/tests/test/tgen_preprocessor_definitons/test.sh rename to testsuite/tests/test/tgen_preprocessor_definitions/test.sh diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/test.yaml b/testsuite/tests/test/tgen_preprocessor_definitions/test.yaml similarity index 100% rename from testsuite/tests/test/tgen_preprocessor_definitons/test.yaml rename to testsuite/tests/test/tgen_preprocessor_definitions/test.yaml diff --git a/testsuite/tests/test/tgen_preprocessor_definitons/user_project.gpr b/testsuite/tests/test/tgen_preprocessor_definitions/user_project.gpr similarity index 100% rename from testsuite/tests/test/tgen_preprocessor_definitons/user_project.gpr rename to testsuite/tests/test/tgen_preprocessor_definitions/user_project.gpr