Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c7/c760001.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 -- C760001.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 Initialize is called for objects and components of
28 -- a controlled type when the objects and components are not
29 -- assigned explicit initial values. Check this for "simple" controlled
30 -- objects, controlled record components and arrays with controlled
31 -- components.
32 --
33 -- Check that if an explicit initial value is assigned to an object
34 -- or component of a controlled type then Initialize is not called.
35 --
36 -- TEST DESCRIPTION:
37 -- This test derives a type for Ada.Finalization.Controlled, and
38 -- overrides the Initialize and Adjust operations for the type. The
39 -- intent of the type is that it should carry incremental values
40 -- indicating the ordering of events with respect to these (and default
41 -- initialization) operations. The body of the test uses these values
42 -- to determine that the implicit calls to these subprograms happen
43 -- (or don't) at the appropriate times.
44 --
45 -- The test further derives types from this "root" type, which are the
46 -- actual types used in the test. One of the types is "simply" derived
47 -- from the "root" type, the other contains a component of the first
48 -- type, thus nesting a controlled object as a record component in
49 -- controlled objects.
50 --
51 -- The main program declares objects of these types and checks the
52 -- values of the components to ascertain that they have been touched
53 -- as expected.
54 --
55 -- Note that Finalization procedures are provided. This test does not
56 -- test that the calls to Finalization are made correctly. The
57 -- Finalization procedures are provided to catch an implementation that
58 -- calls Finalization at an incorrect time.
59 --
60 --
61 -- CHANGE HISTORY:
62 -- 06 Dec 94 SAIC ACVC 2.0
63 -- 10 Oct 95 SAIC Update and repair for ACVC 2.0.1
64 --
65 --!
66
67 ---------------------------------------------------------------- C760001_0
68
69 with Ada.Finalization;
70 package C760001_0 is
71 subtype Unique_ID is Natural;
72 function Unique_Value return Unique_ID;
73 -- increments each time it's called
74
75 function Most_Recent_Unique_Value return Unique_ID;
76 -- returns the same value as the most recent call to Unique_Value
77
78 type Root_Controlled is new Ada.Finalization.Controlled with record
79 My_ID : Unique_ID := Unique_Value;
80 My_Init_ID : Unique_ID := Unique_ID'First;
81 My_Adj_ID : Unique_ID := Unique_ID'First;
82 end record;
83
84 procedure Initialize( R: in out Root_Controlled );
85 procedure Adjust ( R: in out Root_Controlled );
86
87 TC_Initialize_Calls_Is_Failing : Boolean := False;
88
89 end C760001_0;
90
91 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
92
93 with Report;
94 package body C760001_0 is
95
96 Global_Unique_Counter : Unique_ID := 0;
97
98 function Unique_Value return Unique_ID is
99 begin
100 Global_Unique_Counter := Global_Unique_Counter +1;
101 return Global_Unique_Counter;
102 end Unique_Value;
103
104 function Most_Recent_Unique_Value return Unique_ID is
105 begin
106 return Global_Unique_Counter;
107 end Most_Recent_Unique_Value;
108
109 procedure Initialize( R: in out Root_Controlled ) is
110 begin
111 if TC_Initialize_Calls_Is_Failing then
112 Report.Failed("Initialized incorrectly called");
113 end if;
114 R.My_Init_ID := Unique_Value;
115 end Initialize;
116
117 procedure Adjust( R: in out Root_Controlled ) is
118 begin
119 R.My_Adj_ID := Unique_Value;
120 end Adjust;
121
122 end C760001_0;
123
124 ---------------------------------------------------------------- C760001_1
125
126 with Ada.Finalization;
127 with C760001_0;
128 package C760001_1 is
129
130 type Proc_ID is (None, Init, Adj, Fin);
131
132 type Test_Controlled is new C760001_0.Root_Controlled with record
133 Last_Proc_Called: Proc_ID := None;
134 end record;
135
136 procedure Initialize( TC: in out Test_Controlled );
137 procedure Adjust ( TC: in out Test_Controlled );
138 procedure Finalize ( TC: in out Test_Controlled );
139
140 type Nested_Controlled is new C760001_0.Root_Controlled with record
141 Nested : C760001_0.Root_Controlled;
142 Last_Proc_Called: Proc_ID := None;
143 end record;
144
145 procedure Initialize( TC: in out Nested_Controlled );
146 procedure Adjust ( TC: in out Nested_Controlled );
147 procedure Finalize ( TC: in out Nested_Controlled );
148
149 end C760001_1;
150
151 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
152
153 with Report;
154 package body C760001_1 is
155
156 procedure Initialize( TC: in out Test_Controlled ) is
157 begin
158 if TC.Last_Proc_Called /= None then
159 Report.Failed("Initialize for Test_Controlled");
160 end if;
161 TC.Last_Proc_Called := Init;
162 C760001_0.Initialize(C760001_0.Root_Controlled(TC));
163 end Initialize;
164
165 procedure Adjust ( TC: in out Test_Controlled ) is
166 begin
167 TC.Last_Proc_Called := Adj;
168 C760001_0.Adjust(C760001_0.Root_Controlled(TC));
169 end Adjust;
170
171 procedure Finalize ( TC: in out Test_Controlled ) is
172 begin
173 TC.Last_Proc_Called := Fin;
174 end Finalize;
175
176 procedure Initialize( TC: in out Nested_Controlled ) is
177 begin
178 if TC.Last_Proc_Called /= None then
179 Report.Failed("Initialize for Nested_Controlled");
180 end if;
181 TC.Last_Proc_Called := Init;
182 C760001_0.Initialize(C760001_0.Root_Controlled(TC));
183 end Initialize;
184
185 procedure Adjust ( TC: in out Nested_Controlled ) is
186 begin
187 TC.Last_Proc_Called := Adj;
188 C760001_0.Adjust(C760001_0.Root_Controlled(TC));
189 end Adjust;
190
191 procedure Finalize ( TC: in out Nested_Controlled ) is
192 begin
193 TC.Last_Proc_Called := Fin;
194 end Finalize;
195
196 end C760001_1;
197
198 ---------------------------------------------------------------- C760001
199
200 with Report;
201 with TCTouch;
202 with C760001_0;
203 with C760001_1;
204 with Ada.Finalization;
205 procedure C760001 is
206
207 use type C760001_1.Proc_ID;
208
209 -- in the first test, test the simple case. Check that a controlled object
210 -- causes a call to the procedure Initialize.
211 -- Also check that assignment causes a call to Adjust.
212
213 procedure Check_Simple_Objects is
214 S,T : C760001_1.Test_Controlled;
215 begin
216 TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch");
217 TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and
218 (T.Last_Proc_Called = C760001_1.Init),
219 "Initialize for simple object");
220 S := T;
221 TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj),
222 "Adjust for simple object");
223 TCTouch.Assert((S.My_ID = T.My_ID),
224 "Simple object My_ID's don't match");
225 TCTouch.Assert((S.My_Init_ID = T.My_Init_ID),
226 "Simple object My_Init_ID's don't match");
227 TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID),
228 "Simple object My_Adj_ID's in wrong order");
229 end Check_Simple_Objects;
230
231 -- in the second test, test a more complex case, check that a controlled
232 -- component of a controlled object gets processed correctly
233
234 procedure Check_Nested_Objects is
235 NO1 : C760001_1.Nested_Controlled;
236 begin
237 TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id),
238 "Default value order incorrect");
239 TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID),
240 "Initialization call order incorrect");
241 end Check_Nested_Objects;
242
243 -- check that objects assigned an initial value at declaration are Adjusted
244 -- and NOT Initialized
245
246 procedure Check_Objects_With_Initial_Values is
247
248 TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
249
250 A: C760001_1.Test_Controlled :=
251 ( Ada.Finalization.Controlled
252 with TC_Now,
253 TC_Now,
254 TC_Now,
255 C760001_1.None);
256
257 B: C760001_1.Nested_Controlled :=
258 ( Ada.Finalization.Controlled
259 with TC_Now,
260 TC_Now,
261 TC_Now,
262 C760001_0.Root_Controlled(A),
263 C760001_1.None);
264
265 begin
266 -- the implementation may or may not call Adjust for the values
267 -- assigned into A and B,
268 -- but should NOT call Initialize.
269 -- if the value used in the aggregate is overwritten by Initialize,
270 -- this indicates failure
271 TCTouch.Assert(A.My_Init_Id = TC_Now,
272 "Initialize was called for A with initial value");
273 TCTouch.Assert(B.My_Init_Id = TC_Now,
274 "Initialize was called for B with initial value");
275 TCTouch.Assert(B.Nested.My_Init_ID = TC_Now,
276 "Initialize was called for B.Nested initial value");
277 end Check_Objects_With_Initial_Values;
278
279 procedure Check_Array_Case is
280 type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
281 type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
282
283 Simple_Array_Default : Array_Simple;
284
285 Nested_Array_Default : Array_Nested;
286
287 TC_A_Bit_Later : C760001_0.Unique_ID;
288
289 begin
290 TC_A_Bit_Later := C760001_0.Unique_Value;
291 for N in 1..4 loop
292 TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called
293 = C760001_1.Init,
294 "Initialize for array initial value");
295
296 TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID
297 > C760001_0.Unique_ID'First)
298 and (Simple_Array_Default(N).My_Init_ID
299 < TC_A_Bit_Later),
300 "Initialize timing for simple array");
301
302 TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID
303 > C760001_0.Unique_ID'First)
304 and (Nested_Array_Default(N).My_Init_ID
305 < TC_A_Bit_Later),
306 "Initialize timing for container array");
307
308 TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called
309 = C760001_1.Init,
310 "Initialize for nested array (outer) initial value");
311
312 TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID
313 > C760001_0.Unique_ID'First)
314 and (Nested_Array_Default(N).Nested.My_Init_ID
315 < Nested_Array_Default(N).My_Init_ID),
316 "Initialize timing for array content");
317 end loop;
318 end Check_Array_Case;
319
320 procedure Check_Array_Case_With_Initial_Values is
321
322 TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value;
323
324 type Array_Simple is array(1..4) of C760001_1.Test_Controlled;
325 type Array_Nested is array(1..4) of C760001_1.Nested_Controlled;
326
327 Simple_Array_Explicit : Array_Simple := ( 1..4 => (
328 Ada.Finalization.Controlled
329 with TC_Now,
330 TC_Now,
331 TC_Now,
332 C760001_1.None ) );
333
334 A : constant C760001_0.Root_Controlled :=
335 ( Ada.Finalization.Controlled
336 with others => TC_Now);
337
338 Nested_Array_Explicit : Array_Nested := ( 1..4 => (
339 Ada.Finalization.Controlled
340 with TC_Now,
341 TC_Now,
342 TC_Now,
343 A,
344 C760001_1.None ) );
345
346 begin
347 -- the implementation may or may not call Adjust for the values
348 -- assigned into Simple_Array_Explicit and Nested_Array_Explicit,
349 -- but should NOT call Initialize.
350 -- if the value used in the aggregate is overwritten by Initialize,
351 -- this indicates failure
352 for N in 1..4 loop
353 TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID
354 = TC_Now,
355 "Initialize was called for array with initial value");
356 TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID
357 = TC_Now,
358 "Initialize was called for nested array (outer) with initial value");
359 TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now,
360 "Initialize was called for nested array (inner) with initial value");
361 end loop;
362 end Check_Array_Case_With_Initial_Values;
363
364 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
365
366 begin -- Main test procedure.
367
368 Report.Test ("C760001", "Check that Initialize is called for objects " &
369 "and components of a controlled type when the " &
370 "objects and components are not assigned " &
371 "explicit initial values. Check that if an " &
372 "explicit initial value is assigned to an " &
373 "object or component of a controlled type " &
374 "then Initialize is not called" );
375
376 Check_Simple_Objects;
377
378 Check_Nested_Objects;
379
380 Check_Array_Case;
381
382 C760001_0.TC_Initialize_Calls_Is_Failing := True;
383
384 Check_Objects_With_Initial_Values;
385
386 Check_Array_Case_With_Initial_Values;
387
388 Report.Result;
389
390 end C760001;