From c06c99d72f073307649ea30f620eadf66be15bd7 Mon Sep 17 00:00:00 2001 From: Corentin Machu Date: Wed, 4 Dec 2024 17:06:45 +0100 Subject: [PATCH] Add library level generic package instantiation support --- src/test-common.adb | 22 +- src/test-common.ads | 3 + src/test-generation.adb | 26 +- src/test-harness.adb | 28 +- src/test-harness.ads | 10 +- src/test-skeleton.adb | 220 +++++-- src/tgen/tgen-lal_utils.adb | 16 + src/tgen/tgen-lal_utils.ads | 5 + src/tgen/tgen-libgen.adb | 611 ++++++++++++++---- src/tgen/tgen-libgen.ads | 45 +- .../tgen-marshalling-binary_marshallers.adb | 2 + .../tgen-marshalling-json_marshallers.adb | 10 +- src/tgen/tgen-type_representation.adb | 71 +- src/tgen/tgen-type_representation.ads | 5 +- src/tgen/tgen-types-translation.adb | 12 +- src/tgen/tgen-wrappers.ads | 8 + src/tgen/tgen_rts/tgen-strings.adb | 14 +- src/tgen/tgen_rts/tgen-strings.ads | 7 +- src/tgen/tgen_rts/tgen-types-record_types.adb | 24 +- src/tgen/tgen_rts/tgen-types-record_types.ads | 19 +- src/tgen/tgen_rts/tgen-types.adb | 52 +- src/tgen/tgen_rts/tgen-types.ads | 30 +- .../src/tgen_marshalling.adb | 16 +- .../tests/test/184-generic-lib-item/test.out | 3 +- .../build.gpr | 3 + .../src/bar.ads | 2 + .../src/bob.adb | 13 + .../src/bob.ads | 6 + .../src/foo.adb | 10 + .../src/foo.ads | 8 + .../src/qux.ads | 15 + .../test.out | 113 ++++ .../203-generic-packages-architecture/test.sh | 3 + .../test.yaml | 4 + .../build.gpr | 3 + .../src/bar.adb | 8 + .../src/bar.ads | 7 + .../src/foo.ads | 8 + .../src/main_package.ads | 2 + .../test.out | 6 + .../test.sh | 6 + .../test.yaml | 4 + .../top_level_generic_instantiation/build.gpr | 3 + .../src/bar.ads | 4 + .../src/foo.adb | 6 + .../src/foo.ads | 5 + .../top_level_generic_instantiation/test.out | 6 + .../top_level_generic_instantiation/test.sh | 6 + .../top_level_generic_instantiation/test.yaml | 5 + .../build.gpr | 3 + .../src/bar.ads | 3 + .../src/foo.adb | 12 + .../src/foo.ads | 8 + .../src/main.adb | 6 + .../test.out | 7 + .../test.sh | 5 + .../test.yaml | 5 + .../test/top_level_generic_lib_item/build.gpr | 3 + .../top_level_generic_lib_item/src/bar.adb | 9 + .../top_level_generic_lib_item/src/bar.ads | 14 + .../top_level_generic_lib_item/src/foo.ads | 11 + .../src/main_package.ads | 2 + .../test/top_level_generic_lib_item/test.out | 4 + .../test/top_level_generic_lib_item/test.sh | 2 + .../test/top_level_generic_lib_item/test.yaml | 5 + 65 files changed, 1374 insertions(+), 240 deletions(-) create mode 100644 testsuite/tests/test/203-generic-packages-architecture/build.gpr create mode 100644 testsuite/tests/test/203-generic-packages-architecture/src/bar.ads create mode 100644 testsuite/tests/test/203-generic-packages-architecture/src/bob.adb create mode 100644 testsuite/tests/test/203-generic-packages-architecture/src/bob.ads create mode 100644 testsuite/tests/test/203-generic-packages-architecture/src/foo.adb create mode 100644 testsuite/tests/test/203-generic-packages-architecture/src/foo.ads create mode 100644 testsuite/tests/test/203-generic-packages-architecture/src/qux.ads create mode 100644 testsuite/tests/test/203-generic-packages-architecture/test.out create mode 100644 testsuite/tests/test/203-generic-packages-architecture/test.sh create mode 100644 testsuite/tests/test/203-generic-packages-architecture/test.yaml create mode 100644 testsuite/tests/test/tgen_type_from_generic_packages_chain/build.gpr create mode 100644 testsuite/tests/test/tgen_type_from_generic_packages_chain/src/bar.adb create mode 100644 testsuite/tests/test/tgen_type_from_generic_packages_chain/src/bar.ads create mode 100644 testsuite/tests/test/tgen_type_from_generic_packages_chain/src/foo.ads create mode 100644 testsuite/tests/test/tgen_type_from_generic_packages_chain/src/main_package.ads create mode 100644 testsuite/tests/test/tgen_type_from_generic_packages_chain/test.out create mode 100755 testsuite/tests/test/tgen_type_from_generic_packages_chain/test.sh create mode 100644 testsuite/tests/test/tgen_type_from_generic_packages_chain/test.yaml create mode 100644 testsuite/tests/test/top_level_generic_instantiation/build.gpr create mode 100644 testsuite/tests/test/top_level_generic_instantiation/src/bar.ads create mode 100644 testsuite/tests/test/top_level_generic_instantiation/src/foo.adb create mode 100644 testsuite/tests/test/top_level_generic_instantiation/src/foo.ads create mode 100644 testsuite/tests/test/top_level_generic_instantiation/test.out create mode 100755 testsuite/tests/test/top_level_generic_instantiation/test.sh create mode 100644 testsuite/tests/test/top_level_generic_instantiation/test.yaml create mode 100644 testsuite/tests/test/top_level_generic_instantiation_private/build.gpr create mode 100644 testsuite/tests/test/top_level_generic_instantiation_private/src/bar.ads create mode 100644 testsuite/tests/test/top_level_generic_instantiation_private/src/foo.adb create mode 100644 testsuite/tests/test/top_level_generic_instantiation_private/src/foo.ads create mode 100644 testsuite/tests/test/top_level_generic_instantiation_private/src/main.adb create mode 100644 testsuite/tests/test/top_level_generic_instantiation_private/test.out create mode 100755 testsuite/tests/test/top_level_generic_instantiation_private/test.sh create mode 100644 testsuite/tests/test/top_level_generic_instantiation_private/test.yaml create mode 100644 testsuite/tests/test/top_level_generic_lib_item/build.gpr create mode 100644 testsuite/tests/test/top_level_generic_lib_item/src/bar.adb create mode 100644 testsuite/tests/test/top_level_generic_lib_item/src/bar.ads create mode 100644 testsuite/tests/test/top_level_generic_lib_item/src/foo.ads create mode 100644 testsuite/tests/test/top_level_generic_lib_item/src/main_package.ads create mode 100644 testsuite/tests/test/top_level_generic_lib_item/test.out create mode 100644 testsuite/tests/test/top_level_generic_lib_item/test.sh create mode 100644 testsuite/tests/test/top_level_generic_lib_item/test.yaml diff --git a/src/test-common.adb b/src/test-common.adb index 1309757e..ab5f3835 100755 --- a/src/test-common.adb +++ b/src/test-common.adb @@ -534,6 +534,11 @@ package body Test.Common is begin L1 := Nesting_1'First; L2 := Nesting_2'First; + + if Nesting_1 (L1) /= Nesting_2 (L2) then + return ""; + end if; + loop if Nesting_1 (L1) = Nesting_2 (L2) then @@ -560,6 +565,22 @@ package body Test.Common is end Nesting_Common_Prefix; + function Skip_Prefix (Identifier : String; Prefix : String) + return String is + L1 : Integer := Identifier'First; + L2 : Integer := Prefix'First; + begin + while L1 <= Identifier'Last + and then L2 <= Prefix'Last + and then Identifier (L1) = Prefix (L2) + loop + L1 := @ + 1; + L2 := @ + 1; + end loop; + + return Identifier (L1 .. Identifier'Last); + end Skip_Prefix; + ------------------------ -- Nesting_Difference -- ------------------------ @@ -1355,5 +1376,4 @@ package body Test.Common is => Name.P_Is_Ghost_Code); end if; end Is_Ghost_Code; - end Test.Common; diff --git a/src/test-common.ads b/src/test-common.ads index 3603f9a7..befdba33 100755 --- a/src/test-common.ads +++ b/src/test-common.ads @@ -96,6 +96,9 @@ package Test.Common is (Nesting_1, Nesting_2 : String) return String; -- Returns the common prefix of two nestings + function Skip_Prefix (Identifier : String; Prefix : String) + return String with Pre => Identifier'Last >= Prefix'Last; + function Nesting_Difference (Nesting_1, Nesting_2 : String) return String; -- Returns difference in ending of two nestings without the first dot diff --git a/src/test-generation.adb b/src/test-generation.adb index 84582bbe..ddd80125 100644 --- a/src/test-generation.adb +++ b/src/test-generation.adb @@ -104,6 +104,31 @@ package body Test.Generation is return Over; end if; + for Inst of Node.As_Basic_Decl.P_Generic_Instantiations loop + -- If it is top level generic package instantiation, we call + -- `Include_Subp` but with the associated switch set. + if Inst.Unit.Root.As_Compilation_Unit.F_Body.Kind + = Libadalang.Common.Ada_Library_Item + and then Inst + .Unit + .Root + .As_Compilation_Unit + .F_Body + .As_Library_Item + .F_Item = Inst.As_Basic_Decl + then + if not Include_Subp + (Test.Common.TGen_Libgen_Ctx, Node.As_Basic_Decl, Diags, + Is_Top_Level_Generic_Instantiation => True) + then + Report_Err + ("Error while processing " & Node.Image & ":" & ASCII.LF + & Join (Diags) & ASCII.LF); + end if; + return Over; + end if; + end loop; + if not Include_Subp (Test.Common.TGen_Libgen_Ctx, Node.As_Basic_Decl, Diags) then @@ -116,7 +141,6 @@ package body Test.Generation is end if; -- Traverse subprogram declarations in generic package instantiations - if Node.Kind in Ada_Generic_Package_Instantiation then Node.As_Generic_Package_Instantiation.P_Designated_Generic_Decl .As_Generic_Package_Decl.F_Package_Decl diff --git a/src/test-harness.adb b/src/test-harness.adb index f8e57526..488413a6 100755 --- a/src/test-harness.adb +++ b/src/test-harness.adb @@ -370,6 +370,27 @@ package body Test.Harness is Filter_Package_Name : constant String := Common_Package_Name & ".Mapping"; + + function Calculate_Tested_Subp_Count return Natural; + -- Computes the total number of tested subprograms taking into account + -- different instantiations of the same generic packages using gathered + -- test cases list. + + function Calculate_Tested_Subp_Count return Natural is + Result : Natural := 0; + begin + for M of Test.Mapping.Mapping loop + Result := @ + Natural (M.Test_Info.Length); + end loop; + + return Result; + end Calculate_Tested_Subp_Count; + + Subp_Count : constant Natural := Calculate_Tested_Subp_Count; + Total_Subp_Count : constant Natural := + (if Subp_UT_Counter > Subp_Count + then Subp_UT_Counter + else Subp_Count); begin if not Is_Directory (Common_File_Subdir) then Make_Dir (Common_File_Subdir); @@ -423,8 +444,8 @@ package body Test.Harness is S_Put (3, - "Test_Routines_Total : constant Positive :=" - & Natural'Image (Subp_UT_Counter) & ";"); + "Test_Routines_Total : constant Positive := " + & Total_Subp_Count'Image & ";"); Put_New_Line; Put_New_Line; @@ -4643,6 +4664,9 @@ package body Test.Harness is Unit := Bod.F_Item.As_Ada_Node; case Unit.Kind is + when Ada_Generic_Package_Instantiation => + Data.Generic_Kind := True; + Data.Top_Level_Generic_Instantiation := True; when Ada_Package_Decl => Data.Generic_Kind := False; diff --git a/src/test-harness.ads b/src/test-harness.ads index 27765830..ea589a40 100755 --- a/src/test-harness.ads +++ b/src/test-harness.ads @@ -137,9 +137,17 @@ package Test.Harness is -- List of test_case types in current package -- Flags: - Generic_Kind : Boolean := False; + Generic_Kind : Boolean := False; -- On, when the given package is generic + Top_Level_Generic_Instantiation : Boolean := False; + -- Whether this declaration concern a top level generic + -- instantation. + -- Example (bar.ads): + -- package Bar is new Foo (Integer); + -- + -- where `Foo` is a generic package + Good_For_Suite : Boolean := False; -- The suite should be generated diff --git a/src/test-skeleton.adb b/src/test-skeleton.adb index 8eb238dc..76beac96 100755 --- a/src/test-skeleton.adb +++ b/src/test-skeleton.adb @@ -76,6 +76,9 @@ package body Test.Skeleton is Me_Direct_Callees : constant Trace_Handle := Create ("Skeletons.Direct_Callees", Default => Off); + Generic_Instantiation_Name : constant String := "Generic_Instantiation_"; + -- Prefix for packages that are top level generic instantiation + ------------------- -- Minded Data -- ------------------- @@ -86,6 +89,8 @@ package body Test.Skeleton is package Tests_Per_Unit is new Ada.Containers.Indefinite_Ordered_Maps (String, Natural); use Tests_Per_Unit; + package String_Vectors is new + Ada.Containers.Indefinite_Vectors (Natural, String); Test_Info : Tests_Per_Unit.Map; @@ -209,9 +214,21 @@ package body Test.Skeleton is when Declaration_Data => - Is_Generic : Boolean; + Is_Generic : Boolean := False; -- Indicates if given argument package declaration is generic. + Is_Top_Level_Generic_Instantiation : Boolean := False; + -- True if the declaration is a library level generic + -- instantiation. This information is necessary because it's not + -- possible to create child packages of an instantiation. + -- + -- As a workaround top level generic packages are, wrapped in a + -- package containing the original instantiation. This wrapper + -- package should look like this: + -- package Generic_Instantiation_ is + -- package Instance is new Bar; + -- end Generic_Instantiation_; + Has_Simple_Case : Boolean := False; -- Indicates if we have routines that are not primitives of any -- tagged type. @@ -385,9 +402,6 @@ package body Test.Skeleton is -- Marker Processing -- ----------------------- - package String_Vectors is new - Ada.Containers.Indefinite_Vectors (Natural, String); - type Markered_Data is record Commented_Out : Boolean := False; Short_Name_Used : Boolean := False; @@ -782,7 +796,9 @@ package body Test.Skeleton is -- in dumping the traces for user-written test. -- This is recorded in the Data holder. - if Ada.Directories.Exists (Test.Common.JSON_Test_Dir.all) then + if Ada.Directories.Exists (Test.Common.JSON_Test_Dir.all) + and not Data.Subp_List.Is_Empty + then Data.Has_Gen_Tests := Output_Generated_Tests (Data, Suite_Data_List, TP_List); end if; @@ -898,6 +914,8 @@ package body Test.Skeleton is -- the nestings gathered by Get_Records and Get_Subprograms must be -- replaced with the real nesting of instantiation. + Inside_Top_Level_Inst : Boolean := False; + Instance_Nesting : String_Access; -- Stores the nesting of instantiation and its name @@ -1376,7 +1394,6 @@ package body Test.Skeleton is end Update_Name_Frequency; begin - if not Common_Subp_Node_Filter (Node) then return Over; end if; @@ -1389,7 +1406,43 @@ package body Test.Skeleton is return Over; end if; - if Node.Kind = Ada_Package_Decl and then Inside_Inst then + if (Node.Kind = Ada_Generic_Package_Instantiation + and Node.Parent.Kind = Ada_Library_Item) + or + (Node.Kind = Ada_Generic_Package_Instantiation + and Inside_Top_Level_Inst) + then + Inside_Inst := True; + Inside_Top_Level_Inst := True; + Instance_Nesting := new String' + (Encode + (Node + .As_Generic_Package_Instantiation + .P_Designated_Generic_Decl + .P_Generic_Instantiations (1) + .P_Fully_Qualified_Name, + Node.Unit.Get_Charset)); + Instance_Sloc := new String' + (Base_Name (Data.Unit_File_Name.all) + & ":" + & Trim (First_Line_Number (Node)'Img, Both) + & ":" + & Trim (First_Column_Number (Node)'Img, Both) + & ":"); + Traverse + (Node.As_Generic_Instantiation.P_Designated_Generic_Decl, + Get_Subprograms'Access); + Inside_Top_Level_Inst := False; + Inside_Inst := False; + Free (Instance_Nesting); + Free (Instance_Sloc); + return Over; + end if; + + if Node.Kind = Ada_Package_Decl + and then Inside_Inst + and then not Inside_Top_Level_Inst + then -- No processing for packages nested inside generic ones return Over; end if; @@ -1401,7 +1454,6 @@ package body Test.Skeleton is if Node.Kind = Ada_Generic_Package_Instantiation and then not Inside_Inst and then not Data.Is_Generic then - if Stub_Mode_ON then return Over; end if; @@ -1476,7 +1528,7 @@ package body Test.Skeleton is return Over; end if; - if not Inside_Inst then + if not Inside_Inst or Inside_Top_Level_Inst then Subp_UT_Counter := Subp_UT_Counter + 1; end if; Subp.Subp_Declaration := Node.As_Ada_Node; @@ -1664,14 +1716,21 @@ package body Test.Skeleton is Test_Unit_Name); else - Test_Routine.Nesting := new String' - (Nesting_Common_Prefix - (Data.Unit_Full_Name.all, Subp.Nesting.all) & - "." & Test_Data_Unit_Name & - "." & Test_Unit_Name & "." & - Nesting_Difference - (Data.Unit_Full_Name.all, Subp.Nesting.all) & - "." & Test_Data_Unit_Name & "." & Test_Unit_Name); + if Data.Is_Top_Level_Generic_Instantiation then + Test_Routine.Nesting := new String' + (Data.Unit_Full_Name.all & + "." & Test_Data_Unit_Name & + "." & Test_Unit_Name); + else + Test_Routine.Nesting := new String' + (Nesting_Common_Prefix + (Data.Unit_Full_Name.all, Subp.Nesting.all) & + "." & Test_Data_Unit_Name & + "." & Test_Unit_Name & "." & + Nesting_Difference + (Data.Unit_Full_Name.all, Subp.Nesting.all) & + "." & Test_Data_Unit_Name & "." & Test_Unit_Name); + end if; end if; Test_Package_Name := new String' @@ -2395,13 +2454,8 @@ package body Test.Skeleton is Data.Is_Generic := True; when Ada_Generic_Package_Instantiation => - Report_Std - ("gnattest: " - & Base_Name (The_Unit.Unit.Get_Filename) - & " is a library level instantiation"); - Apropriate_Source := False; - Set_Source_Status (The_Unit.Unit.Get_Filename, Bad_Content); - return; + Data.Is_Top_Level_Generic_Instantiation := True; + Apropriate_Source := True; when others => Report_Std @@ -2471,7 +2525,10 @@ package body Test.Skeleton is Data.Unit := The_Unit; Data.Unit_Full_Name := new String' - (Node_Image (Unit.As_Basic_Decl.P_Defining_Name)); + (if Data.Is_Top_Level_Generic_Instantiation + then Generic_Instantiation_Name + & Node_Image (Unit.As_Basic_Decl.P_Defining_Name) + else Node_Image (Unit.As_Basic_Decl.P_Defining_Name)); Data.Unit_File_Name := new String'(The_Unit.Unit.Get_Filename); Trace (Me, "Gathering nested packages"); @@ -3547,7 +3604,9 @@ package body Test.Skeleton is use GNAT.OS_Lib; Cur : Package_Info_List.Cursor := Data.Package_Data_List.First; Output_Dir : constant String := - Get_Source_Output_Dir (Data.Unit_File_Name.all); + Get_Source_Output_Dir + (Skip_Prefix + (Data.Unit_File_Name.all, Generic_Instantiation_Name)); begin loop exit when Cur = Package_Info_List.No_Element; @@ -3558,8 +3617,9 @@ package body Test.Skeleton is S_Pack : constant String := Data.Unit_Full_Name.all & "." & Test_Data_Unit_Name & "." & - Test_Unit_Name & "." & - Nesting_Difference (Data.Unit_Full_Name.all, S); + Test_Unit_Name & (if Data.Is_Top_Level_Generic_Instantiation + then "" + else ("." & Nesting_Difference (Data.Unit_Full_Name.all, S))); begin if Data.Unit_Full_Name.all /= S @@ -3580,6 +3640,15 @@ package body Test.Skeleton is Package_Info_List.Next (Cur); end loop; + -- Create generic instantiation package if it does not already exists + if Data.Is_Top_Level_Generic_Instantiation then + TGen.Libgen.Create_Generic_Wrapper_Package_If_Not_Exists + (Unit_To_File_Name (Data.Unit_Full_Name.all), + Skip_Prefix + (Data.Unit_Full_Name.all, Generic_Instantiation_Name), + Output_Dir); + end if; + if not Data.Has_Simple_Case then Create (Output_Dir & Directory_Separator & @@ -3647,7 +3716,8 @@ package body Test.Skeleton is TP_List : in out TP_Mapping_List.List) is Output_Dir : constant String := - Get_Source_Output_Dir (Data.Unit_File_Name.all); + Get_Source_Output_Dir + (Skip_Prefix (Data.Unit_File_Name.all, Generic_Instantiation_Name)); Tmp_File_Name : constant String := Ada.Directories.Compose @@ -4002,6 +4072,12 @@ package body Test.Skeleton is Gen_Tests.Gen_Unit_Full_Name := new String'(Data.Unit_Full_Name.all); end if; + if Data.Is_Top_Level_Generic_Instantiation then + pragma Assert (not Data.Package_Data_List.Is_Empty); + Current_Pack := Data.Package_Data_List.First_Element; + Update_Generic_Packages (Current_Pack.Generic_Containing_Package.all); + end if; + for I in Data.Type_Data_List.First_Index .. Data.Type_Data_List.Last_Index loop @@ -5590,14 +5666,20 @@ package body Test.Skeleton is Data_Unit_Name := new String' (Current_Pack.Name.all & "." & Test_Data_Unit_Name); else - Data_Unit_Name := new String' - (Data.Unit_Full_Name.all & "." & - Test_Data_Unit_Name & "." & - Test_Unit_Name & "." & - Nesting_Difference - (Current_Pack.Name.all, - Data.Unit_Full_Name.all) & - "." & Test_Data_Unit_Name); + if Data.Is_Top_Level_Generic_Instantiation then + Data_Unit_Name := new String' + (Data.Unit_Full_Name.all & "." & + Test_Data_Unit_Name); + else + Data_Unit_Name := new String' + (Data.Unit_Full_Name.all & "." & + Test_Data_Unit_Name & "." & + Test_Unit_Name & "." & + Nesting_Difference + (Current_Pack.Name.all, + Data.Unit_Full_Name.all) & + "." & Test_Data_Unit_Name); + end if; end if; Test_File_Name := new String' @@ -5616,7 +5698,9 @@ package body Test.Skeleton is Put_Test_Data_Header; - if Current_Pack.Data_Kind = Instantiation then + if Current_Pack.Data_Kind = Instantiation + and not Data.Is_Top_Level_Generic_Instantiation + then S_Put (0, "with " @@ -5670,7 +5754,9 @@ package body Test.Skeleton is Put_New_Line; Put_New_Line; - if Current_Pack.Data_Kind = Instantiation then + if Current_Pack.Data_Kind = Instantiation + and not Data.Is_Top_Level_Generic_Instantiation + then S_Put (0, GT_Marker_Begin); Put_New_Line; S_Put @@ -5739,7 +5825,9 @@ package body Test.Skeleton is S_Put (0, "package body " & Data_Unit_Name.all & " is"); Put_New_Line; Put_New_Line; - if Current_Pack.Data_Kind = Declaration_Data then + if Current_Pack.Data_Kind = Declaration_Data + or Data.Is_Top_Level_Generic_Instantiation + then S_Put (3, "procedure Set_Up (Gnattest_T : in out Test) is"); Put_New_Line; if Current_Pack.Is_Generic then @@ -5889,14 +5977,23 @@ package body Test.Skeleton is Test_Data_Unit_Name & "." & Test_Unit_Name); else - Unit_Name := new String' - (Data.Unit_Full_Name.all & "." & - Test_Data_Unit_Name & "." & - Test_Unit_Name & "." & - Nesting_Difference - (Current_Pack.Name.all, - Data.Unit_Full_Name.all) & - "." & Test_Data_Unit_Name & "." & Test_Unit_Name); + if Data.Is_Top_Level_Generic_Instantiation + or Data.Is_Generic + then + Unit_Name := new String' + (Data.Unit_Full_Name.all & "." & + Test_Data_Unit_Name & "." & + Test_Unit_Name); + else + Unit_Name := new String' + (Data.Unit_Full_Name.all & "." & + Test_Data_Unit_Name & "." & + Test_Unit_Name & "." & + Nesting_Difference + (Current_Pack.Name.all, + Data.Unit_Full_Name.all) & + "." & Test_Data_Unit_Name & "." & Test_Unit_Name); + end if; end if; Test_File_Name := new String'(Unit_To_File_Name (Unit_Name.all)); @@ -5945,7 +6042,9 @@ package body Test.Skeleton is Put_New_Line; -- Declaring simple test type. - if Current_Pack.Data_Kind = Declaration_Data then + if Current_Pack.Data_Kind = Declaration_Data + or Data.Is_Top_Level_Generic_Instantiation + then S_Put (3, "type Test is new GNATtest_Generated.GNATtest_Standard." & @@ -6797,8 +6896,14 @@ package body Test.Skeleton is JSON_Unit_File : constant Virtual_File := GNATCOLL.VFS.Create (+Test.Common.JSON_Test_Dir.all) - / (+TGen.LAL_Utils.JSON_Test_Filename - (Data.Subp_List.First_Element.Subp_Declaration.As_Basic_Decl)); + / (+(if Data.Is_Top_Level_Generic_Instantiation + then + TGen.LAL_Utils.Top_Level_Instantiation_Test_File_Name + (Data.Unit_Full_Name.all) + else + TGen.LAL_Utils.JSON_Test_Filename + (Data.Subp_List.First_Element + .Subp_Declaration.As_Basic_Decl))); Unit_Raw_Content : GNAT.Strings.String_Access; @@ -6811,7 +6916,7 @@ package body Test.Skeleton is -- Diagnostics for TGen.Libgen.Include_Subp Output_Dir : constant String := - Get_Source_Output_Dir (Data.Unit_File_Name.all); + Get_Source_Output_Dir (Data.Unit_File_Name.all); function Escape (Input_String : String) return String; -- Escape every double quote inside Input_String @@ -6846,7 +6951,7 @@ package body Test.Skeleton is end if; Unit_Raw_Content := GNATCOLL.VFS.Read_File (JSON_Unit_File); - if Unit_Raw_Content in null then + if Unit_Raw_Content in null or else Unit_Raw_Content.all = "" then return False; end if; @@ -7086,8 +7191,13 @@ package body Test.Skeleton is if not Test.Common.Unparse_Test_Vectors then for Pack of TGen.Libgen.Required_Support_Packages (Ctx => Test.Common.TGen_Libgen_Ctx, - Unit_Name => To_Qualified_Name - (Data.Unit_Full_Name.all)) + Unit_Name + => To_Qualified_Name + (if Data + .Is_Top_Level_Generic_Instantiation + then "TGen_" + & Data.Unit_Full_Name.all + else Data.Unit_Full_Name.all)) loop Put_Line (Body_Kind, "with " & To_Ada (Pack) & "; use " & To_Ada (Pack) & ";"); diff --git a/src/tgen/tgen-lal_utils.adb b/src/tgen/tgen-lal_utils.adb index ecd3d4a8..8a3ac1cf 100644 --- a/src/tgen/tgen-lal_utils.adb +++ b/src/tgen/tgen-lal_utils.adb @@ -21,6 +21,8 @@ -- . -- ------------------------------------------------------------------------------ +with Ada.Characters.Handling; + with Libadalang.Common; use Libadalang.Common; with Test.Common; @@ -142,4 +144,18 @@ package body TGen.LAL_Utils is return Res; end Ultimate_Enclosing_Compilation_Unit; + ------------------------------------------- + -- Get_Top_Level_Instantiation_File_Name -- + ------------------------------------------- + + function Top_Level_Instantiation_Test_File_Name (Unit_Full_Name : String) + return String + is + Tmp : Ada_Qualified_Name; + begin + Tmp.Append + (TGen.Strings.Ada_Identifier'(To_Unbounded_String (Unit_Full_Name))); + return Ada.Characters.Handling.To_Lower + ("tgen_" & To_Symbol (Tmp, Sep => '_') & ".json"); + end Top_Level_Instantiation_Test_File_Name; end TGen.LAL_Utils; diff --git a/src/tgen/tgen-lal_utils.ads b/src/tgen/tgen-lal_utils.ads index 14294de3..31931690 100644 --- a/src/tgen/tgen-lal_utils.ads +++ b/src/tgen/tgen-lal_utils.ads @@ -83,4 +83,9 @@ package TGen.LAL_Utils is -- provide best effort support: generate support for the generic inst. in -- the child package of the package containing the generic instantiation. + function Top_Level_Instantiation_Test_File_Name + (Unit_Full_Name : String) return String + with Pre => Unit_Full_Name /= ""; + -- Get JSON file name when the unit is a library level generic + -- instantiation. end TGen.LAL_Utils; diff --git a/src/tgen/tgen-libgen.adb b/src/tgen/tgen-libgen.adb index c64a6685..f087919a 100644 --- a/src/tgen/tgen-libgen.adb +++ b/src/tgen/tgen-libgen.adb @@ -21,6 +21,7 @@ -- . -- ------------------------------------------------------------------------------ +with Ada.Characters.Handling; with Ada.Command_Line; with Ada.Containers; with Ada.Directories; @@ -36,6 +37,7 @@ with Libadalang.Unparsing; use Libadalang.Unparsing; with Templates_Parser; +with Test.Common; with TGen.Dependency_Graph; use TGen.Dependency_Graph; with TGen.LAL_Utils; with TGen.Marshalling; use TGen.Marshalling; @@ -54,16 +56,21 @@ package body TGen.Libgen is -- Should be set by any call to Include_Subp or Supported_Subprogram. procedure Generate_Support_Library - (Ctx : Libgen_Context; - Pack_Name : Ada_Qualified_Name) with - Pre => Ctx.Types_Per_Package.Contains (Pack_Name); + (Ctx : Libgen_Context; + Pkg_Name : Ada_Qualified_Name; + Is_Top_Level_Generic_Package : Boolean := False) with + Pre => Ctx.Types_Per_Package.Contains (Pkg_Name); -- Generate the support library files (spec and body) for the types that -- are declared in Pack_Name. + -- `Is_Top_Level_Generic_Package` is used to specify if `Pkg_Name` is + -- a top level instantiation so in order to generate the support library + -- in its wrapper package. procedure Generate_Value_Gen_Library - (Ctx : Libgen_Context; - Pack_Name : Ada_Qualified_Name) with - Pre => Ctx.Strat_Types_Per_Package.Contains (Pack_Name); + (Ctx : Libgen_Context; + Pkg_Name : Ada_Qualified_Name; + Is_Generic_Package : Boolean := False) with + Pre => Ctx.Strat_Types_Per_Package.Contains (Pkg_Name); -- Generate the type representation library files (spec and body) for the -- types that are declared in Pack_Name. @@ -73,13 +80,14 @@ package body TGen.Libgen is -- Generate the function wrappers procedure Generate_Harness_Unit - (Ctx : Libgen_Context; - Pack_Name : Ada_Qualified_Name; - Harness_Dir : String; - Test_Output_Dir : String; - Default_Strat : Default_Strat_Kind; - Default_Test_Num : Natural; - Bin_Tests : Boolean) with + (Ctx : Libgen_Context; + Pack_Name : Ada_Qualified_Name; + Harness_Dir : String; + Test_Output_Dir : String; + Default_Strat : Default_Strat_Kind; + Default_Test_Num : Natural; + Bin_Tests : Boolean; + Is_Generic_Instantiation : Boolean := False) with Pre => Ctx.Generation_Map.Contains (Pack_Name); -- Generate one harness unit (spec and body) for the subprograms registered -- in Pack_Name. @@ -98,12 +106,35 @@ package body TGen.Libgen is (Pack_Name : Ada_Qualified_Name) return Ada_Qualified_Name is (Library_Package (Pack_Name, "TGen_Values")); function Wrapper_Library_Package - (Pack_Name : Ada_Qualified_Name) return Ada_Qualified_Name + (Pack_Name : Ada_Qualified_Name) return Ada_Qualified_Name is (Library_Package (Pack_Name, "TGen_Wrappers")); function Generation_Harness_Package (Pack_Name : Ada_Qualified_Name) return Ada_Qualified_Name is (Library_Package (Pack_Name, "TGen_Generation")); - -- Name of the support library package + function Generation_Harness_Package_Generic + (Pack_Name : Ada_Qualified_Name) return Ada_Qualified_Name + is (Library_Package (Generic_Package_Name (Pack_Name), "TGen_Generation")); + -- Name of the support library package + + function Generic_Package_Name + (Pack_Name : Ada_Qualified_Name; Replace_First : Boolean := False) + return Ada_Qualified_Name is + Prefix : constant Ada_Identifier := Ada_Identifier + (+"TGen_Generic_Instantiation_"); + Replace_Element : constant Ada_Identifier := + (if Replace_First + then Pack_Name.First_Element + else Pack_Name.Last_Element); + First_Element_Name : constant Ada_Identifier := Prefix & Replace_Element; + Result : Ada_Qualified_Name; + begin + Result.Append (First_Element_Name); + for i in 2 .. Positive (Pack_Name.Length) loop + Result.Append (Pack_Name (i)); + end loop; + + return Result; + end Generic_Package_Name; procedure Append_Types (Source : Typ_Set; @@ -113,6 +144,26 @@ package body TGen.Libgen is -- Include all the types in Source in the correct package key in Dest. All -- anonymous types are ignored. + function Depends_On_Top_Level_Inst + (Ctx : Libgen_Context; FQN : Ada_Qualified_Name) + return Boolean with Pre => (not FQN.Is_Empty); + -- Does the fully qualified name relies on a top level generic + -- instantiation. + + ------------------------------- + -- Depends_On_Top_Level_Inst -- + ------------------------------- + + function Depends_On_Top_Level_Inst + (Ctx : Libgen_Context; FQN : Ada_Qualified_Name) + return Boolean + is + First_Package : Ada_Qualified_Name; + begin + First_Package.Append (FQN.First_Element); + return Ctx.Pack_Is_Top_Level_Instantiation (First_Package); + end Depends_On_Top_Level_Inst; + ---------------------- -- Replace_Standard -- ---------------------- @@ -149,23 +200,29 @@ package body TGen.Libgen is ------------------------------ procedure Generate_Support_Library - (Ctx : Libgen_Context; - Pack_Name : Ada_Qualified_Name) + (Ctx : Libgen_Context; + Pkg_Name : Ada_Qualified_Name; + Is_Top_Level_Generic_Package : Boolean := False) is use Ada_Identifier_Vectors; - F_Spec : File_Type; - F_Body : File_Type; + Pack_Name : constant Ada_Qualified_Name := + (if Is_Top_Level_Generic_Package + then Support_Library_Package + (Generic_Package_Name (Copy_Delete_Last (Pkg_Name))) + else Pkg_Name); + F_Spec : File_Type; + F_Body : File_Type; Ada_Pack_Name : constant String := To_Ada (Pack_Name); Origin_Unit : Ada_Qualified_Name := Pack_Name.Copy; Typ_Dependencies : Typ_Set; File_Name : constant String := Ada.Directories.Compose (Containing_Directory => To_String (Ctx.Output_Dir), - Name => To_Filename (Pack_Name)); + Name => To_Filename (Origin_Unit)); Types : constant Types_Per_Package_Maps.Constant_Reference_Type := - Ctx.Types_Per_Package.Constant_Reference (Pack_Name); + Ctx.Types_Per_Package.Constant_Reference (Pkg_Name); TRD : constant String := To_String (Ctx.Root_Templates_Dir); @@ -193,7 +250,12 @@ package body TGen.Libgen is if Ctx.Imports_Per_Unit.Contains (Origin_Unit) then for Dep of Ctx.Imports_Per_Unit.Constant_Reference (Origin_Unit) loop - Put_Line (F_Spec, "with " & To_Ada (Dep) & ";"); + if To_Ada (Dep) /= To_Ada (Pack_Name) + and To_Ada (Generic_Package_Name (Dep, True)) + /= To_Ada (Pack_Name) + then + Put_Line (F_Spec, "with " & To_Ada (Dep) & ";"); + end if; end loop; end if; @@ -204,7 +266,10 @@ package body TGen.Libgen is for Dep of Ctx.Support_Packs_Per_Unit .Constant_Reference (Origin_Unit) loop - if Dep /= Pack_Name then + if To_Ada (Dep) /= To_Ada (Pack_Name) + and To_Ada (Generic_Package_Name (Dep, True)) + /= To_Ada (Pack_Name) + then Put_Line (F_Spec, "with " & To_Ada (Dep) & "; use " & To_Ada (Dep) & ";"); end if; @@ -250,11 +315,15 @@ package body TGen.Libgen is end if; end loop; - for Pack_Name of Package_Dependencies loop - Put_Line - (F_Body, - "with " & To_Ada (Pack_Name) & "; use " & To_Ada (Pack_Name) - & ";"); + for Dep of Package_Dependencies loop + if To_Ada (Dep) /= To_Ada (Pack_Name) + and To_Ada (Generic_Package_Name (Dep, True)) + /= To_Ada (Pack_Name) + then + Put_Line + (F_Body, + "with " & To_Ada (Dep) & "; use " & To_Ada (Dep) & ";"); + end if; end loop; end; @@ -363,26 +432,69 @@ package body TGen.Libgen is -------------------------------- procedure Generate_Value_Gen_Library - (Ctx : Libgen_Context; - Pack_Name : Ada_Qualified_Name) + (Ctx : Libgen_Context; + Pkg_Name : Ada_Qualified_Name; + Is_Generic_Package : Boolean := False) is use Templates_Parser; - F_Spec : File_Type; - F_Body : File_Type; - Ada_Pack_Name : constant String := To_Ada (Pack_Name); + F_Spec : File_Type; + F_Body : File_Type; + Resolved_Pkg_Name : constant Ada_Qualified_Name := + (if Is_Generic_Package + then Value_Library_Package + (Generic_Package_Name (Copy_Delete_Last (Pkg_Name))) + else Pkg_Name); + Ada_Pack_Name : constant String := To_Ada (Resolved_Pkg_Name); Typ_Dependencies : Typ_Set; File_Name : constant String := Ada.Directories.Compose (Containing_Directory => To_String (Ctx.Output_Dir), - Name => To_Filename (Pack_Name)); + Name => To_Filename (Resolved_Pkg_Name)); Types : constant Types_Per_Package_Maps.Constant_Reference_Type := - Ctx.Strat_Types_Per_Package.Constant_Reference (Pack_Name); + Ctx.Strat_Types_Per_Package.Constant_Reference (Pkg_Name); Initialization_Code : Tag; -- Code that should be put in the initialization section of the -- package body. + procedure Put_Deps (F : File_Type; Pack_Name : Ada_Qualified_Name); + -- Put dependencies while taking into account generic instantiations + + procedure Put_Deps (F : File_Type; Pack_Name : Ada_Qualified_Name) is + Generic_Pack_Name : constant Ada_Qualified_Name := + Generic_Package_Name (Copy_Delete_Last (Pack_Name)); + Info_Cursor : constant Subp_Info_Vectors_Maps.Cursor := + Ctx.Included_Subps.Find (Generic_Pack_Name); + begin + if Info_Cursor.Has_Element + and then Info_Cursor.Element + .First_Element.Is_Generic_Instantiation + then + Put_Line + (F, + "with " + & To_Ada + (Copy_Delete_Last + (Generic_Package_Name + (Pack_Name, Replace_First => True))) + & "; use " + & To_Ada + (Copy_Delete_Last + (Generic_Package_Name + (Pack_Name, Replace_First => True))) + & ";"); + else + Put_Line + (F, + "with " + & To_Ada (Pack_Name) + & "; use " + & To_Ada (Pack_Name) + & ";"); + end if; + end Put_Deps; + begin Create (F_Spec, Out_File, File_Name & ".ads"); Create (F_Body, Out_File, File_Name & ".adb"); @@ -436,7 +548,11 @@ package body TGen.Libgen is then TGen.Types.Constraints.As_Anonymous_Typ (T) .Named_Ancestor.Get.Compilation_Unit_Name else T.Get.Compilation_Unit_Name); - if Package_Dependency /= Pack_Name then + if Package_Dependency /= Resolved_Pkg_Name + and then Generic_Package_Name + (Copy_Delete_Last (Package_Dependency)) + /= Resolved_Pkg_Name + then Lib_Marshalling_Dependencies.Include (Package_Dependency); end if; end if; @@ -449,23 +565,21 @@ package body TGen.Libgen is then TGen.Types.Constraints.As_Anonymous_Typ (T) .Named_Ancestor.Get.Compilation_Unit_Name else T.Get.Compilation_Unit_Name); - if Package_Dependency /= Pack_Name then + if Package_Dependency /= Resolved_Pkg_Name + and then Generic_Package_Name + (Copy_Delete_Last (Package_Dependency)) + /= Resolved_Pkg_Name + then Lib_Type_Dependencies.Include (Package_Dependency); end if; end loop; for Pack_Name of Lib_Type_Dependencies loop - Put_Line - (F_Spec, - "with " & To_Ada (Pack_Name) & "; use " & To_Ada (Pack_Name) - & ";"); + Put_Deps (F_Spec, Pack_Name); end loop; for Pack_Name of Lib_Marshalling_Dependencies loop - Put_Line - (F_Body, - "with " & To_Ada (Pack_Name) & "; use " & To_Ada (Pack_Name) - & ";"); + Put_Deps (F_Body, Pack_Name); end loop; end; @@ -483,11 +597,34 @@ package body TGen.Libgen is -- types here. for T of Sort (Types) loop - TGen.Type_Representation.Generate_Type_Representation_For_Typ - (F_Spec, F_Body, T.Get, - To_String (Ctx.Root_Templates_Dir), - Ctx.Strategy_Map, - Initialization_Code); + declare + function Extract_Package_Name (Name : Ada_Qualified_Name) + return Ada_Qualified_Name with Pre => not Name.Is_Empty; + + function Extract_Package_Name (Name : Ada_Qualified_Name) + return Ada_Qualified_Name + is + Result : Ada_Qualified_Name; + begin + Result.Append (Name.First_Element); + return Generic_Package_Name (Result, Replace_First => True); + end Extract_Package_Name; + + Generic_Pack_Cursor : constant Subp_Info_Vectors_Maps.Cursor := + Ctx.Included_Subps.Find + (Extract_Package_Name (T.Get.Package_Name)); + Is_Top_Level_Generic : constant Boolean := + Generic_Pack_Cursor.Has_Element + and then Generic_Pack_Cursor.Element + .First_Element.Is_Generic_Instantiation; + begin + TGen.Type_Representation.Generate_Type_Representation_For_Typ + (F_Spec, F_Body, Ctx, T.Get, + To_String (Ctx.Root_Templates_Dir), + Ctx.Strategy_Map, + Initialization_Code, + Is_Top_Level_Gen => Is_Top_Level_Generic); + end; end loop; -- Print the initialization code, used for the type representation @@ -515,15 +652,15 @@ package body TGen.Libgen is is F_Spec : File_Type; F_Body : File_Type; - Ada_Pack_Name : constant String := To_Ada (Pack_Name); + Generated_Pack_Name : constant Ada_Qualified_Name := + Wrapper_Library_Package (Pack_Name); + Ada_Pack_Name : constant String := To_Ada (Generated_Pack_Name); File_Name : constant String := Ada.Directories.Compose (Containing_Directory => To_String (Ctx.Output_Dir), - Name => To_Filename (Pack_Name)); - Origin_Package : Ada_Qualified_Name := Pack_Name; + Name => To_Filename (Generated_Pack_Name)); + Origin_Package : constant Ada_Qualified_Name := Pack_Name; begin - Origin_Package.Delete_Last; - Create (F_Spec, Out_File, File_Name & ".ads"); Create (F_Body, Out_File, File_Name & ".adb"); @@ -678,7 +815,8 @@ package body TGen.Libgen is function Include_Subp (Ctx : in out Libgen_Context; Subp : Basic_Decl'Class; - Diags : out String_Vectors.Vector) return Boolean + Diags : out String_Vectors.Vector; + Is_Top_Level_Generic_Instantiation : Boolean := False) return Boolean is use Ada_Qualified_Name_Sets_Maps; @@ -686,7 +824,7 @@ package body TGen.Libgen is -- Transitive closure of required types for the parameters of the -- subprogram. - Unit_Name : constant Ada_Qualified_Name := + Unit_Name : Ada_Qualified_Name := TGen.LAL_Utils.Convert_Qualified_Name (TGen.LAL_Utils.Ultimate_Enclosing_Compilation_Unit (Subp) .P_Fully_Qualified_Name_Array); @@ -702,12 +840,44 @@ package body TGen.Libgen is Dummy_Inserted : Boolean; Trans_Res : constant SP.Ref := Supported_Subprogram (Subp); + begin if Trans_Res.Get.Kind = Unsupported then Diags := Trans_Res.Get.Get_Diagnostics; return False; end if; + if Is_Top_Level_Generic_Instantiation then + -- Check if the generic package has a private part by traversing it. + -- If it has a private part, we can't generate tests from it because + -- there's no way to access private elements of a generic package. + declare + Package_Internal : constant Generic_Package_Internal := Subp + .Parent + .Parent + .Parent + .As_Generic_Package_Internal; + begin + if not Package_Internal.F_Private_Part.Is_Null + and then Package_Internal + .F_Private_Part + .F_Decls.First_Child /= No_Ada_Node + then + Put_Line + ("warning (TGen): generic package " + & Image (Package_Internal.P_Fully_Qualified_Name) + & " with private declarations" + & " is not supported."); + end if; + end; + + -- Retrieve the generic package name if it is an instantiation. + -- This ensures that code generated from generics is placed + -- in a separate package, preventing the creation of child packages + -- under a generic package. + Unit_Name := Generic_Package_Name (Unit_Name); + end if; + if Support_Packs = No_Element then Ctx.Support_Packs_Per_Unit.Insert (Unit_Name, @@ -729,9 +899,15 @@ package body TGen.Libgen is Imports, Dummy_Inserted); for Unit of Subp.P_Enclosing_Compilation_Unit.P_Withed_Units loop - Ctx.Imports_Per_Unit.Reference (Imports).Insert - (TGen.LAL_Utils.Convert_Qualified_Name - (Unit.P_Syntactic_Fully_Qualified_Name)); + if not Ctx.Imports_Per_Unit + .Constant_Reference (Imports) + .Contains (TGen.LAL_Utils.Convert_Qualified_Name + (Unit.P_Syntactic_Fully_Qualified_Name)) + then + Ctx.Imports_Per_Unit.Reference (Imports).Insert + (TGen.LAL_Utils.Convert_Qualified_Name + (Unit.P_Syntactic_Fully_Qualified_Name)); + end if; end loop; end if; @@ -740,6 +916,8 @@ package body TGen.Libgen is Fct_Typ : Function_Typ'Class := As_Function_Typ (Trans_Res); Fct_Ref : SP.Ref; begin + Fct_Typ.Top_Level_Generic := Is_Top_Level_Generic_Instantiation; + Fct_Typ.Is_Generic := Subp.P_Generic_Instantiations'Size > 0; Orig_Fct_Ref.Set (Fct_Typ); -- Check strategies. TODO???: integrate it into the type translation @@ -822,13 +1000,16 @@ package body TGen.Libgen is if not Fct_Ref.Get.Supports_Gen then Put_Line ("Warning (TGen): subprogram " - & Image (Subp.P_Unique_Identifying_Name) & " does not support" - & " value generation."); + & Image (Subp.P_Unique_Identifying_Name) & " does not support" + & " value generation."); else Append_Types (Typ_Sets.To_Set (Fct_Ref), Ctx.Generation_Map, - Generation_Harness_Package'Access); + (if Is_Top_Level_Generic_Instantiation then + Generation_Harness_Package_Generic'Access + else + Generation_Harness_Package'Access)); end if; -- Add it to the list of included subprograms in the context @@ -840,13 +1021,18 @@ package body TGen.Libgen is To_Unbounded_Text (To_Text ("Pre")); Subp_Info : Subp_Information; begin + Subp_Info.Is_Generic_Instantiation := + Is_Top_Level_Generic_Instantiation; + if Subp.P_Has_Aspect (Pre_Aspect) then Subp_Info.Pre := +Unparse (Subp.P_Get_Aspect_Spec_Expr (Pre_Aspect)); end if; Subp_Info.T := Fct_Ref; Ctx.Included_Subps.Insert - (Wrapper_Library_Package (Fct_Ref.Get.Compilation_Unit_Name), + ((if Is_Top_Level_Generic_Instantiation + then Generic_Package_Name (Fct_Ref.Get.Compilation_Unit_Name) + else Fct_Ref.Get.Compilation_Unit_Name), [], Cur, Dummy_Inserted); @@ -948,26 +1134,60 @@ package body TGen.Libgen is if Part (Marshalling_Part) then for Cur in Ctx.Types_Per_Package.Iterate loop - -- If all types are not supported, do not generate a support - -- library. - - if not (for all T of Element (Cur) => - not Is_Supported_Type (T.Get)) - then - Generate_Support_Library (Ctx, Key (Cur)); - end if; + declare + Pkg_Info : constant TGen.Libgen.Subp_Info_Vectors_Maps.Cursor := + Ctx.Included_Subps.Find + (Generic_Package_Name (Copy_Delete_Last (Key (Cur)))); + Support_Lib_Name : constant Ada_Qualified_Name := + Support_Library_Package (Copy_Delete_Last (Key (Cur))); + begin + -- If all types are not supported, do not generate a support + -- library. + if not (for all T of Element (Cur) => + not Is_Supported_Type (T.Get)) + then + if Pkg_Info.Has_Element then + if Pkg_Info.Element.Last_Element.Is_Generic_Instantiation + then + Create_Generic_Wrapper_Package_If_Not_Exists + (To_Ada (Generic_Package_Name + (Copy_Delete_Last (Key (Cur)))), + To_Ada (Copy_Delete_Last (Key (Cur))), + Output_Dir); + end if; + Generate_Support_Library + (Ctx, + Support_Lib_Name, + Pkg_Info.Element.Last.Element + .Is_Generic_Instantiation); + else + Generate_Support_Library (Ctx, Support_Lib_Name); + end if; + end if; + end; end loop; end if; if Part (Test_Generation_Part) then for Cur in Ctx.Strat_Types_Per_Package.Iterate loop - -- If all types are not supported, do not generate a support - -- library. - - if not (for all T of Element (Cur) => - not Is_Supported_Type (T.Get)) - then - Generate_Value_Gen_Library (Ctx, Key (Cur)); - end if; + declare + Pkg_Name : constant TGen.Libgen.Subp_Info_Vectors_Maps.Cursor := + Ctx.Included_Subps.Find (Generic_Package_Name + (Copy_Delete_Last (Key (Cur)))); + begin + -- If all types are not supported, do not generate a support + -- library. + + if not (for all T of Element (Cur) => + not Is_Supported_Type (T.Get)) + then + Generate_Value_Gen_Library (Ctx, + Key (Cur), + (if Pkg_Name.Has_Element + then + Pkg_Name.Element.Last.Element.Is_Generic_Instantiation + else False)); + end if; + end; end loop; end if; if Part (Wrappers_Part) then @@ -1004,10 +1224,20 @@ package body TGen.Libgen is function Required_Support_Packages (Ctx : Libgen_Context; Unit_Name : TGen.Strings.Ada_Qualified_Name) - return TGen.Strings.Ada_Qualified_Name_Sets_Maps.Constant_Reference_Type + return Ada_Qualified_Name_Set is + Result : Ada_Qualified_Name_Set; begin - return Ctx.Support_Packs_Per_Unit.Constant_Reference (Unit_Name); + for Name of Ctx.Support_Packs_Per_Unit.Constant_Reference (Unit_Name) + loop + if Ctx.Pack_Is_Top_Level_Instantiation (Copy_Delete_Last (Name)) then + Result.Insert (Generic_Package_Name (Name, Replace_First => True)); + else + Result.Insert (Name); + end if; + end loop; + + return Result; end Required_Support_Packages; ---------------------------- @@ -1025,14 +1255,16 @@ package body TGen.Libgen is --------------------------- procedure Generate_Harness_Unit - (Ctx : Libgen_Context; - Pack_Name : Ada_Qualified_Name; - Harness_Dir : String; - Test_Output_Dir : String; - Default_Strat : Default_Strat_Kind; - Default_Test_Num : Natural; - Bin_Tests : Boolean) + (Ctx : Libgen_Context; + Pack_Name : Ada_Qualified_Name; + Harness_Dir : String; + Test_Output_Dir : String; + Default_Strat : Default_Strat_Kind; + Default_Test_Num : Natural; + Bin_Tests : Boolean; + Is_Generic_Instantiation : Boolean := False) is + pragma Unreferenced (Is_Generic_Instantiation); use GNATCOLL.VFS; use Templates_Parser; F_Spec : File_Type; @@ -1045,7 +1277,7 @@ package body TGen.Libgen is / (+"generation_routine.tmplt"); Original_Unit : constant Ada_Qualified_Name := - Copy_Delete_Last (Pack_Name); + Copy_Delete_Last (Pack_Name); Orig_Unit_Support_Pack : constant Ada_Qualified_Name := Support_Library_Package (Original_Unit); Value_Lib_Pack : constant Ada_Qualified_Name := @@ -1089,21 +1321,59 @@ package body TGen.Libgen is New_Line (F_Body); for Dep of Support_Packs loop - Put_Line - (F_Body, "with " & To_Ada (Dep) & "; use " & To_Ada (Dep) & ";"); + if Ctx.Pack_Is_Top_Level_Instantiation (Copy_Delete_Last (Dep)) then + Put_Line + (F_Body, + "with " + & To_Ada (Generic_Package_Name (Dep, True)) + & "; use " + & To_Ada (Generic_Package_Name (Dep, True)) + & ";"); + else + Put_Line + (F_Body, + "with " & To_Ada (Dep) & "; use " & To_Ada (Dep) & ";"); + end if; end loop; if not Support_Packs.Contains (Orig_Unit_Support_Pack) then - Put_Line - (F_Body, - "with " & To_Ada (Orig_Unit_Support_Pack) & "; use " - & To_Ada (Orig_Unit_Support_Pack) & ";"); + if Ctx.Pack_Is_Top_Level_Instantiation + (Copy_Delete_Last (Orig_Unit_Support_Pack)) + then + Put_Line + (To_Ada (Generic_Package_Name (Orig_Unit_Support_Pack))'Image); + Put_Line + (F_Body, + "with " + & To_Ada (Generic_Package_Name (Orig_Unit_Support_Pack, True)) + & "; use " + & To_Ada (Generic_Package_Name (Orig_Unit_Support_Pack, True)) + & ";"); + else + Put_Line + (F_Body, + "with " & To_Ada (Orig_Unit_Support_Pack) & "; use " + & To_Ada (Orig_Unit_Support_Pack) & ";"); + end if; end if; New_Line (F_Body); - Put_Line - (F_Body, "with " & To_Ada (Value_Lib_Pack) & "; use " - & To_Ada (Value_Lib_Pack) & ";"); + if Ctx.Pack_Is_Top_Level_Instantiation + (Copy_Delete_Last (Value_Lib_Pack)) + then + Put_Line + (F_Body, + "with " + & To_Ada (Generic_Package_Name (Value_Lib_Pack, True)) + & "; use " + & To_Ada (Generic_Package_Name (Value_Lib_Pack, True)) + & ";"); + else + Put_Line + (F_Body, + "with " & To_Ada (Value_Lib_Pack) & "; use " + & To_Ada (Value_Lib_Pack) & ";"); + end if; New_Line (F_Body); Put_Line (F_Body, "package body " & To_Ada (Pack_Name) & " is"); @@ -1127,7 +1397,10 @@ package body TGen.Libgen is Global_Output_FNs : Vector_Tag; Real_Name : constant String := - As_Function_Typ (Subp).Simple_Name; + (if Subp.Get.Is_Generic + then + To_Symbol (As_Function_Typ (Subp).Name, Sep => '_') + else As_Function_Typ (Subp).Simple_Name); Subp_Name : constant String := (if Is_Operator (Real_Name) then Map_Operator_Name (Real_Name) @@ -1147,13 +1420,15 @@ package body TGen.Libgen is Assocs.Insert (Assoc ("GLOBAL_PREFIX", Global_Prefix)); Assocs.Insert (Assoc ("NUM_TESTS", Default_Test_Num)); Assocs.Insert (Assoc ("ENUM_STRAT", Default_Strat = Stateful)); - Assocs.Insert - (Assoc ("SUBP_NAME", Subp_Name)); + Assocs.Insert (Assoc ("SUBP_NAME", (Subp_Name))); Assocs.Insert (Assoc ("SUBP_UID", As_Function_Typ (Subp).Subp_UID)); Assocs.Insert (Assoc - ("FN_TYP_REF", Subp.Get.Slug & "_Typ_Ref")); + ("FN_TYP_REF", + Subp.Get.Slug (Top_Level_Generic => + Depends_On_Top_Level_Inst (Ctx, Subp.Get.Name)) + & "_Typ_Ref")); -- Deal with parameters @@ -1227,9 +1502,24 @@ package body TGen.Libgen is if not Bin_Tests then Put_Line (F_Body, " Dumper : constant TGen.JSON.Utils" & ".JSON_Auto_IO :="); - Put_Line (F_Body, " TGen.JSON.Utils.Create (""" - & Test_Output_Dir & GNAT.OS_Lib.Directory_Separator - & To_Filename (Original_Unit) & ".json"");"); + declare + C : constant Subp_Info_Vectors_Maps.Cursor := + Ctx.Included_Subps.Find (Original_Unit); + begin + if C.Has_Element + and C.Element.First.Element.Is_Generic_Instantiation + then + Put_Line (F_Body, " TGen.JSON.Utils.Create (""" + & Test_Output_Dir & GNAT.OS_Lib.Directory_Separator + & Ada.Characters.Handling.To_Lower + (To_Symbol (Copy_Delete_Last (Pack_Name), Sep => '_')) + & ".json"");"); + else + Put_Line (F_Body, " TGen.JSON.Utils.Create (""" + & Test_Output_Dir & GNAT.OS_Lib.Directory_Separator + & To_Filename (Original_Unit) & ".json"");"); + end if; + end; Put_Line (F_Body, " Unit_JSON : TGen.JSON.JSON_Value := Dumper" & ".Get_JSON_Ref;"); end if; @@ -1237,7 +1527,9 @@ package body TGen.Libgen is for Subp of Subps loop declare Real_Name : constant String := - As_Function_Typ (Subp).Simple_Name; + (if Subp.Get.Is_Generic + then To_Symbol (As_Function_Typ (Subp).Name, Sep => '_') + else As_Function_Typ (Subp).Simple_Name); Subp_Name : constant String := (if Is_Operator (Real_Name) then Map_Operator_Name (Real_Name) @@ -1355,10 +1647,8 @@ 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 ("); + Put_Line (Prj_File, "package Compiler is"); + 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;"); @@ -1377,15 +1667,44 @@ package body TGen.Libgen is Put_Line (Main_File, "procedure Generation_Main is"); Put_Line (Main_File, "begin"); for Unit_Cur in Ctx.Generation_Map.Iterate loop - Put_Line (Main_File, " " & To_Ada (Key (Unit_Cur)) & ".Generate;"); - Generate_Harness_Unit - (Ctx, - Key (Unit_Cur), - Harness_Dir, - Test_Output_Dir, - Default_Strat, - Default_Test_Num, - Bin_Tests); + declare + Fully_Qualified_Name : constant Ada_Qualified_Name := + Key (Unit_Cur); + Pkg_Infos : constant Subp_Info_Vectors_Maps.Cursor := + Ctx.Included_Subps.Find + (Copy_Delete_Last (Fully_Qualified_Name)); + begin + Put_Line (Main_File, " " + & To_Ada (Fully_Qualified_Name) + & ".Generate;"); + if Pkg_Infos.Has_Element + and then Pkg_Infos.Element.Last.Element + .Is_Generic_Instantiation + then + Generate_Harness_Unit + (Ctx, + Fully_Qualified_Name, + Harness_Dir, + Test_Output_Dir, + Default_Strat, + Default_Test_Num, + Bin_Tests, + Pkg_Infos.Element.First.Element.Is_Generic_Instantiation); + Create_Generic_Wrapper_Package_If_Not_Exists + (To_Ada (Copy_Delete_Last (Fully_Qualified_Name)), + "Bar", + Ctx.Get_Output_Dir); + else + Generate_Harness_Unit + (Ctx, + Fully_Qualified_Name, + Harness_Dir, + Test_Output_Dir, + Default_Strat, + Default_Test_Num, + Bin_Tests); + end if; + end; end loop; Put_Line (Main_File, "end Generation_Main;"); Close (Main_File); @@ -1425,4 +1744,56 @@ package body TGen.Libgen is or not Data.File_Configs.Is_Empty; Ctx.Preprocessor_Definitions := Data; end Set_Preprocessing_Definitions; + + -------------------- + -- Get_Output_Dir -- + -------------------- + + function Get_Output_Dir (Ctx : Libgen_Context) return String is + begin + return To_String (Ctx.Output_Dir); + end Get_Output_Dir; + + function Pack_Is_Top_Level_Instantiation + (Ctx : Libgen_Context; Pack_Name : Ada_Qualified_Name) return Boolean is + C : constant Subp_Info_Vectors_Maps.Cursor := + Ctx.Included_Subps.Find (Generic_Package_Name (Pack_Name)); + begin + return C.Has_Element + and then C.Element.First_Element.Is_Generic_Instantiation; + end Pack_Is_Top_Level_Instantiation; + + -------------------------------------------------- + -- Create_Generic_Wrapper_Package_If_Not_Exists -- + -------------------------------------------------- + + procedure Create_Generic_Wrapper_Package_If_Not_Exists + (Unit_Name : String; + Base_Name : String; + Output_Dir : String) + is + use Test.Common; + use GNATCOLL.VFS; + File_Name : constant String := + +(GNATCOLL.VFS.Create (+Unit_To_File_Name (Unit_Name)).Base_Name + & ".ads"); + Dir_Sep : constant Character := GNAT.OS_Lib.Directory_Separator; + TGen_File_Name : constant String := + TGen_Libgen_Ctx.Get_Output_Dir & Dir_Sep & File_Name; + Gnattest_File_Name : constant String := Output_Dir & Dir_Sep & File_Name; + F_Type : File_Type; + begin + if Create (+Gnattest_File_Name).Is_Readable + or else Create (+TGen_File_Name).Is_Readable + then + return; + end if; + + Create (F_Type, Out_File, Gnattest_File_Name); + Put_Line (F_Type, "with " & Base_Name & ";"); + Put_Line (F_Type, "package " & Unit_Name & " is"); + Put_Line (F_Type, " package Instance renames " & Base_Name & ";"); + Put_Line (F_Type, "end " & Unit_Name & ";"); + Close (F_Type); + end Create_Generic_Wrapper_Package_If_Not_Exists; end TGen.Libgen; diff --git a/src/tgen/tgen-libgen.ads b/src/tgen/tgen-libgen.ads index 523a1532..faa539ec 100644 --- a/src/tgen/tgen-libgen.ads +++ b/src/tgen/tgen-libgen.ads @@ -81,9 +81,11 @@ package TGen.Libgen is -- supported inlined in the Unsupported_Typ.Reason field. function Include_Subp - (Ctx : in out Libgen_Context; - Subp : LAL.Basic_Decl'Class; - Diags : out TGen.Strings.String_Vectors.Vector) return Boolean; + (Ctx : in out Libgen_Context; + Subp : LAL.Basic_Decl'Class; + Diags : out + TGen.Strings.String_Vectors.Vector; + Is_Top_Level_Generic_Instantiation : Boolean := False) return Boolean; -- Register all the types in the parameters of Subp in the set of types for -- which the marshalling library will be generated. This procedures does -- not actually generate any sources, call Generate to create the support @@ -93,6 +95,10 @@ package TGen.Libgen is -- types, or if some of the types are unsupported for marshalling, -- and report diagnostics in Diags. In that case, the context is not -- modified. Otherwise, Diags should be ignored. + -- + -- The `Is_Generic_Instantiation_Only` switch is used when a subp comes + -- from a top level generic instantiation. This flag is required because + -- it triggers the generation of a wrapper package to allow child packages. procedure Generate (Ctx : in out Libgen_Context; Part : Any_Library_Part := All_Parts); @@ -118,7 +124,7 @@ package TGen.Libgen is function Required_Support_Packages (Ctx : Libgen_Context; Unit_Name : TGen.Strings.Ada_Qualified_Name) - return TGen.Strings.Ada_Qualified_Name_Sets_Maps.Constant_Reference_Type; + return TGen.Strings.Ada_Qualified_Name_Set; -- Return a reference to the set of support packages that need to be -- "withed" to be used with the types used in Unit_Name. @@ -173,6 +179,37 @@ package TGen.Libgen is (Ctx : out Libgen_Context; Data : Libadalang.Preprocessing.Preprocessor_Data); -- Set preprocessor definitions to the context. + + function Get_Output_Dir (Ctx : Libgen_Context) return String; + -- Get TGgen's support library output directory + + function Generic_Package_Name + (Pack_Name : TGen.Strings.Ada_Qualified_Name; + Replace_First : Boolean := False) + return TGen.Strings.Ada_Qualified_Name + with Pre => (not Pack_Name.Is_Empty); + -- Add generic instantiation prefix to a qualified name. By default, the + -- function will change the last identifier of a fully qualified name, the + -- `Replace_First` switch can be used to replace the first one instead. + + function Pack_Is_Top_Level_Instantiation + (Ctx : Libgen_Context; Pack_Name : TGen.Strings.Ada_Qualified_Name) + return Boolean; + -- Return if the package is a top level generic instantiation + + procedure Create_Generic_Wrapper_Package_If_Not_Exists + (Unit_Name : String; + Base_Name : String; + Output_Dir : String); + -- Create a wrapper package for top level generic instantiations. In + -- case a of top level generic instantiation, this wrapper allows + -- creation of child packages. The only limitation of this approach + -- is that private generic subprograms can't be accessed which is why + -- they're not supported. + -- + -- `Pack_Name` being the wrapper fully qualified name and `Base_Name` + -- the library level instantiation fully qualified name. + private use TGen.Strings; use TGen.Context; diff --git a/src/tgen/tgen-marshalling-binary_marshallers.adb b/src/tgen/tgen-marshalling-binary_marshallers.adb index 0a26aff9..8f8e3922 100644 --- a/src/tgen/tgen-marshalling-binary_marshallers.adb +++ b/src/tgen/tgen-marshalling-binary_marshallers.adb @@ -255,12 +255,14 @@ package body TGen.Marshalling.Binary_Marshallers is -- part: This is not the case as soon as one of the discriminants -- is fully private. + pragma Style_Checks (Off); Size_Max_Pub : constant Boolean := not (Typ in Discriminated_Record_Typ'Class) or else not (for some Disc_Typ of Discriminated_Record_Typ'Class (Typ).Discriminant_Types => Disc_Typ.Get.Fully_Private); + pragma Style_Checks (On); begin Put_Line (Spec_Part, Parse (Composite_Base_Spec_Template, Assocs)); New_Line (Spec_Part); diff --git a/src/tgen/tgen-marshalling-json_marshallers.adb b/src/tgen/tgen-marshalling-json_marshallers.adb index f0c047b4..80b0c3d0 100644 --- a/src/tgen/tgen-marshalling-json_marshallers.adb +++ b/src/tgen/tgen-marshalling-json_marshallers.adb @@ -306,6 +306,10 @@ package body TGen.Marshalling.JSON_Marshallers is Global_Full_Types : Vector_Tag; Global_Slugs : Vector_Tag; Global_Types_FNs : Vector_Tag; + Proc_Name : constant String := + (if FN_Typ.Is_Generic and then not Is_Operator (FN_Typ.Simple_Name) + then To_Symbol (FN_Typ.Name, Sep => '_') + else FN_Typ.Simple_Name); begin if FN_Typ.Component_Types.Is_Empty and then FN_Typ.Globals.Is_Empty then return; @@ -313,9 +317,9 @@ package body TGen.Marshalling.JSON_Marshallers is Assocs.Insert (Assoc ("GLOBAL_PREFIX", Global_Prefix)); Assocs.Insert (Assoc ("PROC_NAME", - (if Is_Operator (FN_Typ.Simple_Name) - then Map_Operator_Name (FN_Typ.Simple_Name) - else (FN_Typ.Simple_Name)))); + (if Is_Operator (Proc_Name) + then Map_Operator_Name (Proc_Name) + else Proc_Name))); Assocs.Insert (Assoc ("PROC_FQN", Utils.String_Utilities.Escape_String_Literal diff --git a/src/tgen/tgen-type_representation.adb b/src/tgen/tgen-type_representation.adb index 7bfe607a..92ed859e 100644 --- a/src/tgen/tgen-type_representation.adb +++ b/src/tgen/tgen-type_representation.adb @@ -340,7 +340,8 @@ package body TGen.Type_Representation is (T : Anonymous_Typ'Class; Anonymous_Typ_Decl_Template, Anonymous_Typ_Init_Template : String; Constraint_Decl_Template, Constraint_Init_Template : String; - T_Decl, T_Init : out Unbounded_String); + T_Decl, T_Init : out Unbounded_String; + Is_Top_Level_Generic : Boolean := False); -- Return the declarations and initialization for an anonymous type ------------------------------------ @@ -351,10 +352,13 @@ package body TGen.Type_Representation is (T : Anonymous_Typ'Class; Anonymous_Typ_Decl_Template, Anonymous_Typ_Init_Template : String; Constraint_Decl_Template, Constraint_Init_Template : String; - T_Decl, T_Init : out Unbounded_String) + T_Decl, T_Init : out Unbounded_String; + Is_Top_Level_Generic : Boolean := False) is - Ty_Prefix : constant String := T.Slug; - Ty_Name : constant String := Esc (T.FQN (No_Std => True)); + Ty_Prefix : constant String := T.Slug (Is_Top_Level_Generic); + Ty_Name : constant String := + Esc (T.FQN + (No_Std => True, Top_Level_Generic => Is_Top_Level_Generic)); Assocs : Translate_Set; begin Insert (Assocs, Assoc ("TY_NAME", Ty_Name)); @@ -391,15 +395,19 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Instance_Typ (T : Instance_Typ'Class; Instance_Typ_Decl_Template, Instance_Typ_Init_Template : String; - T_Decl, T_Init : out Unbounded_String); + T_Decl, T_Init : out Unbounded_String; + Is_Top_Level_Generic : Boolean := False); procedure Collect_Info_For_Instance_Typ (T : Instance_Typ'Class; Instance_Typ_Decl_Template, Instance_Typ_Init_Template : String; - T_Decl, T_Init : out Unbounded_String) + T_Decl, T_Init : out Unbounded_String; + Is_Top_Level_Generic : Boolean := False) is - Ty_Prefix : constant String := T.Slug; - Ty_Name : constant String := Esc (T.FQN (No_Std => True)); + Ty_Prefix : constant String := T.Slug (Is_Top_Level_Generic); + Ty_Name : constant String := + Esc (T.FQN + (No_Std => True, Top_Level_Generic => Is_Top_Level_Generic)); Assocs : Translate_Set; begin Insert (Assocs, Assoc ("TY_NAME", Ty_Name)); @@ -417,7 +425,8 @@ package body TGen.Type_Representation is (T : Scalar_Typ'Class; Scalar_Typ_Decl_Template, Scalar_Typ_Init_Template : String; Scalar_Typ_Decl : out Unbounded_String; - Scalar_Typ_Init : out Unbounded_String); + Scalar_Typ_Init : out Unbounded_String; + Is_Top_Level_Generic : Boolean := False); --------------------------------- -- Collect_Info_For_Scalar_Typ -- @@ -427,10 +436,13 @@ package body TGen.Type_Representation is (T : Scalar_Typ'Class; Scalar_Typ_Decl_Template, Scalar_Typ_Init_Template : String; Scalar_Typ_Decl : out Unbounded_String; - Scalar_Typ_Init : out Unbounded_String) + Scalar_Typ_Init : out Unbounded_String; + Is_Top_Level_Generic : Boolean := False) is - Ty_Prefix : constant String := T.Slug; - Ty_Name : constant String := Esc (T.FQN (No_Std => True)); + Ty_Prefix : constant String := T.Slug (Is_Top_Level_Generic); + Ty_Name : constant String := + Esc (T.FQN + (No_Std => True, Top_Level_Generic => Is_Top_Level_Generic)); Assocs : Translate_Set; begin Insert (Assocs, Assoc ("TY_NAME", Ty_Name)); @@ -465,10 +477,12 @@ package body TGen.Type_Representation is procedure Generate_Type_Representation_For_Typ (F_Spec, F_Body : File_Type with Unreferenced; + Ctx : TGen.Libgen.Libgen_Context; Typ : TGen.Types.Typ'Class; Templates_Root_Dir : String; Strategies : FQN_To_Parsed_Strat_Maps.Map; - Init_Package_Code : in out Tag) + Init_Package_Code : in out Tag; + Is_Top_Level_Gen : Boolean := False) is TRD : constant String := Templates_Root_Dir @@ -479,8 +493,9 @@ package body TGen.Type_Representation is package Templates is new TGen.Templates (TRD); use Templates.Type_Representation; - Ty_Prefix : constant String := Typ.Slug; - Ty_Name : constant String := Esc (Typ.FQN (No_Std => True)); + Ty_Prefix : constant String := Typ.Slug (Is_Top_Level_Gen); + Ty_Name : constant String := + Esc (Typ.FQN (No_Std => True, Top_Level_Generic => Is_Top_Level_Gen)); Anonymous_Ty_Index : Positive := 1; Variant_Index : Positive := 1; @@ -510,8 +525,8 @@ package body TGen.Type_Representation is procedure Collect_Info_For_Array (T : Array_Typ'Class; - Array_Typ_Decl : out Unbounded_String; - Array_Typ_Init : out Unbounded_String); + Array_Typ_Decl : out Unbounded_String; + Array_Typ_Init : out Unbounded_String); -- Return the specification and initialization for an array type -------------------------------- @@ -523,6 +538,9 @@ package body TGen.Type_Representation is Anonymous_Decl : out Unbounded_String; Anonymous_Init : out Unbounded_String; Component_Ty_Prefix : out Unbounded_String) is + Is_Top_Level_Gen : constant Boolean := + not T.Package_Name.Is_Empty + and then Ctx.Pack_Is_Top_Level_Instantiation (T.Package_Name); begin -- We have to collect anonymous types there and instantiate a new -- prefix for them. It will be the type name + the anonymous type @@ -546,8 +564,9 @@ package body TGen.Type_Representation is Constraint_Decl_Template, Constraint_Init_Template, Anonymous_Decl, - Anonymous_Init); - Component_Ty_Prefix := +Ano_Typ.Slug; + Anonymous_Init, + Is_Top_Level_Gen); + Component_Ty_Prefix := +Ano_Typ.Slug (Is_Top_Level_Gen); Anonymous_Ty_Index := Anonymous_Ty_Index + 1; -- Add the type reference declaration in the body declarative @@ -556,10 +575,11 @@ package body TGen.Type_Representation is Anonymous_Decl := Anonymous_Decl - & (+(Ano_Typ.Slug & "_Typ_Ref : TGen.Types.SP.Ref;")); + & (+Ano_Typ.Slug (Is_Top_Level_Gen)) + & "_Typ_Ref : TGen.Types.SP.Ref;"; end; else - Component_Ty_Prefix := +T.Slug; + Component_Ty_Prefix := +T.Slug (Is_Top_Level_Gen); end if; end Collect_Info_For_Component; @@ -1017,7 +1037,8 @@ package body TGen.Type_Representation is Constraint_Decl_Template, Constraint_Init_Template, Anonymous_Typ_Decl, - Anonymous_Typ_Init); + Anonymous_Typ_Init, + Is_Top_Level_Gen); Put_Line (F_Spec, " " & Anonymous_Typ'Class (Typ).Slug & "_Typ_Ref : SP.Ref;"); Put_Line (F_Body, +Anonymous_Typ_Decl); @@ -1033,7 +1054,8 @@ package body TGen.Type_Representation is Instance_Decl_Template, Instance_Init_Template, Instance_Typ_Decl, - Instance_Typ_Init); + Instance_Typ_Init, + Is_Top_Level_Gen); Put_Line (F_Spec, " " & Ty_Prefix & "_Typ_Ref : TGen.Types.SP.Ref;"); Put_Line (F_Body, +Instance_Typ_Decl); @@ -1079,7 +1101,8 @@ package body TGen.Type_Representation is Scalar_Typ_Decl_Template, Scalar_Typ_Init_Template, Scalar_Typ_Decl, - Scalar_Typ_Init); + Scalar_Typ_Init, + Is_Top_Level_Gen); Put_Line (F_Spec, " " & Ty_Prefix & "_Typ_Ref : TGen.Types.SP.Ref;"); Put_Line (F_Body, +Scalar_Typ_Decl); diff --git a/src/tgen/tgen-type_representation.ads b/src/tgen/tgen-type_representation.ads index e887ee5d..2e09ae9b 100644 --- a/src/tgen/tgen-type_representation.ads +++ b/src/tgen/tgen-type_representation.ads @@ -26,6 +26,7 @@ with Ada.Text_IO; use Ada.Text_IO; with Templates_Parser; use Templates_Parser; +with TGen.Libgen; with TGen.Types; use TGen.Types; with TGen.Parse_Strategy; use TGen.Parse_Strategy; @@ -33,10 +34,12 @@ package TGen.Type_Representation is procedure Generate_Type_Representation_For_Typ (F_Spec, F_Body : File_Type; + Ctx : TGen.Libgen.Libgen_Context; Typ : TGen.Types.Typ'Class; Templates_Root_Dir : String; Strategies : FQN_To_Parsed_Strat_Maps.Map; - Init_Package_Code : in out Tag); + Init_Package_Code : in out Tag; + Is_Top_Level_Gen : Boolean := False); -- Generate the TGen type representation for the given type. Note that -- this function is not recursive, and must thus be called for all of -- the component types of this type that are not anonymous types. diff --git a/src/tgen/tgen-types-translation.adb b/src/tgen/tgen-types-translation.adb index 2c9485b6..b90202f8 100644 --- a/src/tgen/tgen-types-translation.adb +++ b/src/tgen/tgen-types-translation.adb @@ -2849,7 +2849,8 @@ package body TGen.Types.Translation is Subtype_Constraints => new Discrete_Range_Constraint' (Translate_Discrete_Range_Constraint (N.As_Subtype_Indication.F_Constraint - .As_Range_Constraint)))); + .As_Range_Constraint)), + others => <>)); end return; when Real_Typ_Range => return Res : Translation_Result (Success => True) do @@ -2864,7 +2865,8 @@ package body TGen.Types.Translation is Subtype_Constraints => new TGen.Types.Constraints.Constraint'Class' (Translate_Real_Constraints - (N.As_Subtype_Indication.F_Constraint)))); + (N.As_Subtype_Indication.F_Constraint)), + others => <>)); end return; when Array_Typ_Range => @@ -2886,7 +2888,8 @@ package body TGen.Types.Translation is (Translate_Index_Constraints (N.As_Subtype_Indication.F_Constraint, As_Unconstrained_Array_Typ - (Intermediate_Result.Res).Num_Dims))); + (Intermediate_Result.Res).Num_Dims)), + others => <>); Total_Size : constant Big_Integer := As_Constrained_Array_Typ (Anon_Typ.As_Named_Typ).Size; @@ -2927,7 +2930,8 @@ package body TGen.Types.Translation is Subtype_Constraints => new Discriminant_Constraints' (Translate_Discriminant_Constraints (N.As_Subtype_Indication.F_Constraint - .As_Composite_Constraint)))); + .As_Composite_Constraint)), + others => <>)); end return; when others => return Intermediate_Result; diff --git a/src/tgen/tgen-wrappers.ads b/src/tgen/tgen-wrappers.ads index 753d4854..3ccfa754 100644 --- a/src/tgen/tgen-wrappers.ads +++ b/src/tgen/tgen-wrappers.ads @@ -37,6 +37,14 @@ package TGen.Wrappers is Pre : Unbounded_String; -- Precondition string of the subprogram + + Is_Generic_Instantiation : Boolean; + -- Whether the package is a simply a generic instantiation or not. + -- foo.ads: + -- + -- package Foo is new Bar (Integer); + -- + -- where bar is a generic. end record; procedure Generate_Wrapper_For_Subprogram diff --git a/src/tgen/tgen_rts/tgen-strings.adb b/src/tgen/tgen_rts/tgen-strings.adb index 3ca64e37..68341218 100644 --- a/src/tgen/tgen_rts/tgen-strings.adb +++ b/src/tgen/tgen_rts/tgen-strings.adb @@ -2,7 +2,7 @@ -- -- -- TGen -- -- -- --- Copyright (C) 2022, AdaCore -- +-- Copyright (C) 2024, AdaCore -- -- -- -- TGen is free software; you can redistribute it and/or modify it under -- -- under terms of the GNU General Public License as published by the -- @@ -259,4 +259,16 @@ package body TGen.Strings is end return; end Copy_Delete_Last; + ----------------------- + -- Copy_Delete_First -- + ----------------------- + + function Copy_Delete_First + (FQN : Ada_Qualified_Name) return Ada_Qualified_Name is + begin + return Res : Ada_Qualified_Name := FQN.Copy do + Res.Delete_First; + end return; + end Copy_Delete_First; + end TGen.Strings; diff --git a/src/tgen/tgen_rts/tgen-strings.ads b/src/tgen/tgen_rts/tgen-strings.ads index 3735dddb..e51c30cc 100644 --- a/src/tgen/tgen_rts/tgen-strings.ads +++ b/src/tgen/tgen_rts/tgen-strings.ads @@ -2,7 +2,7 @@ -- -- -- TGen -- -- -- --- Copyright (C) 2022, AdaCore -- +-- Copyright (C) 2024, AdaCore -- -- -- -- TGen is free software; you can redistribute it and/or modify it under -- -- under terms of the GNU General Public License as published by the -- @@ -173,6 +173,11 @@ package TGen.Strings is Pre => Ada.Containers.">=" (FQN.Length, 1); -- Return a copy of FQN, deleting the last name in the process. + function Copy_Delete_First + (FQN : Ada_Qualified_Name) return Ada_Qualified_Name with + Pre => Ada.Containers.">=" (FQN.Length, 1); + -- Return a copy of FQN, deleting the first name in the process. + package Ada_Qualified_Name_Sets is new Ada.Containers.Ordered_Sets (Element_Type => Ada_Qualified_Name, "=" => Ada_Identifier_Vectors."="); diff --git a/src/tgen/tgen_rts/tgen-types-record_types.adb b/src/tgen/tgen_rts/tgen-types-record_types.adb index 431f2516..e89e122b 100644 --- a/src/tgen/tgen_rts/tgen-types-record_types.adb +++ b/src/tgen/tgen_rts/tgen-types-record_types.adb @@ -2,7 +2,7 @@ -- -- -- TGen -- -- -- --- Copyright (C) 2022, AdaCore -- +-- Copyright (C) 2024, AdaCore -- -- -- -- TGen is free software; you can redistribute it and/or modify it under -- -- under terms of the GNU General Public License as published by the -- @@ -1097,7 +1097,8 @@ package body TGen.Types.Record_Types is Component_Types => Components, Static_Gen => Disc_Record.Static_Gen, Fully_Private => Disc_Record.Fully_Private, - Private_Extension => Disc_Record.Private_Extension); + Private_Extension => Disc_Record.Private_Extension, + others => <>); R_Ref : SP.Ref; begin R_Ref.Set (R); @@ -1594,7 +1595,10 @@ package body TGen.Types.Record_Types is -- FQN -- --------- - function FQN (Self : Function_Typ; No_Std : Boolean := False) return String + function FQN + (Self : Function_Typ; + No_Std : Boolean := False; + Top_Level_Generic : Boolean := False) return String is Result : Ada_Qualified_Name := Self.Name.Copy; begin @@ -1606,6 +1610,10 @@ package body TGen.Types.Record_Types is then Result.Delete_First; end if; + + if Top_Level_Generic then + Result := TGen.Types.Generic_Package_Instance_Name (@); + end if; return To_Ada (Result); end FQN; @@ -1875,7 +1883,11 @@ package body TGen.Types.Record_Types is -- Slug -- ---------- - function Slug (Self : Function_Typ) return String is + function Slug + (Self : Function_Typ; + Is_Top_Level_Generic_Instantiation : Boolean := False) + return String + is Temp : Ada_Qualified_Name; begin -- Build a new qualified name, replacing operator names by an @@ -1892,6 +1904,10 @@ package body TGen.Types.Record_Types is end if; end loop; + if Is_Top_Level_Generic_Instantiation then + Temp := Generic_Package_Instance_Name (@); + end if; + return To_Symbol (Temp, '_'); end Slug; diff --git a/src/tgen/tgen_rts/tgen-types-record_types.ads b/src/tgen/tgen_rts/tgen-types-record_types.ads index 2f91d8de..9216349e 100644 --- a/src/tgen/tgen_rts/tgen-types-record_types.ads +++ b/src/tgen/tgen_rts/tgen-types-record_types.ads @@ -392,11 +392,20 @@ package TGen.Types.Record_Types is (Function_Kind); overriding function FQN - (Self : Function_Typ; No_Std : Boolean := False) return String; - -- Return the fully qualified name associated with this subprogram, - -- removing the trailing hash. - - function Slug (Self : Function_Typ) return String; + (Self : Function_Typ; + No_Std : Boolean := False; + Top_Level_Generic : Boolean := False) return String; + -- Return the fully qualified name associated with this subprogram, + -- removing the trailing hash. + -- If No_Std is True, remove the Standard prefix for entities from the + -- standard packaged. + -- The Top_Level_Generic flag can be used to return the generic wrapper + -- package name instead of the package instantiation one. + + function Slug + (Self : Function_Typ; + Is_Top_Level_Generic_Instantiation : Boolean := False) + return String; -- Return a unique identifier for Typ. This transforms the names of -- operators. diff --git a/src/tgen/tgen_rts/tgen-types.adb b/src/tgen/tgen_rts/tgen-types.adb index 351d39e4..714ae5c4 100644 --- a/src/tgen/tgen_rts/tgen-types.adb +++ b/src/tgen/tgen_rts/tgen-types.adb @@ -28,6 +28,34 @@ with TGen.Strategies; use TGen.Strategies; package body TGen.Types is + -------------------------- + -- Generic_Package_Name -- + -------------------------- + + function Generic_Package_Instance_Name + (Pack_Name : Ada_Qualified_Name) + return Ada_Qualified_Name + is + Prefix : constant Ada_Identifier := Ada_Identifier + (+"TGen_Generic_Instantiation_"); + First_Element_Name : constant Ada_Identifier := + Prefix & Pack_Name.First_Element; + Result : Ada_Qualified_Name; + + use Ada_Identifier_Vectors; + begin + Result.Append (First_Element_Name); + Result.Append (Ada_Identifier (+"Instance")); + for I in + Extended_Index'Succ (Pack_Name.First_Index) + .. Pack_Name.Last_Index + loop + Result.Append (Pack_Name.Element (I)); + end loop; + + return Result; + end Generic_Package_Instance_Name; + ----------- -- Image -- ----------- @@ -65,17 +93,23 @@ package body TGen.Types is -- FQN -- --------- - function FQN (Self : Typ; No_Std : Boolean := False) return String is + function FQN (Self : Typ; + No_Std : Boolean := False; + Top_Level_Generic : Boolean := False) return String is + Name : constant Ada_Qualified_Name := + (if Top_Level_Generic + then Generic_Package_Instance_Name (Self.Name) + else Self.Name); begin if not No_Std or else not Ada.Strings.Equal_Case_Insensitive - (+Unbounded_String (Self.Name.First_Element), + (+Unbounded_String (Name.First_Element), "standard") then - return To_Ada (Self.Name); + return To_Ada (Name); end if; declare - Stripped : Ada_Qualified_Name := Self.Name; + Stripped : Ada_Qualified_Name := Name; begin Stripped.Delete_First; return To_Ada (Stripped); @@ -159,9 +193,15 @@ package body TGen.Types is -- Slug -- ---------- - function Slug (Self : Typ) return String is + function Slug (Self : Typ; Top_Level_Generic : Boolean := False) + return String + is + Name : constant Ada_Qualified_Name := + (if Top_Level_Generic + then Generic_Package_Instance_Name (Self.Name) + else Self.Name); begin - return To_Symbol (Self.Name, '_'); + return To_Symbol (Name, '_'); end Slug; ------------------ diff --git a/src/tgen/tgen_rts/tgen-types.ads b/src/tgen/tgen_rts/tgen-types.ads index eec0b889..627cc7d5 100644 --- a/src/tgen/tgen_rts/tgen-types.ads +++ b/src/tgen/tgen_rts/tgen-types.ads @@ -60,7 +60,19 @@ package TGen.Types is -- Whether this type has a private extension. Note that if Fully_Private -- is True, this field will be False. - end record; + Top_Level_Generic : Boolean := False; + -- If the type comes from a top level generic instantiation. + + Is_Generic : Boolean := False; + -- If the type is the result of a generic package instantiation + + end record + with Dynamic_Predicate => + -- A top level generic instantion is a generic itself (Top_Level_Generic + -- implies Is_Generic). + (if Top_Level_Generic + then Top_Level_Generic and Is_Generic + else True); type Typ_Kind is (Invalid_Kind, Signed_Int_Kind, @@ -97,7 +109,8 @@ package TGen.Types is function Image (Self : Typ) return String; - function Slug (Self : Typ) return String; + function Slug (Self : Typ; Top_Level_Generic : Boolean := False) + return String; -- Return a unique identifier for the type function Is_Anonymous (Self : Typ) return Boolean; @@ -125,11 +138,16 @@ package TGen.Types is function Compilation_Unit_Name (Self : Typ) return Ada_Qualified_Name; -- Return the name of the compilation unit this type belongs to - function FQN (Self : Typ; No_Std : Boolean := False) return String; + function FQN + (Self : Typ; + No_Std : Boolean := False; + Top_Level_Generic : Boolean := False) return String; -- Return the fully qualified name for the type. -- -- If No_Std is True, remove the Standard prefix for entities from the -- standard packaged. + -- The Top_Level_Generic flag can be used to return the generic wrapper + -- package name instead of the package instantiation one. function Is_Constrained (Self : Typ) return Boolean is (False); -- An array type with indefinite bounds must be constrained, a discriminant @@ -268,4 +286,10 @@ package TGen.Types is function Kind (Self : Unsupported_Types) return Typ_Kind is (Unsupported); +private + + function Generic_Package_Instance_Name (Pack_Name : Ada_Qualified_Name) + return Ada_Qualified_Name; + -- Return the fully qualified name of a generic instance. + end TGen.Types; 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 2f11a21e..dad5b0f3 100644 --- a/testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb +++ b/testsuite/ada_drivers/gen_marshalling_lib/src/tgen_marshalling.adb @@ -137,6 +137,8 @@ procedure TGen_Marshalling is is pragma Unreferenced (Job_Ctx); + Top_Level_Generic_Inst : Boolean := False; + function Traverse_Helper (Node : LAL.Ada_Node'Class) return LALCO.Visit_Status; @@ -158,7 +160,13 @@ procedure TGen_Marshalling is return LALCO.Over; end if; - if not Include_Subp (Gen_Ctx, Node.As_Basic_Decl, Diags) then + if not Include_Subp + (Gen_Ctx, + Node.As_Basic_Decl, + Diags, + Is_Top_Level_Generic_Instantiation + => Top_Level_Generic_Inst) + then Put_Line ("Error during parameter translation of subprogram " & (+Node.As_Basic_Decl.P_Fully_Qualified_Name) & ":"); @@ -191,10 +199,14 @@ procedure TGen_Marshalling is elsif Unit.Root.Kind /= LALCO.Ada_Compilation_Unit then Put_Line ("Unit is not a compilation unit"); - elsif Unit.Root.As_Compilation_Unit.P_Decl.Kind /= LALCO.Ada_Package_Decl + elsif Unit.Root.As_Compilation_Unit.P_Decl.Kind not in + LALCO.Ada_Package_Decl | LALCO.Ada_Generic_Package_Instantiation then Put_Line ("Unit does not contain a package declaration"); else + Top_Level_Generic_Inst := + Unit.Root.As_Compilation_Unit.P_Decl.Kind + = LALCO.Ada_Generic_Package_Instantiation; LAL.Traverse (Unit.Root, Traverse_Helper'Access); end if; end Process_Unit; diff --git a/testsuite/tests/test/184-generic-lib-item/test.out b/testsuite/tests/test/184-generic-lib-item/test.out index 4e11fe32..db23f8f6 100644 --- a/testsuite/tests/test/184-generic-lib-item/test.out +++ b/testsuite/tests/test/184-generic-lib-item/test.out @@ -2,5 +2,4 @@ gnattest: Error while processing : pkg.identity.X: inst.pair is not supported (types declared a generic package instantiation that is a library item are unsupported) No subprogram supported for test case generation. -Units remaining: 3 Units remaining: 2 gnattest: inst.ads is a library level instantiation -Units remaining: 1 +Units remaining: 3 Units remaining: 2 Units remaining: 1 diff --git a/testsuite/tests/test/203-generic-packages-architecture/build.gpr b/testsuite/tests/test/203-generic-packages-architecture/build.gpr new file mode 100644 index 00000000..2e451e4c --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/build.gpr @@ -0,0 +1,3 @@ +project Build is + for Source_Dirs use ("src"); +end Build; diff --git a/testsuite/tests/test/203-generic-packages-architecture/src/bar.ads b/testsuite/tests/test/203-generic-packages-architecture/src/bar.ads new file mode 100644 index 00000000..6e5bac30 --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/src/bar.ads @@ -0,0 +1,2 @@ +with Foo; +package Bar is new Foo (Float); diff --git a/testsuite/tests/test/203-generic-packages-architecture/src/bob.adb b/testsuite/tests/test/203-generic-packages-architecture/src/bob.adb new file mode 100644 index 00000000..90a85832 --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/src/bob.adb @@ -0,0 +1,13 @@ +package body Bob is + + procedure Bobby (A, B : in out Bob_Type) is + begin + null; + end Bobby; + + procedure Sneaky_Bobby (A : Integer) is + begin + null; + end Sneaky_Bobby; + +end Bob; diff --git a/testsuite/tests/test/203-generic-packages-architecture/src/bob.ads b/testsuite/tests/test/203-generic-packages-architecture/src/bob.ads new file mode 100644 index 00000000..5e0677d9 --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/src/bob.ads @@ -0,0 +1,6 @@ +generic + type Bob_Type is private; +package Bob is + procedure Bobby (A, B : in out Bob_Type); + procedure Sneaky_Bobby (A : Integer); +end Bob; diff --git a/testsuite/tests/test/203-generic-packages-architecture/src/foo.adb b/testsuite/tests/test/203-generic-packages-architecture/src/foo.adb new file mode 100644 index 00000000..ab21b7df --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/src/foo.adb @@ -0,0 +1,10 @@ +package body Foo is + procedure Swap (A, B : in out Foo_Type) + is + C : Foo_Type := A; + begin + A := B; + B := A; + end Swap; + procedure Sneaky (A : Integer) is null; +end Foo; diff --git a/testsuite/tests/test/203-generic-packages-architecture/src/foo.ads b/testsuite/tests/test/203-generic-packages-architecture/src/foo.ads new file mode 100644 index 00000000..e933c173 --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/src/foo.ads @@ -0,0 +1,8 @@ +with Bob; +generic + type Foo_Type is private; +package Foo is + procedure Swap (A, B : in out Foo_Type); + procedure Sneaky (A : Integer); + package Bob_Foo is new Bob (Foo_Type); +end Foo; diff --git a/testsuite/tests/test/203-generic-packages-architecture/src/qux.ads b/testsuite/tests/test/203-generic-packages-architecture/src/qux.ads new file mode 100644 index 00000000..bdc0b6c1 --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/src/qux.ads @@ -0,0 +1,15 @@ +with Foo; +package Qux is + function Qux_Add (I : Integer) return Integer is (2 + I); + type Grault_Type is + record + G : Integer; + end record; + package Corge is new Foo (Integer); + package Waldo is + package Fred is new Foo (Natural); + package Grault is new Foo (Grault_Type); + end Waldo; +private + package Garply is new Foo (Float); +end Qux; diff --git a/testsuite/tests/test/203-generic-packages-architecture/test.out b/testsuite/tests/test/203-generic-packages-architecture/test.out new file mode 100644 index 00000000..93f79fb3 --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/test.out @@ -0,0 +1,113 @@ +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:6:4: info: corresponding test PASSED +bar.ads:6:4: info: corresponding test PASSED +bar.ads:6:4: info: corresponding test PASSED +bar.ads:6:4: info: corresponding test PASSED +bar.ads:6:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +bar.ads:5:4: info: corresponding test PASSED +qux.ads:3:4: info: corresponding test PASSED +qux.ads:3:4: info: corresponding test PASSED +qux.ads:3:4: info: corresponding test PASSED +qux.ads:3:4: info: corresponding test PASSED +qux.ads:3:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:6:4: info: corresponding test PASSED +qux.ads:3:4: error: corresponding test FAILED: Test not implemented. (qux-test_data-tests.adb:45) +foo.ads:5:4 instance at qux.ads:8:4: error: corresponding test FAILED: Test not implemented. (foo-test_data-tests.adb:44) +foo.ads:6:4 instance at qux.ads:8:4: error: corresponding test FAILED: Test not implemented. (foo-test_data-tests.adb:65) +foo.ads:5:4 instance at qux.ads:10:7: error: corresponding test FAILED: Test not implemented. (foo-test_data-tests.adb:44) +foo.ads:6:4 instance at qux.ads:10:7: error: corresponding test FAILED: Test not implemented. (foo-test_data-tests.adb:65) +foo.ads:5:4 instance at qux.ads:11:7: error: corresponding test FAILED: Test not implemented. (foo-test_data-tests.adb:44) +foo.ads:6:4 instance at qux.ads:11:7: error: corresponding test FAILED: Test not implemented. (foo-test_data-tests.adb:65) +112 tests run: 105 passed; 7 failed; 0 crashed. diff --git a/testsuite/tests/test/203-generic-packages-architecture/test.sh b/testsuite/tests/test/203-generic-packages-architecture/test.sh new file mode 100644 index 00000000..e443119c --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/test.sh @@ -0,0 +1,3 @@ +gnattest -q -P build.gpr --gen-test-vectors +gprbuild -q -P gnattest/harness/test_driver.gpr +./gnattest/harness/test_runner diff --git a/testsuite/tests/test/203-generic-packages-architecture/test.yaml b/testsuite/tests/test/203-generic-packages-architecture/test.yaml new file mode 100644 index 00000000..a52e4351 --- /dev/null +++ b/testsuite/tests/test/203-generic-packages-architecture/test.yaml @@ -0,0 +1,4 @@ +description: | + Run TGen test case generator with a complex generic packages architecture. + +driver: gnattest_driver diff --git a/testsuite/tests/test/tgen_type_from_generic_packages_chain/build.gpr b/testsuite/tests/test/tgen_type_from_generic_packages_chain/build.gpr new file mode 100644 index 00000000..2e451e4c --- /dev/null +++ b/testsuite/tests/test/tgen_type_from_generic_packages_chain/build.gpr @@ -0,0 +1,3 @@ +project Build is + for Source_Dirs use ("src"); +end Build; diff --git a/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/bar.adb b/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/bar.adb new file mode 100644 index 00000000..826358c9 --- /dev/null +++ b/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/bar.adb @@ -0,0 +1,8 @@ +package body Bar is + + function Identity (X : Element_Type) return Element_Type is + begin + return X; + end Identity; + +end Bar; diff --git a/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/bar.ads b/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/bar.ads new file mode 100644 index 00000000..0cee7981 --- /dev/null +++ b/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/bar.ads @@ -0,0 +1,7 @@ +generic + type Element_Type is private; +package Bar is + + function Identity (X : Element_Type) return Element_Type; + +end Bar; diff --git a/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/foo.ads b/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/foo.ads new file mode 100644 index 00000000..34791f31 --- /dev/null +++ b/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/foo.ads @@ -0,0 +1,8 @@ +with Bar; +generic + type Element_Type is private; +package Foo is + + package Foo_Bar is new Bar (Element_Type); + +end Foo; diff --git a/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/main_package.ads b/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/main_package.ads new file mode 100644 index 00000000..109d05f6 --- /dev/null +++ b/testsuite/tests/test/tgen_type_from_generic_packages_chain/src/main_package.ads @@ -0,0 +1,2 @@ +with Foo; +package Main_Package is new Foo (Natural); diff --git a/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.out b/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.out new file mode 100644 index 00000000..37d02510 --- /dev/null +++ b/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.out @@ -0,0 +1,6 @@ +main_package.ads:5:4: info: corresponding test PASSED +main_package.ads:5:4: info: corresponding test PASSED +main_package.ads:5:4: info: corresponding test PASSED +main_package.ads:5:4: info: corresponding test PASSED +main_package.ads:5:4: info: corresponding test PASSED +5 tests run: 5 passed; 0 failed; 0 crashed. diff --git a/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.sh b/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.sh new file mode 100755 index 00000000..974a3aef --- /dev/null +++ b/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +gnattest -q -P build.gpr --gen-test-vectors +cd gnattest/harness +gprbuild -q -P test_driver.gpr +./test_runner diff --git a/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.yaml b/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.yaml new file mode 100644 index 00000000..5af6b53c --- /dev/null +++ b/testsuite/tests/test/tgen_type_from_generic_packages_chain/test.yaml @@ -0,0 +1,4 @@ +description: |4 + tgen test + +driver: shell_script diff --git a/testsuite/tests/test/top_level_generic_instantiation/build.gpr b/testsuite/tests/test/top_level_generic_instantiation/build.gpr new file mode 100644 index 00000000..2e451e4c --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation/build.gpr @@ -0,0 +1,3 @@ +project Build is + for Source_Dirs use ("src"); +end Build; diff --git a/testsuite/tests/test/top_level_generic_instantiation/src/bar.ads b/testsuite/tests/test/top_level_generic_instantiation/src/bar.ads new file mode 100644 index 00000000..a7f8ad89 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation/src/bar.ads @@ -0,0 +1,4 @@ +with Foo; + +-- Package is just an instantiation +package Bar is new Foo (Integer); diff --git a/testsuite/tests/test/top_level_generic_instantiation/src/foo.adb b/testsuite/tests/test/top_level_generic_instantiation/src/foo.adb new file mode 100644 index 00000000..de07e420 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation/src/foo.adb @@ -0,0 +1,6 @@ +package body Foo is + function Identity (X : Integer) return Integer is + begin + return X; + end Identity; +end Foo; diff --git a/testsuite/tests/test/top_level_generic_instantiation/src/foo.ads b/testsuite/tests/test/top_level_generic_instantiation/src/foo.ads new file mode 100644 index 00000000..d97e7c27 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation/src/foo.ads @@ -0,0 +1,5 @@ +generic + type T is private; +package Foo is + function Identity (X : Integer) return Integer; +end Foo; diff --git a/testsuite/tests/test/top_level_generic_instantiation/test.out b/testsuite/tests/test/top_level_generic_instantiation/test.out new file mode 100644 index 00000000..b5efe05a --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation/test.out @@ -0,0 +1,6 @@ +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +5 tests run: 5 passed; 0 failed; 0 crashed. diff --git a/testsuite/tests/test/top_level_generic_instantiation/test.sh b/testsuite/tests/test/top_level_generic_instantiation/test.sh new file mode 100755 index 00000000..974a3aef --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation/test.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +gnattest -q -P build.gpr --gen-test-vectors +cd gnattest/harness +gprbuild -q -P test_driver.gpr +./test_runner diff --git a/testsuite/tests/test/top_level_generic_instantiation/test.yaml b/testsuite/tests/test/top_level_generic_instantiation/test.yaml new file mode 100644 index 00000000..46e55903 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation/test.yaml @@ -0,0 +1,5 @@ +description: | + Generate test cases when a package is a simply a generic package + instantiation. + +driver: shell_script diff --git a/testsuite/tests/test/top_level_generic_instantiation_private/build.gpr b/testsuite/tests/test/top_level_generic_instantiation_private/build.gpr new file mode 100644 index 00000000..2e451e4c --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation_private/build.gpr @@ -0,0 +1,3 @@ +project Build is + for Source_Dirs use ("src"); +end Build; diff --git a/testsuite/tests/test/top_level_generic_instantiation_private/src/bar.ads b/testsuite/tests/test/top_level_generic_instantiation_private/src/bar.ads new file mode 100644 index 00000000..e1aab758 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation_private/src/bar.ads @@ -0,0 +1,3 @@ +with Foo; + +package Bar is new Foo (Integer); diff --git a/testsuite/tests/test/top_level_generic_instantiation_private/src/foo.adb b/testsuite/tests/test/top_level_generic_instantiation_private/src/foo.adb new file mode 100644 index 00000000..f2d4f543 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation_private/src/foo.adb @@ -0,0 +1,12 @@ +package body Foo is + procedure Do_Stuff (X : Integer) is + pragma Unreferenced (X); + begin + Do_Private_Stuff; + end Do_Stuff; + + procedure Do_Private_Stuff is + begin + null; + end Do_Private_Stuff; +end Foo; diff --git a/testsuite/tests/test/top_level_generic_instantiation_private/src/foo.ads b/testsuite/tests/test/top_level_generic_instantiation_private/src/foo.ads new file mode 100644 index 00000000..64e548a6 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation_private/src/foo.ads @@ -0,0 +1,8 @@ +generic + type T is private; +package Foo is + procedure Do_Stuff (X : Integer); + +private + procedure Do_Private_Stuff; +end Foo; diff --git a/testsuite/tests/test/top_level_generic_instantiation_private/src/main.adb b/testsuite/tests/test/top_level_generic_instantiation_private/src/main.adb new file mode 100644 index 00000000..03268c24 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation_private/src/main.adb @@ -0,0 +1,6 @@ +with Bar; + +procedure Main is +begin + Bar.Do_Stuff (42); +end Main; diff --git a/testsuite/tests/test/top_level_generic_instantiation_private/test.out b/testsuite/tests/test/top_level_generic_instantiation_private/test.out new file mode 100644 index 00000000..a14a625d --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation_private/test.out @@ -0,0 +1,7 @@ +warning (TGen): generic package Bar with private declarations is not supported. +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +bar.ads:4:4: info: corresponding test PASSED +5 tests run: 5 passed; 0 failed; 0 crashed. diff --git a/testsuite/tests/test/top_level_generic_instantiation_private/test.sh b/testsuite/tests/test/top_level_generic_instantiation_private/test.sh new file mode 100755 index 00000000..f6f7e040 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation_private/test.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +gnattest -q -P build.gpr --gen-test-vectors +gprbuild -q -P ./gnattest/harness/test_driver.gpr +./gnattest/harness/test_runner diff --git a/testsuite/tests/test/top_level_generic_instantiation_private/test.yaml b/testsuite/tests/test/top_level_generic_instantiation_private/test.yaml new file mode 100644 index 00000000..8760fca7 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_instantiation_private/test.yaml @@ -0,0 +1,5 @@ +description: + Check that a warning is emitted when a top level generic package contains + private subprograms. + +driver: shell_script diff --git a/testsuite/tests/test/top_level_generic_lib_item/build.gpr b/testsuite/tests/test/top_level_generic_lib_item/build.gpr new file mode 100644 index 00000000..2e451e4c --- /dev/null +++ b/testsuite/tests/test/top_level_generic_lib_item/build.gpr @@ -0,0 +1,3 @@ +project Build is + for Source_Dirs use ("src"); +end Build; diff --git a/testsuite/tests/test/top_level_generic_lib_item/src/bar.adb b/testsuite/tests/test/top_level_generic_lib_item/src/bar.adb new file mode 100644 index 00000000..ddc231da --- /dev/null +++ b/testsuite/tests/test/top_level_generic_lib_item/src/bar.adb @@ -0,0 +1,9 @@ +package body Bar is + + function Subp_Under_Test + (Test_Data_1 : Integer; + Test_Data_2 : Element_Type; + Test_Data_3 : out Float) + return Bar_Array is ((11 .. 20 => <>)); + +end Bar; diff --git a/testsuite/tests/test/top_level_generic_lib_item/src/bar.ads b/testsuite/tests/test/top_level_generic_lib_item/src/bar.ads new file mode 100644 index 00000000..77926aff --- /dev/null +++ b/testsuite/tests/test/top_level_generic_lib_item/src/bar.ads @@ -0,0 +1,14 @@ +generic + type Element_Type is private; +package Bar is + + type Bar_Range is range 11 .. 20; + type Bar_Array is array (Bar_Range) of Element_Type; + + function Subp_Under_Test + (Test_Data_1 : Integer; + Test_Data_2 : Element_Type; + Test_Data_3 : out Float) + return Bar_Array; + +end Bar; diff --git a/testsuite/tests/test/top_level_generic_lib_item/src/foo.ads b/testsuite/tests/test/top_level_generic_lib_item/src/foo.ads new file mode 100644 index 00000000..c0dc6e99 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_lib_item/src/foo.ads @@ -0,0 +1,11 @@ +with Bar; +generic + type Element_Type is private; +package Foo is + + type Foo_Range is range 1 .. 10; + type Foo_Array is array (Foo_Range) of Element_Type; + + package Foo_Bar is new Bar (Foo_Array); + +end Foo; diff --git a/testsuite/tests/test/top_level_generic_lib_item/src/main_package.ads b/testsuite/tests/test/top_level_generic_lib_item/src/main_package.ads new file mode 100644 index 00000000..109d05f6 --- /dev/null +++ b/testsuite/tests/test/top_level_generic_lib_item/src/main_package.ads @@ -0,0 +1,2 @@ +with Foo; +package Main_Package is new Foo (Natural); diff --git a/testsuite/tests/test/top_level_generic_lib_item/test.out b/testsuite/tests/test/top_level_generic_lib_item/test.out new file mode 100644 index 00000000..76717efc --- /dev/null +++ b/testsuite/tests/test/top_level_generic_lib_item/test.out @@ -0,0 +1,4 @@ +gnattest: Error while processing <| SubpDecl ["Subp_Under_Test"] bar.ads:8:4-12:25 [main_package.ads:2:1, foo.ads:9:4] |>: +main_package.foo_bar.subp_under_test.Test_Data_2: main_package.foo_array is not supported (types declared a generic package instantiation that is a library item are unsupported) + +gnattest: cannot create main suite and test runner diff --git a/testsuite/tests/test/top_level_generic_lib_item/test.sh b/testsuite/tests/test/top_level_generic_lib_item/test.sh new file mode 100644 index 00000000..0272cfaf --- /dev/null +++ b/testsuite/tests/test/top_level_generic_lib_item/test.sh @@ -0,0 +1,2 @@ +gnattest -q -P build.gpr --gen-test-vectors +test $? -eq 1 diff --git a/testsuite/tests/test/top_level_generic_lib_item/test.yaml b/testsuite/tests/test/top_level_generic_lib_item/test.yaml new file mode 100644 index 00000000..68aee1af --- /dev/null +++ b/testsuite/tests/test/top_level_generic_lib_item/test.yaml @@ -0,0 +1,5 @@ +description: | + Check that types that are part of a generic package instantiation and + declared as library items are rejected. + +driver: shell_script