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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
|
-- C392D03.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that, for an inherited dispatching operation that is overridden,
-- the body executed is the body of the overriding subprogram, even if
-- the overriding occurs in a private part.
--
-- Check for the case where the overriding operation is declared in a
-- separate (non-child) package from that declaring the parent type, and
-- the descendant type is a record extension.
--
-- Check for both dispatching and nondispatching calls.
--
-- TEST DESCRIPTION:
-- Consider:
--
-- package P is
-- type Root is tagged ...
-- procedure Op (A: Root);
-- end P;
--
-- with P;
-- package Q is
-- type Derived1 is new P.Root with record...
-- -- Implicit procedure Op (A: Derived1) declared here.
-- type Derived2 is new P.Root with private...
-- -- Implicit procedure Op (A: Derived2) declared here.
-- type New_Derived is new Derived1 with private...
-- -- Implicit procedure Op (A: New_Derived) declared here.
-- private
-- procedure Op (A: Derived1); -- Overrides parent's Op.
-- type Derived2 is new P.Root with record...
-- procedure Op (A: Derived2); -- Overrides parent's Op.
-- type New_Derived is new Derived1 with record...
-- ...
-- end Q;
--
-- Both type Derived1 and Derived2 inherit Op from the parent type Root.
-- Type New_Derived inherits (inherited) Op from Derived1. The inherited
-- operation is implicitly declared immediately after the type extension.
-- The inherited operation is overridden by an explicit declaration in
-- the private part. Even though the overriding operation is private,
-- calls to Op with an operand of tag Derived1, Derived2, or New_Derived
-- will execute the body of the overriding operation.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- F392D00.A
-- C392D03.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
with F392D00;
package C392D03_0 is
type Aperture is (Eight, Sixteen);
type Auto_Focus is new F392D00.Remote_Camera with record
-- ...
FStop : Aperture;
end record;
-- Implicit procedure Focus (C : in out Auto_Focus;
-- Depth : in Depth_Of_Field) declared here.
type Auto_Flashing is new F392D00.Remote_Camera with private;
-- Implicit procedure Focus (C : in out Auto_Flashing;
-- Depth : in Depth_Of_Field) declared here.
type Special_Focus is new Auto_Focus with private;
-- Implicit procedure Focus (C : in out Special_Focus;
-- Depth : in Depth_Of_Field) declared here.
-- ...Other operations.
private
procedure Focus (C : in out Auto_Focus; -- Overrides
Depth : in F392D00.Depth_Of_Field); -- parent's op.
-- For the improved remote camera, focus is set automatically, so it is
-- declared as a private operation.
type Auto_Flashing is new F392D00.Remote_Camera with null record;
procedure Focus (C : in out Auto_Flashing; -- Overrides
Depth : in F392D00.Depth_Of_Field); -- parent's op.
type Special_Focus is new Auto_Focus with null record;
end C392D03_0;
--==================================================================--
package body C392D03_0 is
procedure Focus (C : in out Auto_Focus;
Depth : in F392D00.Depth_Of_Field) is
begin
-- Artificial for testing purposes.
C.DOF := 52;
end Focus;
-----------------------------------------------------------
procedure Focus (C : in out Auto_Flashing;
Depth : in F392D00.Depth_Of_Field) is
begin
-- Artificial for testing purposes.
C.DOF := 91;
end Focus;
end C392D03_0;
--==================================================================--
with F392D00;
with C392D03_0;
with Report;
procedure C392D03 is
type Focus_Ptr is access procedure
(P1 : in out C392D03_0.Auto_Focus;
P2 : in F392D00.Depth_Of_Field);
Basic_Camera : F392D00.Remote_Camera;
Auto_Camera1 : C392D03_0.Auto_Focus;
Auto_Camera2 : C392D03_0.Auto_Focus;
Flash_Camera1 : C392D03_0.Auto_Flashing;
Flash_Camera2 : C392D03_0.Auto_Flashing;
Special_Camera : C392D03_0.Special_Focus;
Auto_Depth : F392D00.Depth_Of_Field := 78;
TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46;
TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52;
TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91;
FP : Focus_Ptr := C392D03_0.Focus'Access;
use type F392D00.Depth_Of_Field;
begin
Report.Test ("C392D03", "Dispatching for overridden primitive " &
"subprograms: record extension declared in non-child " &
"package, parent is tagged record");
-- Call the class-wide operation for Remote_Camera'Class, which itself makes
-- a dispatching call to Focus:
-- For an object of type Remote_Camera, the dispatching call should
-- dispatch to the body declared for the root type:
F392D00.Self_Test(Basic_Camera);
if Basic_Camera.DOF /= TC_Expected_Basic_Depth then
Report.Failed ("Call dispatched incorrectly for root type");
end if;
-- For an object of type Auto_Focus, the dispatching call should
-- dispatch to the body declared for the derived type:
F392D00.Self_Test(Auto_Camera1);
if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then
Report.Failed ("Call dispatched incorrectly for Auto_Focus type");
end if;
-- For an object of type Auto_Flash, the dispatching call should
-- also dispatch to the body declared for the derived type:
F392D00.Self_Test(Flash_Camera1);
if Flash_Camera1.DOF /= TC_Expected_Depth then
Report.Failed ("Call dispatched incorrectly for Auto_Flash type");
end if;
-- For an object of Auto_Flash type, a non-dispatching call to Focus should
-- execute the body declared for the derived type (even through it is
-- declared in the private part).
C392D03_0.Focus (Flash_Camera2, Auto_Depth);
if Flash_Camera2.DOF /= TC_Expected_Depth then
Report.Failed ("Non-dispatching call to privately overriding " &
"subprogram executed the wrong body");
end if;
-- For an object of Auto_Focus type, a non-dispatching call to Focus should
-- execute the body declared for the derived type (even through it is
-- declared in the private part).
FP.all (Auto_Camera2, Auto_Depth);
if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then
Report.Failed ("Non-dispatching call by using access to overriding " &
"subprogram executed the wrong body");
end if;
-- For an object of type Special_Camera, the dispatching call should
-- also dispatch to the body declared for the derived type:
F392D00.Self_Test(Special_Camera);
if Special_Camera.DOF /= TC_Expected_Auto_Depth then
Report.Failed ("Call dispatched incorrectly for Special_Camera type");
end if;
Report.Result;
end C392D03;
|
