1-- { dg-do run }
2procedure 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
43begin
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;
50end Check_Displace_Generation;
51