1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
|
-- { dg-do compile }
-- { dg-require-effective-target strub }
-- Check that strub mode mismatches between overrider and overridden
-- subprograms are reported even when the overriders for an
-- interface's subprograms are inherited from a type that is not a
-- descendent of the interface.
procedure Strub_Intf2 is
package Foo is
type A is tagged null record;
procedure P (I : Integer; X : A);
pragma Machine_Attribute (P, "strub", "at-calls"); -- { dg-error "requires the same .strub. mode" }
function F (X : access A) return Integer;
type TX is Interface;
procedure P (I : Integer; X : TX) is abstract;
function F (X : access TX) return Integer is abstract;
pragma Machine_Attribute (F, "strub", "at-calls");
type B is new A and TX with null record; -- { dg-error "requires the same .strub. mode" }
end Foo;
package body Foo is
procedure P (I : Integer; X : A) is
begin
null;
end;
function F (X : access A) return Integer is (0);
end Foo;
use Foo;
procedure Q (X : TX'Class) is
begin
P (-1, X);
end;
XB : aliased B;
I : Integer := 0;
XC : access TX'Class;
begin
Q (XB);
I := I + F (XB'Access);
XC := XB'Access;
I := I + F (XC);
end Strub_Intf2;
|
