gcc/testsuite/gnat.dg/test_iface_aggr.adb

   1 --  { dg-do run }
   2
   3 with Ada.Text_IO, Ada.Tags;
   4 procedure Test_Iface_Aggr is
   5    package Pkg is
   6      type Iface is interface;
   7      function Constructor (S: Iface) return Iface'Class is abstract;
   8      procedure Do_Test (It : Iface'class);
   9      type Root is abstract tagged record
  10         Comp_1 : Natural := 0;
  11      end record;
  12      type DT_1 is new Root and Iface with record
  13          Comp_2, Comp_3 : Natural := 0;
  14      end record;
  15      function Constructor (S: DT_1) return Iface'Class;
  16      type DT_2 is new DT_1 with null record;  --  Test
  17      function Constructor (S: DT_2) return Iface'Class;
  18    end;
  19    package body Pkg is
  20       procedure Do_Test (It: in Iface'Class) is
  21          Obj : Iface'Class := Constructor (It);
  22          S   : String := Ada.Tags.External_Tag (Obj'Tag);
  23       begin
  24          null;
  25       end;
  26      function Constructor (S: DT_1) return Iface'Class is
  27      begin
  28        return Iface'Class(DT_1'(others => <>));
  29      end;
  30      function Constructor (S: DT_2) return Iface'Class is
  31        Result : DT_2;
  32      begin
  33        return Iface'Class(DT_2'(others => <>));    --  Test
  34      end;
  35    end;
  36    use Pkg;
  37    Obj: DT_2;
  38 begin
  39    Do_Test (Obj);
  40 end;