diff --git a/src/tgen/tgen-lal_utils.adb b/src/tgen/tgen-lal_utils.adb index 1b6fc521..ecd3d4a8 100644 --- a/src/tgen/tgen-lal_utils.adb +++ b/src/tgen/tgen-lal_utils.adb @@ -129,15 +129,15 @@ package body TGen.LAL_Utils is ----------------------------------------- function Ultimate_Enclosing_Compilation_Unit - (Subp : LAL.Basic_Decl'Class) return LAL.Unbounded_Text_Type_Array + (Subp : LAL.Basic_Decl'Class) return LAL.Basic_Decl is Instantiation_Chain : constant LAL.Generic_Instantiation_Array := Subp.P_Generic_Instantiations; - Res : constant LAL.Unbounded_Text_Type_Array := + Res : constant LAL.Basic_Decl := LAL.P_Enclosing_Compilation_Unit (if Instantiation_Chain'Length > 0 then Instantiation_Chain (Instantiation_Chain'Last) - else Subp).P_Decl.P_Fully_Qualified_Name_Array; + else Subp).P_Decl; begin return Res; end Ultimate_Enclosing_Compilation_Unit; diff --git a/src/tgen/tgen-lal_utils.ads b/src/tgen/tgen-lal_utils.ads index 20548a66..14294de3 100644 --- a/src/tgen/tgen-lal_utils.ads +++ b/src/tgen/tgen-lal_utils.ads @@ -73,7 +73,7 @@ package TGen.LAL_Utils is -- same subprogram. function Ultimate_Enclosing_Compilation_Unit - (Subp : LAL.Basic_Decl'Class) return LAL.Unbounded_Text_Type_Array; + (Subp : LAL.Basic_Decl'Class) return LAL.Basic_Decl; -- Return the ultimate enclosing compilation unit, going up the -- instantiation chains if the given Subp is a generic instantiation. -- diff --git a/src/tgen/tgen-libgen.adb b/src/tgen/tgen-libgen.adb index 21789389..c64a6685 100644 --- a/src/tgen/tgen-libgen.adb +++ b/src/tgen/tgen-libgen.adb @@ -688,7 +688,8 @@ package body TGen.Libgen is Unit_Name : constant Ada_Qualified_Name := TGen.LAL_Utils.Convert_Qualified_Name - (TGen.LAL_Utils.Ultimate_Enclosing_Compilation_Unit (Subp)); + (TGen.LAL_Utils.Ultimate_Enclosing_Compilation_Unit (Subp) + .P_Fully_Qualified_Name_Array); -- Name of the compilation unit this subprogram belongs to. Support_Packs : Cursor := Ctx.Support_Packs_Per_Unit.Find (Unit_Name); diff --git a/src/tgen/tgen-types-translation.adb b/src/tgen/tgen-types-translation.adb index 837ab7e4..2c9485b6 100644 --- a/src/tgen/tgen-types-translation.adb +++ b/src/tgen/tgen-types-translation.adb @@ -3013,8 +3013,11 @@ package body TGen.Types.Translation is then N.P_Defining_Name else No_Defining_Name); + Comp_Unit_Decl : constant Basic_Decl := + Ultimate_Enclosing_Compilation_Unit (N.As_Basic_Decl); + Comp_Unit_Idx : constant Positive := - Ultimate_Enclosing_Compilation_Unit (LAL.Basic_Decl'Class (N))'Last; + Comp_Unit_Decl.P_Fully_Qualified_Name_Array'Last; FQN : constant Ada_Qualified_Name := (if not Type_Name.Is_Null @@ -3049,6 +3052,24 @@ package body TGen.Types.Translation is (Reason => To_Unbounded_String ("Anonymous array or access type unsupported"), others => <>)); + + -- Types that are declared in a library level generic instantiation are + -- not supported at the moment, as the support packages would need to be + -- generic instances themselves (with other rules to follow), see + -- RM 10.1.1 (17/3, 18). + -- + -- TODO??? Investigate if there are issues in generating the helper + -- packages as non-child units in this case, see #184. + + elsif Comp_Unit_Decl.Kind in Ada_Generic_Instantiation then + Specialized_Res := (Success => True, others => <>); + Specialized_Res.Res.Set + (Unsupported_Typ' + (Reason => To_Unbounded_String + ("types declared a generic package instantiation that is a" + & " library item are unsupported"), + others => <>)); + elsif Text.Image (N.P_Root_Type.P_Fully_Qualified_Name) = "System.Address" then @@ -3387,7 +3408,8 @@ package body TGen.Types.Translation is F_Typ_Ref : SP.Ref; Result : Translation_Result (Success => True); Comp_Unit_Idx : constant Positive := - Ultimate_Enclosing_Compilation_Unit (N)'Last; + Ultimate_Enclosing_Compilation_Unit (N) + .P_Fully_Qualified_Name_Array'Last; UID : constant String := Test.Common.Mangle_Hash_16 (Subp => N); diff --git a/testsuite/tests/test/184-generic-lib-item/gen.ads b/testsuite/tests/test/184-generic-lib-item/gen.ads new file mode 100644 index 00000000..b52afa8b --- /dev/null +++ b/testsuite/tests/test/184-generic-lib-item/gen.ads @@ -0,0 +1,5 @@ +generic + type T is (<>); +package Gen is + type Pair is array (1 .. 2) of T; +end Gen; diff --git a/testsuite/tests/test/184-generic-lib-item/inst.ads b/testsuite/tests/test/184-generic-lib-item/inst.ads new file mode 100644 index 00000000..5a9ba760 --- /dev/null +++ b/testsuite/tests/test/184-generic-lib-item/inst.ads @@ -0,0 +1,3 @@ +with Gen; + +package Inst is new Gen (Integer); diff --git a/testsuite/tests/test/184-generic-lib-item/pkg.ads b/testsuite/tests/test/184-generic-lib-item/pkg.ads new file mode 100644 index 00000000..7a69a0d8 --- /dev/null +++ b/testsuite/tests/test/184-generic-lib-item/pkg.ads @@ -0,0 +1,7 @@ +with Inst; + +package Pkg is + + function Identity (X : Inst.Pair) return Inst.Pair is (X); + +end Pkg; diff --git a/testsuite/tests/test/184-generic-lib-item/test.gpr b/testsuite/tests/test/184-generic-lib-item/test.gpr new file mode 100644 index 00000000..419e6c6c --- /dev/null +++ b/testsuite/tests/test/184-generic-lib-item/test.gpr @@ -0,0 +1,4 @@ +project Test is + for Source_Dirs use ("."); + for Object_Dir use "obj"; +end Test; diff --git a/testsuite/tests/test/184-generic-lib-item/test.out b/testsuite/tests/test/184-generic-lib-item/test.out new file mode 100644 index 00000000..4e11fe32 --- /dev/null +++ b/testsuite/tests/test/184-generic-lib-item/test.out @@ -0,0 +1,6 @@ +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 diff --git a/testsuite/tests/test/184-generic-lib-item/test.sh b/testsuite/tests/test/184-generic-lib-item/test.sh new file mode 100644 index 00000000..af9a1e52 --- /dev/null +++ b/testsuite/tests/test/184-generic-lib-item/test.sh @@ -0,0 +1 @@ +gnattest -P test.gpr --gen-test-vectors diff --git a/testsuite/tests/test/184-generic-lib-item/test.yaml b/testsuite/tests/test/184-generic-lib-item/test.yaml new file mode 100644 index 00000000..5417ab3a --- /dev/null +++ b/testsuite/tests/test/184-generic-lib-item/test.yaml @@ -0,0 +1,7 @@ +description: + Check that TGen properly rejects types declared in generic instantiations + that are library items. + +driver: shell_script +control: + - [XFAIL, 'x86', 'Marshalling not working for 32bits (UB03-008)']