Merge branch 'topic/machu/253-skip-class-wide-types' into 'master'

TGen: Handle class wide return type properly

Closes #253

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

Author: Volham22

src/tgen/tgen-types-translation.adb

@@ -2950,6 +2950,8 @@ package body TGen.Types.Translation is
                     (Translate_Discriminant_Constraints
                       (N.As_Subtype_Indication.F_Constraint
                        .As_Composite_Constraint)),
+                    Is_Class_Wide =>
+                        not Type_Decl_Node.P_Classwide_Type.Is_Null,
                   others => <>));
             end return;
          when others =>
@@ -3042,7 +3044,7 @@ package body TGen.Types.Translation is
       Comp_Unit_Idx : constant Positive :=
         Comp_Unit_Decl.P_Fully_Qualified_Name_Array'Last;
 
-      FQN : constant Ada_Qualified_Name :=
+      FQN : Ada_Qualified_Name :=
         (if not Type_Name.Is_Null
          then Convert_Qualified_Name (Type_Name.P_Fully_Qualified_Name_Array)
          else Ada_Identifier_Vectors.Empty);
@@ -3229,6 +3231,8 @@ package body TGen.Types.Translation is
          Specialized_Res.Res.Get.Fully_Private := Decl_Is_Fully_Private (N);
          Specialized_Res.Res.Get.Private_Extension :=
            Basic_Decl'(N.P_All_Parts (1)).As_Base_Type_Decl.P_Is_Private;
+         Specialized_Res.Res.Get.Is_Class_Wide :=
+            not N.P_Classwide_Type.Is_Null;
       end if;
 
       return Specialized_Res;
@@ -3508,6 +3512,7 @@ package body TGen.Types.Translation is
                if not Ret.Success then
                   return (False, Ret.Diagnostics);
                end if;
+
                F_Typ.Ret_Typ := Ret.Res;
             end;
          else

src/tgen/tgen_rts/tgen-types.adb

@@ -100,19 +100,24 @@ package body TGen.Types is
          (if Top_Level_Generic
           then Generic_Package_Instance_Name (Self.Name)
           else Self.Name);
+
+      function Append_Class_Wide_If_Needed (Type_Name : String) return String
+      is ((if Self.Is_Class_Wide then
+           Type_Name & "'Class"
+           else Type_Name));
    begin
       if not No_Std
         or else not Ada.Strings.Equal_Case_Insensitive
                   (+Unbounded_String (Name.First_Element),
                    "standard")
       then
-         return To_Ada (Name);
+         return Append_Class_Wide_If_Needed (To_Ada (Name));
       end if;
       declare
          Stripped : Ada_Qualified_Name := Name;
       begin
          Stripped.Delete_First;
-         return To_Ada (Stripped);
+         return Append_Class_Wide_If_Needed (To_Ada (Stripped));
       end;
    end FQN;
 

src/tgen/tgen_rts/tgen-types.ads

@@ -66,6 +66,9 @@ package TGen.Types is
       Is_Generic : Boolean := False;
       --  If the type is the result of a generic package instantiation
 
+      Is_Class_Wide : Boolean := False;
+      --  Whether the type is class wide (has `'Class` attribute)
+
    end record
    with Dynamic_Predicate =>
       --  A top level generic instantion is a generic itself (Top_Level_Generic

testsuite/tests/test/253-fix_class_wide_return_type/src/pkg.adb

@@ -0,0 +1,6 @@
+package body Pkg is
+   function Create_Foo (Bar : Integer) return Foo'Class is
+   begin
+      return Foo'(Baz => Bar);
+   end Create_Foo;
+end Pkg;

testsuite/tests/test/253-fix_class_wide_return_type/src/pkg.ads

@@ -0,0 +1,10 @@
+package Pkg is
+   type Foo is tagged private;
+
+private
+   type Foo is tagged record
+      Baz : Integer;
+   end record;
+
+   function Create_Foo (Bar : Integer) return Foo'Class;
+end Pkg;

testsuite/tests/test/253-fix_class_wide_return_type/test.out

@@ -0,0 +1,8 @@
+pkg.ads:9:4: info: corresponding test PASSED
+pkg.ads:9:4: info: corresponding test PASSED
+pkg.ads:9:4: info: corresponding test PASSED
+pkg.ads:9:4: info: corresponding test PASSED
+pkg.ads:9:4: info: corresponding test PASSED
+pkg.ads:9:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:61)
+6 tests run: 5 passed; 1 failed; 0 crashed.
+Test runner dumped 5 tests

testsuite/tests/test/253-fix_class_wide_return_type/test.yaml

@@ -0,0 +1,7 @@
+description: |
+  This test make sure that TGen ignores declaration with class wide return
+  types. Class wide types (`'Class`) are not supported yet.
+
+default-gpr: true
+
+driver: gnattest_tgen