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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155 | with Ada.Text_IO;
package body Tagged_Subprogram_Calls is
package body Inner is
procedure P(A : E) is
begin
null;
end P;
end Inner;
procedure Test(Param : Inner.E) is
type F is new Inner.E range Param .. Inner.C;
O : F := B;
Q : Inner.E := Inner.B;
begin
P(O);
Inner.P(Q);
end Test;
procedure Test2 is
A : T;
B : T1 := (I => 42);
C : T'Class := A;
D : T'Class := B;
E : T1'Class := B;
F : T'Class := T_F(D);
begin
T_P(A);
T_P(B);
T_P(C);
T_P(D);
T_P(E);
T_Q(42, A);
T_Q(42, B);
T_Q(42, C);
T_Q(42, D);
T_Q(42, E);
A.T_P;
B.T_P;
C.T_P;
D.T_P;
E.T_P;
A.T_R(42);
B.T_R(42);
C.T_R(42);
D.T_R(42);
E.T_R(42);
D.T_F.T_P;
B.T_F.T_P;
D.T_F.T_R(42);
B.T_F.T_R(42);
D.T_G.T_R(42); -- D.T_G should yield class wide type, but doesn't
B.T_G.T_R(42);
if +D then
null;
end if;
end Test2;
procedure T_P(S : T) is null;
procedure T_P(S : T1) is null;
procedure T_P(S : T2) is null;
procedure T_Q(J : Integer; S : T) is null;
procedure T_Q(J : Integer; S : T1) is null;
procedure T_R(S : T; J : Integer) is
begin
Ada.Text_IO.Put_Line("T");
end T_R;
procedure T_R(S : T1; J : Integer) is
begin
Ada.Text_IO.Put_Line("T1");
end T_R;
procedure Test3 is
O1 : S1;
O2 : S'Class := O1;
O3 : I'Class := O1;
begin
O1.S_P;
O2.S_P;
O1.S_I;
O3.S_I;
end Test3;
procedure S_I(A : I1) is
begin
null;
end S_I;
procedure S_P(A : S1) is
begin
Ada.Text_IO.Put_Line("S1");
end S_P;
procedure S_I(A : S1) is
begin
Ada.Text_IO.Put_Line("S1");
end S_I;
procedure S_P(A : S2) is
begin
Ada.Text_IO.Put_Line("S2");
end S_P;
procedure S_I(A : S2) is
begin
Ada.Text_IO.Put_Line("S2");
end S_I;
procedure GP1(I : TP'Class) is
begin
PP(I);
end GP1;
procedure GPI is new GP1(TP => S, PP => S_P);
procedure GP2(I : TP'Class) is
procedure GPI is new GP1(TP => TP, PP => PP);
begin
null;
end GP2;
task body TI is
begin
accept E;
end TI;
task body TIT is
begin
accept E;
end TIT;
protected body PI is
entry E when True is
begin
null;
end E;
end PI;
protected body PIT is
entry E when True is
begin
null;
end E;
end PIT;
end Tagged_Subprogram_Calls;
|