Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c390004.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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;