3 -- Grant of Unlimited Rights
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
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.
27 -- Check that the tags of allocated objects correctly identify the
28 -- type of the allocated object. Check that the tag corresponds
29 -- correctly to the value resulting from both normal and view
30 -- conversion. Check that the tags of accessed values designating
31 -- aliased objects correctly identify the type of the object. Check
32 -- that the tag of a function result correctly evaluates. Check this
33 -- for class-wide functions. The tag of a class-wide function result
34 -- should be the tag appropriate to the actual value returned, not the
35 -- tag of the ancestor type.
38 -- This test defines a class hierarchy of types, with reference
39 -- semantics (an access type to the class-wide type). Similar in
40 -- structure to C392005, this test checks that dynamic allocation does
41 -- not adversely impact the tagging of types.
45 -- 06 Dec 94 SAIC ACVC 2.0
49 package C390004_1
is -- DMV
50 type Equipment
is ( T_Veh
, T_Car
, T_Con
, T_Jep
);
52 type Vehicle
is tagged record
53 Wheels
: Natural := 4;
54 Parked
: Boolean := False;
57 function Wheels
( It
: Vehicle
) return Natural;
58 procedure Park
( It
: in out Vehicle
);
59 procedure UnPark
( It
: in out Vehicle
);
60 procedure Set_Wheels
( It
: in out Vehicle
; To_Count
: in Natural );
61 procedure TC_Check
( It
: in Vehicle
; To_Equip
: in Equipment
);
63 type Car
is new Vehicle
with record
64 Passengers
: Natural := 0;
67 function Passengers
( It
: Car
) return Natural;
68 procedure Load_Passengers
( It
: in out Car
; To_Count
: in Natural );
69 procedure Park
( It
: in out Car
);
70 procedure TC_Check
( It
: in Car
; To_Equip
: in Equipment
);
72 type Convertible
is new Car
with record
73 Top_Up
: Boolean := True;
76 function Top_Up
( It
: Convertible
) return Boolean;
77 procedure Lower_Top
( It
: in out Convertible
);
78 procedure Park
( It
: in out Convertible
);
79 procedure Raise_Top
( It
: in out Convertible
);
80 procedure TC_Check
( It
: in Convertible
; To_Equip
: in Equipment
);
82 type Jeep
is new Convertible
with record
83 Windshield_Up
: Boolean := True;
86 function Windshield_Up
( It
: Jeep
) return Boolean;
87 procedure Lower_Windshield
( It
: in out Jeep
);
88 procedure Park
( It
: in out Jeep
);
89 procedure Raise_Windshield
( It
: in out Jeep
);
90 procedure TC_Check
( It
: in Jeep
; To_Equip
: in Equipment
);
95 package body C390004_1
is
97 procedure Set_Wheels
( It
: in out Vehicle
; To_Count
: in Natural ) is
99 It
.Wheels
:= To_Count
;
102 function Wheels
( It
: Vehicle
) return Natural is
107 procedure Park
( It
: in out Vehicle
) is
112 procedure UnPark
( It
: in out Vehicle
) is
117 procedure TC_Check
( It
: in Vehicle
; To_Equip
: in Equipment
) is
119 if To_Equip
/= T_Veh
then
120 Report
.Failed
("Failed, called Vehicle for "
121 & Equipment
'Image(To_Equip
));
125 procedure TC_Check
( It
: in Car
; To_Equip
: in Equipment
) is
127 if To_Equip
/= T_Car
then
128 Report
.Failed
("Failed, called Car for "
129 & Equipment
'Image(To_Equip
));
133 procedure TC_Check
( It
: in Convertible
; To_Equip
: in Equipment
) is
135 if To_Equip
/= T_Con
then
136 Report
.Failed
("Failed, called Convertible for "
137 & Equipment
'Image(To_Equip
));
141 procedure TC_Check
( It
: in Jeep
; To_Equip
: in Equipment
) is
143 if To_Equip
/= T_Jep
then
144 Report
.Failed
("Failed, called Jeep for "
145 & Equipment
'Image(To_Equip
));
149 procedure Load_Passengers
( It
: in out Car
; To_Count
: in Natural ) is
151 It
.Passengers
:= To_Count
;
155 procedure Park
( It
: in out Car
) is
158 Park
( Vehicle
( It
) );
161 function Passengers
( It
: Car
) return Natural is
163 return It
.Passengers
;
166 procedure Raise_Top
( It
: in out Convertible
) is
171 procedure Lower_Top
( It
: in out Convertible
) is
176 function Top_Up
( It
: Convertible
) return Boolean is
181 procedure Park
( It
: in out Convertible
) is
187 procedure Raise_Windshield
( It
: in out Jeep
) is
189 It
.Windshield_Up
:= True;
190 end Raise_Windshield
;
192 procedure Lower_Windshield
( It
: in out Jeep
) is
194 It
.Windshield_Up
:= False;
195 end Lower_Windshield
;
197 function Windshield_Up
( It
: Jeep
) return Boolean is
199 return It
.Windshield_Up
;
202 procedure Park
( It
: in out Jeep
) is
204 It
.Windshield_Up
:= True;
205 Park
( Convertible
( It
) );
213 package DMV
renames C390004_1
;
215 The_Vehicle
: aliased DMV
.Vehicle
;
216 The_Car
: aliased DMV
.Car
;
217 The_Convertible
: aliased DMV
.Convertible
;
218 The_Jeep
: aliased DMV
.Jeep
;
220 type C_Reference
is access all DMV
.Car
'Class;
221 type V_Reference
is access all DMV
.Vehicle
'Class;
223 Designator
: V_Reference
;
226 procedure Valet
( It
: in out DMV
.Vehicle
'Class ) is
231 procedure TC_Match
( Object
: DMV
.Vehicle
'Class;
232 Taglet
: Ada
.Tags
.Tag
;
236 if Object
'Tag /= Taglet
then
237 Report
.Failed
("Tag mismatch: " & Where
);
241 procedure Parking_Validation
( It
: DMV
.Vehicle
; TC_Message
: String ) is
243 if DMV
.Wheels
( It
) /= 1 or not It
.Parked
then
244 Report
.Failed
("Failed Vehicle " & TC_Message
);
246 end Parking_Validation
;
248 procedure Parking_Validation
( It
: DMV
.Car
; TC_Message
: String ) is
250 if DMV
.Wheels
( It
) /= 2 or DMV
.Passengers
( It
) /= 0
251 or not It
.Parked
then
252 Report
.Failed
("Failed Car " & TC_Message
);
254 end Parking_Validation
;
256 procedure Parking_Validation
( It
: DMV
.Convertible
;
257 TC_Message
: String ) is
259 if DMV
.Wheels
( It
) /= 3 or DMV
.Passengers
( It
) /= 0
260 or not DMV
.Top_Up
( It
) or not It
.Parked
then
261 Report
.Failed
("Failed Convertible " & TC_Message
);
263 end Parking_Validation
;
265 procedure Parking_Validation
( It
: DMV
.Jeep
; TC_Message
: String ) is
267 if DMV
.Wheels
( It
) /= 4 or DMV
.Passengers
( It
) /= 0
268 or not DMV
.Top_Up
( It
) or not DMV
.Windshield_Up
( It
)
269 or not It
.Parked
then
270 Report
.Failed
("Failed Jeep " & TC_Message
);
272 end Parking_Validation
;
274 function Wash
( It
: V_Reference
; TC_Expect
: Ada
.Tags
.Tag
)
275 return DMV
.Vehicle
'Class is
276 This_Machine
: DMV
.Vehicle
'Class := It
.all;
278 TC_Match
( It
.all, TC_Expect
, "Class-wide object in Wash" );
279 Storage
:= DMV
.Wheels
( This_Machine
);
283 function Wash
( It
: C_Reference
; TC_Expect
: Ada
.Tags
.Tag
)
284 return DMV
.Car
'Class is
285 This_Machine
: DMV
.Car
'Class := It
.all;
287 TC_Match
( It
.all, TC_Expect
, "Class-wide object in Wash" );
288 Storage
:= DMV
.Wheels
( This_Machine
);
294 Report
.Test
( "C390004", "Check that the tags of allocated objects "
295 & "correctly identify the type of the allocated "
296 & "object. Check that tags resulting from "
297 & "normal and view conversions. Check tags of "
298 & "accessed values designating aliased objects. "
299 & "Check function result tags" );
301 DMV
.Set_Wheels
( The_Vehicle
, 1 );
302 DMV
.Set_Wheels
( The_Car
, 2 );
303 DMV
.Set_Wheels
( The_Convertible
, 3 );
304 DMV
.Set_Wheels
( The_Jeep
, 4 );
306 Valet
( The_Vehicle
);
308 Valet
( The_Convertible
);
311 Parking_Validation
( The_Vehicle
, "setup" );
312 Parking_Validation
( The_Car
, "setup" );
313 Parking_Validation
( The_Convertible
, "setup" );
314 Parking_Validation
( The_Jeep
, "setup" );
316 -- Check that the tags of allocated objects correctly identify the type
317 -- of the allocated object.
319 Designator
:= new DMV
.Vehicle
;
320 DMV
.TC_Check
( Designator
.all, DMV
.T_Veh
);
321 TC_Match
( Designator
.all, DMV
.Vehicle
'Tag, "allocated Vehicle" );
323 Designator
:= new DMV
.Car
;
324 DMV
.TC_Check
( Designator
.all, DMV
.T_Car
);
325 TC_Match
( Designator
.all, DMV
.Car
'Tag, "allocated Car");
327 Designator
:= new DMV
.Convertible
;
328 DMV
.TC_Check
( Designator
.all, DMV
.T_Con
);
329 TC_Match
( Designator
.all, DMV
.Convertible
'Tag, "allocated Convertible" );
331 Designator
:= new DMV
.Jeep
;
332 DMV
.TC_Check
( Designator
.all, DMV
.T_Jep
);
333 TC_Match
( Designator
.all, DMV
.Jeep
'Tag, "allocated Jeep" );
335 -- Check that view conversion causes the correct dispatch
336 DMV
.TC_Check
( DMV
.Vehicle
( The_Jeep
), DMV
.T_Veh
);
337 DMV
.TC_Check
( DMV
.Car
( The_Jeep
), DMV
.T_Car
);
338 DMV
.TC_Check
( DMV
.Convertible
( The_Jeep
), DMV
.T_Con
);
340 -- And that view conversion does not change the tag
341 TC_Match
( DMV
.Vehicle
( The_Jeep
), DMV
.Jeep
'Tag, "View Conv Veh" );
342 TC_Match
( DMV
.Car
( The_Jeep
), DMV
.Jeep
'Tag, "View Conv Car" );
343 TC_Match
( DMV
.Convertible
( The_Jeep
), DMV
.Jeep
'Tag, "View Conv Jep" );
345 -- Check that the tags of accessed values designating aliased objects
346 -- correctly identify the type of the object.
347 Designator
:= The_Vehicle
'Access;
348 DMV
.TC_Check
( Designator
.all, DMV
.T_Veh
);
349 TC_Match
( Designator
.all, DMV
.Vehicle
'Tag, "aliased Vehicle" );
351 Designator
:= The_Car
'Access;
352 DMV
.TC_Check
( Designator
.all, DMV
.T_Car
);
353 TC_Match
( Designator
.all, DMV
.Car
'Tag, "aliased Car" );
355 Designator
:= The_Convertible
'Access;
356 DMV
.TC_Check
( Designator
.all, DMV
.T_Con
);
357 TC_Match
( Designator
.all, DMV
.Convertible
'Tag, "aliased Convertible" );
359 Designator
:= The_Jeep
'Access;
360 DMV
.TC_Check
( Designator
.all, DMV
.T_Jep
);
361 TC_Match
( Designator
.all, DMV
.Jeep
'Tag, "aliased Jeep" );
363 -- Check that the tag of a function result correctly evaluates.
364 -- Check this for class-wide functions. The tag of a class-wide
365 -- function result should be the tag appropriate to the actual value
366 -- returned, not the tag of the ancestor type.
367 Function_Check
: declare
368 A_Vehicle
: V_Reference
:= new DMV
.Vehicle
'( The_Vehicle );
369 A_Car : C_Reference := new DMV.Car'( The_Car
);
370 A_Convertible
: C_Reference
:= new DMV
.Convertible
'( The_Convertible );
371 A_Jeep : C_Reference := new DMV.Jeep'( The_Jeep
);
373 DMV
.Unpark
( A_Vehicle
.all );
374 DMV
.Load_Passengers
( A_Car
.all, 5 );
375 DMV
.Load_Passengers
( A_Convertible
.all, 6 );
376 DMV
.Load_Passengers
( A_Jeep
.all, 7 );
377 DMV
.Lower_Top
( DMV
.Convertible
(A_Convertible
.all) );
378 DMV
.Lower_Top
( DMV
.Jeep
(A_Jeep
.all) );
379 DMV
.Lower_Windshield
( DMV
.Jeep
(A_Jeep
.all) );
381 if DMV
.Wheels
( Wash
( A_Jeep
, DMV
.Jeep
'Tag ) ) /= 4
383 Report
.Failed
("Did not correctly wash Jeep");
386 if DMV
.Wheels
( Wash
( A_Convertible
, DMV
.Convertible
'Tag ) ) /= 3
388 Report
.Failed
("Did not correctly wash Convertible");
391 if DMV
.Wheels
( Wash
( A_Car
, DMV
.Car
'Tag ) ) /= 2
393 Report
.Failed
("Did not correctly wash Car");
396 if DMV
.Wheels
( Wash
( A_Vehicle
, DMV
.Vehicle
'Tag ) ) /= 1
398 Report
.Failed
("Did not correctly wash Vehicle");