Merge branch 'leo_cr/184-tl_generci_insts' into 'master'

TGen: Reject types from instantiations that are library items

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

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;

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.
    --

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);

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);

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;

testsuite/tests/test/184-generic-lib-item/inst.ads

@@ -0,0 +1,3 @@
+with Gen;
+
+package Inst is new Gen (Integer);

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;

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;

testsuite/tests/test/184-generic-lib-item/test.out

@@ -0,0 +1,6 @@
+gnattest: Error while processing <ExprFunction ["Identity"] pkg.ads:5:4-5:62>:
+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     

testsuite/tests/test/184-generic-lib-item/test.sh

@@ -0,0 +1 @@
+gnattest -P test.gpr --gen-test-vectors

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)']