gcc/testsuite/gnat.dg/aggr3.adb

   1 --  { dg-do run }
   2
   3 with Ada.Tags;    use Ada.Tags;
   4 with Ada.Text_IO; use Ada.Text_IO;
   5 procedure aggr3 is
   6    package Pkg is
   7       type Element is interface;
   8       type Event is tagged record
   9          V1 : Natural;
  10          V2 : Natural;
  11       end record;
  12       function Create return Event;
  13       type D_Event is new Event and Element with null record;
  14       function Create return D_Event;
  15    end;
  16    package body Pkg is
  17       function Create return Event is
  18          Obj : Event;
  19       begin
  20          Obj.V1 := 0;
  21          return Obj;
  22       end;
  23       function Create return D_Event is
  24       begin
  25          return (Event'(Create) with null record);
  26       end;
  27    end;
  28    use Pkg;
  29    procedure CW_Test (Obj : Element'Class) is
  30       S : Constant String := Expanded_Name (Obj'Tag);
  31    begin
  32       null;
  33    end;
  34 begin
  35    CW_Test (Create);
  36 end;