gcc/testsuite/gnat.dg/discr4.adb

   1 --  { dg-do run }
   2 --  { dg-options "-gnatws" }
   3
   4 procedure discr4 is
   5    package Pkg is
   6       type Rec_Comp (D : access Integer) is record
   7          Data : Integer;
   8       end record;
   9 --
  10       type I is interface;
  11       procedure Test (Obj : I) is abstract;
  12 --
  13       Num : aliased Integer := 10;
  14 --
  15       type Root (D : access Integer) is tagged record
  16          C1 : Rec_Comp (D);           --  test
  17       end record;
  18 --
  19       type DT is new Root and I with null record;
  20 --
  21       procedure Dummy (Obj : DT);
  22       procedure Test  (Obj : DT);
  23    end;
  24 --
  25    package body Pkg is
  26       procedure Dummy (Obj : DT) is
  27       begin
  28          raise Program_Error;
  29       end;
  30 --
  31       procedure Test (Obj : DT) is
  32       begin
  33          null;
  34       end;
  35    end;
  36 --
  37    use Pkg;
  38 --
  39    procedure CW_Test (Obj : I'Class) is
  40    begin
  41       Obj.Test;
  42    end;
  43 --
  44    Obj : DT (Num'Access);
  45 begin
  46    CW_Test (Obj);
  47 end;