|
111
|
1 -- C390003.A
|
|
|
2 --
|
|
|
3 -- Grant of Unlimited Rights
|
|
|
4 --
|
|
|
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
|
|
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
|
|
|
7 -- unlimited rights in the software and documentation contained herein.
|
|
|
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
|
|
9 -- this public release, the Government intends to confer upon all
|
|
|
10 -- recipients unlimited rights equal to those held by the Government.
|
|
|
11 -- These rights include rights to use, duplicate, release or disclose the
|
|
|
12 -- released technical data and computer software in whole or in part, in
|
|
|
13 -- any manner and for any purpose whatsoever, and to have or permit others
|
|
|
14 -- to do so.
|
|
|
15 --
|
|
|
16 -- DISCLAIMER
|
|
|
17 --
|
|
|
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
|
|
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
|
|
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
|
|
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
|
|
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
|
|
23 -- PARTICULAR PURPOSE OF SAID MATERIAL.
|
|
|
24 --*
|
|
|
25 --
|
|
|
26 -- OBJECTIVE:
|
|
|
27 -- Check that for a subtype S of a tagged type T, S'Class denotes a
|
|
|
28 -- class-wide subtype. Check that T'Tag denotes the tag of the type T,
|
|
|
29 -- and that, for a class-wide tagged type X, X'Tag denotes the tag of X.
|
|
|
30 -- Check that the tags of stand alone objects, record and array
|
|
|
31 -- components, aggregates, and formal parameters identify their type.
|
|
|
32 -- Check that the tag of a value of a formal parameter is that of the
|
|
|
33 -- actual parameter, even if the actual is passed by a view conversion.
|
|
|
34 --
|
|
|
35 -- TEST DESCRIPTION:
|
|
|
36 -- This test defines a class hierarchy (based on C390002) and
|
|
|
37 -- uses it to determine the correctness of the resulting tag
|
|
|
38 -- information generated by the compiler. A type is defined in the
|
|
|
39 -- class which contains components of the class as part of its
|
|
|
40 -- definition. This is to reduce the overall number of types
|
|
|
41 -- required, and to achieve the required nesting to accomplish
|
|
|
42 -- this test. The model is that of a car carrier truck; both car
|
|
|
43 -- and truck being in the class of Vehicle.
|
|
|
44 --
|
|
|
45 -- Class Hierarchy:
|
|
|
46 -- Vehicle - - - - - - - (Bicycle)
|
|
|
47 -- / | \ / \
|
|
|
48 -- Truck Car Q_Machine Tandem Motorcycle
|
|
|
49 -- |
|
|
|
50 -- Auto_Carrier
|
|
|
51 -- Contains:
|
|
|
52 -- Auto_Carrier( Car )
|
|
|
53 -- Q_Machine( Car, Motorcycle )
|
|
|
54 --
|
|
|
55 --
|
|
|
56 --
|
|
|
57 -- CHANGE HISTORY:
|
|
|
58 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
59 -- 19 Dec 94 SAIC Removed ARM references from objective text.
|
|
|
60 -- 20 Dec 94 SAIC Replaced three unnecessary extension
|
|
|
61 -- aggregates with simple aggregates.
|
|
|
62 -- 16 Oct 95 SAIC Fixed bugs for ACVC 2.0.1
|
|
|
63 --
|
|
|
64 --!
|
|
|
65
|
|
|
66 ----------------------------------------------------------------- C390003_1
|
|
|
67
|
|
|
68 with Ada.Tags;
|
|
|
69 package C390003_1 is -- Vehicle
|
|
|
70
|
|
|
71 type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy);
|
|
|
72 type States is (Good, Flat, Worn);
|
|
|
73
|
|
|
74 type Wheel_List is array(Positive range <>) of States;
|
|
|
75
|
|
|
76 type Object(Wheels: Positive) is tagged record
|
|
|
77 Wheel_State : Wheel_List(1..Wheels);
|
|
|
78 end record;
|
|
|
79
|
|
|
80 procedure TC_Validate( It: Object; Key: TC_Keys );
|
|
|
81 procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag );
|
|
|
82
|
|
|
83 procedure Create( The_Vehicle : in out Object; Tyres : in States );
|
|
|
84 procedure Rotate( The_Vehicle : in out Object );
|
|
|
85 function Wheels( The_Vehicle : Object ) return Positive;
|
|
|
86
|
|
|
87 end C390003_1; -- Vehicle;
|
|
|
88
|
|
|
89 ----------------------------------------------------------------- C390003_2
|
|
|
90
|
|
|
91 with C390003_1;
|
|
|
92 package C390003_2 is -- Motivators
|
|
|
93
|
|
|
94 package Vehicle renames C390003_1;
|
|
|
95 subtype Bicycle is Vehicle.Object(2); -- constrained subtype
|
|
|
96
|
|
|
97 type Motorcycle is new Bicycle with record
|
|
|
98 Displacement : Natural;
|
|
|
99 end record;
|
|
|
100 procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys );
|
|
|
101
|
|
|
102 type Tandem is new Bicycle with null record;
|
|
|
103 procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys );
|
|
|
104
|
|
|
105 type Car is new Vehicle.Object(4) with -- extended, constrained
|
|
|
106 record
|
|
|
107 Displacement : Natural;
|
|
|
108 end record;
|
|
|
109 procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys );
|
|
|
110
|
|
|
111 type Truck is new Vehicle.Object with -- extended, unconstrained
|
|
|
112 record
|
|
|
113 Tare : Natural;
|
|
|
114 end record;
|
|
|
115 procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys );
|
|
|
116
|
|
|
117 end C390003_2; -- Motivators;
|
|
|
118
|
|
|
119 ----------------------------------------------------------------- C390003_3
|
|
|
120
|
|
|
121 with C390003_1;
|
|
|
122 with C390003_2;
|
|
|
123 package C390003_3 is -- Special_Trucks
|
|
|
124 package Vehicle renames C390003_1;
|
|
|
125 package Motivators renames C390003_2;
|
|
|
126 Max_Cars_On_Vehicle : constant := 6;
|
|
|
127 type Cargo_Index is range 0..Max_Cars_On_Vehicle;
|
|
|
128 type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle)
|
|
|
129 of Motivators.Car;
|
|
|
130 type Auto_Carrier is new Motivators.Truck(18) with
|
|
|
131 record
|
|
|
132 Load_Count : Cargo_Index := 0;
|
|
|
133 Payload : Cargo;
|
|
|
134 end record;
|
|
|
135 procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys );
|
|
|
136 procedure Load ( The_Car : in Motivators.Car;
|
|
|
137 Onto : in out Auto_Carrier);
|
|
|
138 procedure Unload( The_Car : out Motivators.Car;
|
|
|
139 Off_of : in out Auto_Carrier);
|
|
|
140 end C390003_3;
|
|
|
141
|
|
|
142 ----------------------------------------------------------------- C390003_4
|
|
|
143
|
|
|
144 with C390003_1;
|
|
|
145 with C390003_2;
|
|
|
146 package C390003_4 is -- James_Bond
|
|
|
147
|
|
|
148 package Vehicle renames C390003_1;
|
|
|
149 package Motivators renames C390003_2;
|
|
|
150
|
|
|
151 type Q_Machine is new Vehicle.Object(4) with record
|
|
|
152 Car_Part : Motivators.Car;
|
|
|
153 Bike_Part : Motivators.Motorcycle;
|
|
|
154 end record;
|
|
|
155 procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys );
|
|
|
156
|
|
|
157 end C390003_4;
|
|
|
158
|
|
|
159 ----------------------------------------------------------------- C390003_1
|
|
|
160
|
|
|
161 with Report;
|
|
|
162 with Ada.Tags;
|
|
|
163 package body C390003_1 is -- Vehicle
|
|
|
164
|
|
|
165 function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
|
|
|
166
|
|
|
167 procedure TC_Validate( It: Object; Key: TC_Keys ) is
|
|
|
168 begin
|
|
|
169 if Key /= Veh then
|
|
|
170 Report.Failed("Expected Veh Key");
|
|
|
171 end if;
|
|
|
172 end TC_Validate;
|
|
|
173
|
|
|
174 procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is
|
|
|
175 begin
|
|
|
176 if It'Tag /= The_Tag then
|
|
|
177 Report.Failed("Unexpected Tag for classwide formal");
|
|
|
178 end if;
|
|
|
179 end TC_Validate;
|
|
|
180
|
|
|
181 procedure Create( The_Vehicle : in out Object; Tyres : in States ) is
|
|
|
182 begin
|
|
|
183 The_Vehicle.Wheel_State := ( others => Tyres );
|
|
|
184 end Create;
|
|
|
185
|
|
|
186 function Wheels( The_Vehicle : Object ) return Positive is
|
|
|
187 begin
|
|
|
188 return The_Vehicle.Wheels;
|
|
|
189 end Wheels;
|
|
|
190
|
|
|
191 procedure Rotate( The_Vehicle : in out Object ) is
|
|
|
192 Push : States;
|
|
|
193 Pulled : States
|
|
|
194 := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last);
|
|
|
195 begin
|
|
|
196 for Finger in
|
|
|
197 The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop
|
|
|
198 Push := The_Vehicle.Wheel_State(Finger);
|
|
|
199 The_Vehicle.Wheel_State(Finger) := Pulled;
|
|
|
200 Pulled := Push;
|
|
|
201 end loop;
|
|
|
202 end Rotate;
|
|
|
203
|
|
|
204 end C390003_1; -- Vehicle;
|
|
|
205
|
|
|
206 ----------------------------------------------------------------- C390003_2
|
|
|
207
|
|
|
208 with Ada.Tags;
|
|
|
209 with Report;
|
|
|
210 package body C390003_2 is -- Motivators
|
|
|
211
|
|
|
212 function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
|
|
|
213 function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
|
|
|
214
|
|
|
215 procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is
|
|
|
216 begin
|
|
|
217 if Key /= Vehicle.MC then
|
|
|
218 Report.Failed("Expected MC Key");
|
|
|
219 end if;
|
|
|
220 end TC_Validate;
|
|
|
221
|
|
|
222 procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is
|
|
|
223 begin
|
|
|
224 if Key /= Vehicle.Tand then
|
|
|
225 Report.Failed("Expected Tand Key");
|
|
|
226 end if;
|
|
|
227 end TC_Validate;
|
|
|
228
|
|
|
229 procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is
|
|
|
230 begin
|
|
|
231 if Key /= Vehicle.Car then
|
|
|
232 Report.Failed("Expected Car Key");
|
|
|
233 end if;
|
|
|
234 end TC_Validate;
|
|
|
235
|
|
|
236 procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is
|
|
|
237 begin
|
|
|
238 if Key /= Vehicle.Truk then
|
|
|
239 Report.Failed("Expected Truk Key");
|
|
|
240 end if;
|
|
|
241 end TC_Validate;
|
|
|
242 end C390003_2; -- Motivators;
|
|
|
243
|
|
|
244 ----------------------------------------------------------------- C390003_3
|
|
|
245
|
|
|
246 with Ada.Tags;
|
|
|
247 with Report;
|
|
|
248 package body C390003_3 is -- Special_Trucks
|
|
|
249
|
|
|
250 function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
|
|
|
251 function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
|
|
|
252
|
|
|
253 procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is
|
|
|
254 begin
|
|
|
255 if Key /= Vehicle.Heavy then
|
|
|
256 Report.Failed("Expected Heavy Key");
|
|
|
257 end if;
|
|
|
258 end TC_Validate;
|
|
|
259
|
|
|
260 procedure Load ( The_Car : in Motivators.Car;
|
|
|
261 Onto : in out Auto_Carrier) is
|
|
|
262 begin
|
|
|
263 Onto.Load_Count := Onto.Load_Count +1;
|
|
|
264 Onto.Payload(Onto.Load_Count) := The_Car;
|
|
|
265 end Load;
|
|
|
266 procedure Unload( The_Car : out Motivators.Car;
|
|
|
267 Off_of : in out Auto_Carrier) is
|
|
|
268 begin
|
|
|
269 The_Car := Off_of.Payload(Off_of.Load_Count);
|
|
|
270 Off_of.Load_Count := Off_of.Load_Count -1;
|
|
|
271 end Unload;
|
|
|
272
|
|
|
273 end C390003_3;
|
|
|
274
|
|
|
275 ----------------------------------------------------------------- C390003_4
|
|
|
276
|
|
|
277 with Report, Ada.Tags;
|
|
|
278 package body C390003_4 is -- James_Bond
|
|
|
279
|
|
|
280 function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."=";
|
|
|
281 function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."=";
|
|
|
282
|
|
|
283 procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is
|
|
|
284 begin
|
|
|
285 if Key /= Vehicle.Q then
|
|
|
286 Report.Failed("Expected Q Key");
|
|
|
287 end if;
|
|
|
288 end TC_Validate;
|
|
|
289
|
|
|
290 end C390003_4;
|
|
|
291
|
|
|
292 ------------------------------------------------------------------- C390003
|
|
|
293
|
|
|
294 with Report;
|
|
|
295 with C390003_1;
|
|
|
296 with C390003_2;
|
|
|
297 with C390003_3;
|
|
|
298 with C390003_4;
|
|
|
299 procedure C390003 is
|
|
|
300
|
|
|
301 package Vehicle renames C390003_1; use Vehicle;
|
|
|
302 package Motivators renames C390003_2;
|
|
|
303 package Special_Trucks renames C390003_3;
|
|
|
304 package James_Bond renames C390003_4;
|
|
|
305
|
|
|
306 -- The cast, in order of complexity:
|
|
|
307
|
|
|
308 Pennys_Bike : Motivators.Bicycle;
|
|
|
309 Weekender : Motivators.Tandem;
|
|
|
310 Qs_Moped : Motivators.Motorcycle;
|
|
|
311 Ms_Limo : Motivators.Car;
|
|
|
312 Yard_Van : Motivators.Truck(8);
|
|
|
313 Specter_X : Special_Trucks.Auto_Carrier;
|
|
|
314 Gen_II : James_Bond.Q_Machine;
|
|
|
315
|
|
|
316
|
|
|
317 -- Check compatibility with the corresponding class wide type.
|
|
|
318
|
|
|
319 procedure Vehicle_Shop( It : in out Vehicle.Object'Class;
|
|
|
320 Key : in Vehicle.TC_Keys ) is
|
|
|
321
|
|
|
322 -- Check that Subtype'Class is defined for tagged subtypes.
|
|
|
323 procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is
|
|
|
324 begin
|
|
|
325 -- Dispatch to appropriate TC_Validate
|
|
|
326 Vehicle.TC_Validate( Bike, Key );
|
|
|
327 end Bike_Shop;
|
|
|
328
|
|
|
329 begin
|
|
|
330 Vehicle.TC_Validate( It, Key );
|
|
|
331 if Vehicle.Wheels( It ) = 2 then
|
|
|
332 Bike_Shop( It ); -- only call Bike_Shop when It has 2 wheels
|
|
|
333 end if;
|
|
|
334 end Vehicle_Shop;
|
|
|
335
|
|
|
336 begin -- Main test procedure.
|
|
|
337
|
|
|
338 Report.Test ("C390003", "Check that for a subtype S of a tagged type " &
|
|
|
339 "T, S'Class denotes a class-wide subtype. Check that " &
|
|
|
340 "T'Tag denotes the tag of the type T, and that, for a " &
|
|
|
341 "class-wide tagged type X, X'Tag denotes the tag of X. " &
|
|
|
342 "Check that the tags of stand alone objects, record and " &
|
|
|
343 "array components, aggregates, and formal parameters " &
|
|
|
344 "identify their type. Check that the tag of a value of a " &
|
|
|
345 "formal parameter is that of the actual parameter, even " &
|
|
|
346 "if the actual is passed by a view conversion" );
|
|
|
347
|
|
|
348 -- Check that the tags of stand alone objects, record and array
|
|
|
349 -- components, aggregates, and formal parameters identify their type.
|
|
|
350 -- Check that the tag of a value of a formal parameter is that of the
|
|
|
351 -- actual parameter, even if the actual is passed by a view conversion.
|
|
|
352
|
|
|
353 Vehicle_Shop( Pennys_Bike, Veh );
|
|
|
354 Vehicle_Shop( Weekender, Tand );
|
|
|
355 Vehicle_Shop( Qs_Moped, MC );
|
|
|
356 Vehicle_Shop( Ms_Limo, Car );
|
|
|
357 Vehicle_Shop( Yard_Van, Truk );
|
|
|
358 Vehicle_Shop( Specter_X, Heavy );
|
|
|
359 Vehicle_Shop( Specter_X.Payload(1), Car );
|
|
|
360 Vehicle_Shop( Gen_II, Q );
|
|
|
361 Vehicle_Shop( Gen_II.Car_Part, Car );
|
|
|
362 Vehicle_Shop( Gen_II.Bike_Part, MC );
|
|
|
363
|
|
|
364 Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag );
|
|
|
365 Vehicle.TC_Validate( Weekender, Motivators.Tandem'Tag );
|
|
|
366 Vehicle.TC_Validate( Qs_Moped, Motivators.Motorcycle'Tag );
|
|
|
367 Vehicle.TC_Validate( Ms_Limo, Motivators.Car'Tag );
|
|
|
368 Vehicle.TC_Validate( Yard_Van, Motivators.Truck'Tag );
|
|
|
369 Vehicle.TC_Validate( Specter_X, Special_Trucks.Auto_Carrier'Tag );
|
|
|
370 Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag );
|
|
|
371 Vehicle.TC_Validate( Gen_II, James_Bond.Q_Machine'Tag );
|
|
|
372 Vehicle.TC_Validate( Gen_II.Car_Part, Motivators.Car'Tag );
|
|
|
373 Vehicle.TC_Validate( Gen_II.Bike_Part, Motivators.Motorcycle'Tag );
|
|
|
374
|
|
|
375 -- Check the tag generated for an aggregate.
|
|
|
376
|
|
|
377 Rentals: declare
|
|
|
378 Mikes_Rental : Vehicle.Object'Class :=
|
|
|
379 Vehicle.Object'( 3, (Good, Flat, Worn));
|
|
|
380 Diannes_Car : Vehicle.Object'Class :=
|
|
|
381 Motivators.Tandem'( Wheels => 2,
|
|
|
382 Wheel_State => (Good, Good) );
|
|
|
383 Jims_Bike : Vehicle.Object'Class :=
|
|
|
384 Motivators.Motorcycle'( Pennys_Bike
|
|
|
385 with Displacement => 350 );
|
|
|
386 Bills_Limo : Vehicle.Object'Class :=
|
|
|
387 Motivators.Car'( Wheels => 4,
|
|
|
388 Wheel_State => (others => Good),
|
|
|
389 Displacement => 282 );
|
|
|
390 Alans_Car : Vehicle.Object'Class :=
|
|
|
391 Motivators.Truck'( 18, (others => Worn),
|
|
|
392 Tare => 5_500 );
|
|
|
393 Pats_Truck : Vehicle.Object'Class := Specter_X;
|
|
|
394 Keiths_Car : Vehicle.Object'Class := Gen_II;
|
|
|
395 Isaacs_Bus : Vehicle.Object'Class := Keiths_Car;
|
|
|
396
|
|
|
397 begin
|
|
|
398 Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag );
|
|
|
399 Vehicle.TC_Validate( Diannes_Car, Motivators.Tandem'Tag );
|
|
|
400 Vehicle.TC_Validate( Jims_Bike, Motivators.Motorcycle'Tag );
|
|
|
401 Vehicle.TC_Validate( Bills_Limo, Motivators.Car'Tag );
|
|
|
402 Vehicle.TC_Validate( Alans_Car, Motivators.Truck'Tag );
|
|
|
403 Vehicle.TC_Validate( Pats_Truck, Special_Trucks.Auto_Carrier'Tag );
|
|
|
404 Vehicle.TC_Validate( Keiths_Car, James_Bond.Q_Machine'Tag );
|
|
|
405 end Rentals;
|
|
|
406
|
|
|
407 -- Check the tag of parameters.
|
|
|
408 -- Check that the tag is not affected by view conversion.
|
|
|
409
|
|
|
410 Vehicle.TC_Validate( Vehicle.Object( Gen_II ), James_Bond.Q_Machine'Tag );
|
|
|
411 Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag );
|
|
|
412 Vehicle.TC_Validate( Motivators.Bicycle( Weekender ),
|
|
|
413 Motivators.Tandem'Tag );
|
|
|
414 Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ),
|
|
|
415 Motivators.Motorcycle'Tag );
|
|
|
416
|
|
|
417 Report.Result;
|
|
|
418
|
|
|
419 end C390003;
|
