|
111
|
1 -- C390004.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 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.
|
|
|
36 --
|
|
|
37 -- TEST DESCRIPTION:
|
|
|
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.
|
|
|
42 --
|
|
|
43 --
|
|
|
44 -- CHANGE HISTORY:
|
|
|
45 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
46 --
|
|
|
47 --!
|
|
|
48
|
|
|
49 package C390004_1 is -- DMV
|
|
|
50 type Equipment is ( T_Veh, T_Car, T_Con, T_Jep );
|
|
|
51
|
|
|
52 type Vehicle is tagged record
|
|
|
53 Wheels : Natural := 4;
|
|
|
54 Parked : Boolean := False;
|
|
|
55 end record;
|
|
|
56
|
|
|
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 );
|
|
|
62
|
|
|
63 type Car is new Vehicle with record
|
|
|
64 Passengers : Natural := 0;
|
|
|
65 end record;
|
|
|
66
|
|
|
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 );
|
|
|
71
|
|
|
72 type Convertible is new Car with record
|
|
|
73 Top_Up : Boolean := True;
|
|
|
74 end record;
|
|
|
75
|
|
|
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 );
|
|
|
81
|
|
|
82 type Jeep is new Convertible with record
|
|
|
83 Windshield_Up : Boolean := True;
|
|
|
84 end record;
|
|
|
85
|
|
|
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 );
|
|
|
91
|
|
|
92 end C390004_1;
|
|
|
93
|
|
|
94 with Report;
|
|
|
95 package body C390004_1 is
|
|
|
96
|
|
|
97 procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is
|
|
|
98 begin
|
|
|
99 It.Wheels := To_Count;
|
|
|
100 end Set_Wheels;
|
|
|
101
|
|
|
102 function Wheels( It: Vehicle ) return Natural is
|
|
|
103 begin
|
|
|
104 return It.Wheels;
|
|
|
105 end Wheels;
|
|
|
106
|
|
|
107 procedure Park ( It: in out Vehicle ) is
|
|
|
108 begin
|
|
|
109 It.Parked := True;
|
|
|
110 end Park;
|
|
|
111
|
|
|
112 procedure UnPark ( It: in out Vehicle ) is
|
|
|
113 begin
|
|
|
114 It.Parked := False;
|
|
|
115 end UnPark;
|
|
|
116
|
|
|
117 procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ) is
|
|
|
118 begin
|
|
|
119 if To_Equip /= T_Veh then
|
|
|
120 Report.Failed ("Failed, called Vehicle for "
|
|
|
121 & Equipment'Image(To_Equip));
|
|
|
122 end if;
|
|
|
123 end TC_Check;
|
|
|
124
|
|
|
125 procedure TC_Check ( It: in Car; To_Equip: in Equipment ) is
|
|
|
126 begin
|
|
|
127 if To_Equip /= T_Car then
|
|
|
128 Report.Failed ("Failed, called Car for "
|
|
|
129 & Equipment'Image(To_Equip));
|
|
|
130 end if;
|
|
|
131 end TC_Check;
|
|
|
132
|
|
|
133 procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ) is
|
|
|
134 begin
|
|
|
135 if To_Equip /= T_Con then
|
|
|
136 Report.Failed ("Failed, called Convertible for "
|
|
|
137 & Equipment'Image(To_Equip));
|
|
|
138 end if;
|
|
|
139 end TC_Check;
|
|
|
140
|
|
|
141 procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ) is
|
|
|
142 begin
|
|
|
143 if To_Equip /= T_Jep then
|
|
|
144 Report.Failed ("Failed, called Jeep for "
|
|
|
145 & Equipment'Image(To_Equip));
|
|
|
146 end if;
|
|
|
147 end TC_Check;
|
|
|
148
|
|
|
149 procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is
|
|
|
150 begin
|
|
|
151 It.Passengers := To_Count;
|
|
|
152 UnPark( It );
|
|
|
153 end Load_Passengers;
|
|
|
154
|
|
|
155 procedure Park( It: in out Car ) is
|
|
|
156 begin
|
|
|
157 It.Passengers := 0;
|
|
|
158 Park( Vehicle( It ) );
|
|
|
159 end Park;
|
|
|
160
|
|
|
161 function Passengers( It: Car ) return Natural is
|
|
|
162 begin
|
|
|
163 return It.Passengers;
|
|
|
164 end Passengers;
|
|
|
165
|
|
|
166 procedure Raise_Top( It: in out Convertible ) is
|
|
|
167 begin
|
|
|
168 It.Top_Up := True;
|
|
|
169 end Raise_Top;
|
|
|
170
|
|
|
171 procedure Lower_Top( It: in out Convertible ) is
|
|
|
172 begin
|
|
|
173 It.Top_Up := False;
|
|
|
174 end Lower_Top;
|
|
|
175
|
|
|
176 function Top_Up ( It: Convertible ) return Boolean is
|
|
|
177 begin
|
|
|
178 return It.Top_Up;
|
|
|
179 end Top_Up;
|
|
|
180
|
|
|
181 procedure Park ( It: in out Convertible ) is
|
|
|
182 begin
|
|
|
183 It.Top_Up := True;
|
|
|
184 Park( Car( It ) );
|
|
|
185 end Park;
|
|
|
186
|
|
|
187 procedure Raise_Windshield( It: in out Jeep ) is
|
|
|
188 begin
|
|
|
189 It.Windshield_Up := True;
|
|
|
190 end Raise_Windshield;
|
|
|
191
|
|
|
192 procedure Lower_Windshield( It: in out Jeep ) is
|
|
|
193 begin
|
|
|
194 It.Windshield_Up := False;
|
|
|
195 end Lower_Windshield;
|
|
|
196
|
|
|
197 function Windshield_Up( It: Jeep ) return Boolean is
|
|
|
198 begin
|
|
|
199 return It.Windshield_Up;
|
|
|
200 end Windshield_Up;
|
|
|
201
|
|
|
202 procedure Park( It: in out Jeep ) is
|
|
|
203 begin
|
|
|
204 It.Windshield_Up := True;
|
|
|
205 Park( Convertible( It ) );
|
|
|
206 end Park;
|
|
|
207 end C390004_1;
|
|
|
208
|
|
|
209 with Report;
|
|
|
210 with Ada.Tags;
|
|
|
211 with C390004_1;
|
|
|
212 procedure C390004 is
|
|
|
213 package DMV renames C390004_1;
|
|
|
214
|
|
|
215 The_Vehicle : aliased DMV.Vehicle;
|
|
|
216 The_Car : aliased DMV.Car;
|
|
|
217 The_Convertible : aliased DMV.Convertible;
|
|
|
218 The_Jeep : aliased DMV.Jeep;
|
|
|
219
|
|
|
220 type C_Reference is access all DMV.Car'Class;
|
|
|
221 type V_Reference is access all DMV.Vehicle'Class;
|
|
|
222
|
|
|
223 Designator : V_Reference;
|
|
|
224 Storage : Natural;
|
|
|
225
|
|
|
226 procedure Valet( It: in out DMV.Vehicle'Class ) is
|
|
|
227 begin
|
|
|
228 DMV.Park( It );
|
|
|
229 end Valet;
|
|
|
230
|
|
|
231 procedure TC_Match( Object: DMV.Vehicle'Class;
|
|
|
232 Taglet: Ada.Tags.Tag;
|
|
|
233 Where : String ) is
|
|
|
234 use Ada.Tags;
|
|
|
235 begin
|
|
|
236 if Object'Tag /= Taglet then
|
|
|
237 Report.Failed("Tag mismatch: " & Where);
|
|
|
238 end if;
|
|
|
239 end TC_Match;
|
|
|
240
|
|
|
241 procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is
|
|
|
242 begin
|
|
|
243 if DMV.Wheels( It ) /= 1 or not It.Parked then
|
|
|
244 Report.Failed ("Failed Vehicle " & TC_Message);
|
|
|
245 end if;
|
|
|
246 end Parking_Validation;
|
|
|
247
|
|
|
248 procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is
|
|
|
249 begin
|
|
|
250 if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0
|
|
|
251 or not It.Parked then
|
|
|
252 Report.Failed ("Failed Car " & TC_Message);
|
|
|
253 end if;
|
|
|
254 end Parking_Validation;
|
|
|
255
|
|
|
256 procedure Parking_Validation( It: DMV.Convertible;
|
|
|
257 TC_Message: String ) is
|
|
|
258 begin
|
|
|
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);
|
|
|
262 end if;
|
|
|
263 end Parking_Validation;
|
|
|
264
|
|
|
265 procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is
|
|
|
266 begin
|
|
|
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);
|
|
|
271 end if;
|
|
|
272 end Parking_Validation;
|
|
|
273
|
|
|
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;
|
|
|
277 begin
|
|
|
278 TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );
|
|
|
279 Storage := DMV.Wheels( This_Machine );
|
|
|
280 return This_Machine;
|
|
|
281 end Wash;
|
|
|
282
|
|
|
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;
|
|
|
286 begin
|
|
|
287 TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );
|
|
|
288 Storage := DMV.Wheels( This_Machine );
|
|
|
289 return This_Machine;
|
|
|
290 end Wash;
|
|
|
291
|
|
|
292 begin
|
|
|
293
|
|
|
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" );
|
|
|
300
|
|
|
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 );
|
|
|
305
|
|
|
306 Valet( The_Vehicle );
|
|
|
307 Valet( The_Car );
|
|
|
308 Valet( The_Convertible );
|
|
|
309 Valet( The_Jeep );
|
|
|
310
|
|
|
311 Parking_Validation( The_Vehicle, "setup" );
|
|
|
312 Parking_Validation( The_Car, "setup" );
|
|
|
313 Parking_Validation( The_Convertible, "setup" );
|
|
|
314 Parking_Validation( The_Jeep, "setup" );
|
|
|
315
|
|
|
316 -- Check that the tags of allocated objects correctly identify the type
|
|
|
317 -- of the allocated object.
|
|
|
318
|
|
|
319 Designator := new DMV.Vehicle;
|
|
|
320 DMV.TC_Check( Designator.all, DMV.T_Veh );
|
|
|
321 TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" );
|
|
|
322
|
|
|
323 Designator := new DMV.Car;
|
|
|
324 DMV.TC_Check( Designator.all, DMV.T_Car );
|
|
|
325 TC_Match( Designator.all, DMV.Car'Tag, "allocated Car");
|
|
|
326
|
|
|
327 Designator := new DMV.Convertible;
|
|
|
328 DMV.TC_Check( Designator.all, DMV.T_Con );
|
|
|
329 TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" );
|
|
|
330
|
|
|
331 Designator := new DMV.Jeep;
|
|
|
332 DMV.TC_Check( Designator.all, DMV.T_Jep );
|
|
|
333 TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" );
|
|
|
334
|
|
|
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 );
|
|
|
339
|
|
|
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" );
|
|
|
344
|
|
|
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" );
|
|
|
350
|
|
|
351 Designator := The_Car'Access;
|
|
|
352 DMV.TC_Check( Designator.all, DMV.T_Car );
|
|
|
353 TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" );
|
|
|
354
|
|
|
355 Designator := The_Convertible'Access;
|
|
|
356 DMV.TC_Check( Designator.all, DMV.T_Con );
|
|
|
357 TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" );
|
|
|
358
|
|
|
359 Designator := The_Jeep'Access;
|
|
|
360 DMV.TC_Check( Designator.all, DMV.T_Jep );
|
|
|
361 TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" );
|
|
|
362
|
|
|
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 );
|
|
|
372 begin
|
|
|
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) );
|
|
|
380
|
|
|
381 if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4
|
|
|
382 or Storage /= 4 then
|
|
|
383 Report.Failed("Did not correctly wash Jeep");
|
|
|
384 end if;
|
|
|
385
|
|
|
386 if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3
|
|
|
387 or Storage /= 3 then
|
|
|
388 Report.Failed("Did not correctly wash Convertible");
|
|
|
389 end if;
|
|
|
390
|
|
|
391 if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2
|
|
|
392 or Storage /= 2 then
|
|
|
393 Report.Failed("Did not correctly wash Car");
|
|
|
394 end if;
|
|
|
395
|
|
|
396 if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1
|
|
|
397 or Storage /= 1 then
|
|
|
398 Report.Failed("Did not correctly wash Vehicle");
|
|
|
399 end if;
|
|
|
400
|
|
|
401 end Function_Check;
|
|
|
402
|
|
|
403 Report.Result;
|
|
|
404 end C390004;
|
