gcc/testsuite/gnat.dg/check_displace_generation.adb

   1 -- { dg-do run }
   2 procedure Check_Displace_Generation is
   3
   4    package Stuff is
   5
   6       type Base_1 is interface;
   7       function F_1 (X : Base_1) return Integer is abstract;
   8
   9       type Base_2 is interface;
  10       function F_2 (X : Base_2) return Integer is abstract;
  11
  12       type Concrete is new Base_1 and Base_2 with null record;
  13       function F_1 (X : Concrete) return Integer;
  14       function F_2 (X : Concrete) return Integer;
  15
  16    end Stuff;
  17
  18    package body Stuff is
  19
  20       function F_1 (X : Concrete) return Integer is
  21       begin
  22          return 1;
  23       end F_1;
  24
  25       function F_2 (X : Concrete) return Integer is
  26       begin
  27          return 2;
  28       end F_2;
  29
  30    end Stuff;
  31
  32    use Stuff;
  33
  34    function Make_Concrete return Concrete is
  35       C : Concrete;
  36    begin
  37       return C;
  38    end Make_Concrete;
  39
  40    B_1 : Base_1'Class := Make_Concrete;
  41    B_2 : Base_2'Class := Make_Concrete;
  42
  43 begin
  44    if B_1.F_1 /= 1 then
  45       raise Program_Error with "bad B_1.F_1 call";
  46    end if;
  47    if B_2.F_2 /= 2 then
  48       raise Program_Error with "bad B_2.F_2 call";
  49    end if;
  50 end Check_Displace_Generation;