From 106791e3b2162398df9ec5264824b53869ca7637 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20Creuse?= Date: Thu, 12 Sep 2024 14:07:49 +0200 Subject: [PATCH] TGen: Reject types from instantiations that are library items The support packages for these types would need to also be generic instanciations, which requires some big overhauls in TGen, so support for those types is disabled at the moment. --- src/tgen/tgen-lal_utils.adb | 6 ++--- src/tgen/tgen-lal_utils.ads | 2 +- src/tgen/tgen-libgen.adb | 3 ++- src/tgen/tgen-types-translation.adb | 26 +++++++++++++++++-- .../tests/test/184-generic-lib-item/gen.ads | 5 ++++ .../tests/test/184-generic-lib-item/inst.ads | 3 +++ .../tests/test/184-generic-lib-item/pkg.ads | 7 +++++ .../tests/test/184-generic-lib-item/test.gpr | 4 +++ .../tests/test/184-generic-lib-item/test.out | 6 +++++ .../tests/test/184-generic-lib-item/test.sh | 1 + .../tests/test/184-generic-lib-item/test.yaml | 7 +++++ 11 files changed, 63 insertions(+), 7 deletions(-) create mode 100644 testsuite/tests/test/184-generic-lib-item/gen.ads create mode 100644 testsuite/tests/test/184-generic-lib-item/inst.ads create mode 100644 testsuite/tests/test/184-generic-lib-item/pkg.ads create mode 100644 testsuite/tests/test/184-generic-lib-item/test.gpr create mode 100644 testsuite/tests/test/184-generic-lib-item/test.out create mode 100644 testsuite/tests/test/184-generic-lib-item/test.sh create mode 100644 testsuite/tests/test/184-generic-lib-item/test.yaml 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)']