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 for an extension_aggregate whose ancestor_part is a
28 -- subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) )
29 -- Initialize is called on all controlled subcomponents of the
30 -- ancestor part; if the type of the ancestor part is itself controlled,
31 -- the Initialize procedure of the ancestor type is called, unless that
32 -- Initialize procedure is abstract.
34 -- Check that the utilization of a controlled type for a generic actual
35 -- parameter supports the correct behavior in the instantiated package.
38 -- Declares a generic package instantiated to check that controlled
39 -- types are not impacted by the "generic boundary."
40 -- This instance is then used to perform the tests of various
41 -- aggregate formations of the controlled type. After each operation
42 -- in the main program that should cause implicit calls, the "state" of
43 -- the software is checked. The "state" of the software is maintained in
44 -- several variables which count the calls to the Initialize, Adjust and
45 -- Finalize procedures in each context. Given the nature of the
46 -- language rules, the test specifies a minimum number of times that
47 -- these subprograms should have been called. The test also checks cases
48 -- where the subprograms should not have been called.
50 -- As per the example in AARM 7.6(11a..d);6.0, the distinctions between
51 -- the presence/absence of default values is tested.
55 -- C760009_3.Master_Control is derived from
56 -- C760009_2.Control is derived from
57 -- Ada.Finalization.Controlled
59 -- C760009_1.Simple_Control is derived from
60 -- Ada.Finalization.Controlled
62 -- C760009_3.Master_Control contains
65 -- C760009_2.Control contains
66 -- C760009_1.Simple_Control (default value)
67 -- C760009_1.Simple_Control (default initialized)
71 -- 01 MAY 95 SAIC Initial version
72 -- 19 FEB 96 SAIC Fixed elaboration Initialize count
73 -- 14 NOV 96 SAIC Allowed for 7.6(21) optimizations
74 -- 13 FEB 97 PWB.CTA Initialized counters at lines 127-129
75 -- 26 JUN 98 EDS Added pragma Elaborate_Body to C760009_0
76 -- to avoid possible instantiation error
79 ---------------------------------------------------------------- C760009_0
81 with Ada
.Finalization
;
84 type Private_Formal
is private;
86 with procedure TC_Validate
( APF
: in out Private_Formal
);
88 package C760009_0
is -- Check_1
90 pragma Elaborate_Body
;
91 procedure TC_Check_1
( APF
: in Private_Formal
);
92 procedure TC_Check_2
( APF
: out Private_Formal
);
93 procedure TC_Check_3
( APF
: in out Private_Formal
);
97 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
100 package body C760009_0
is -- Check_1
102 procedure TC_Check_1
( APF
: in Private_Formal
) is
103 Local
: Private_Formal
;
106 TC_Validate
( Local
);
109 procedure TC_Check_2
( APF
: out Private_Formal
) is
110 Local
: Private_Formal
; -- initialized by virtue of actual being
117 procedure TC_Check_3
( APF
: in out Private_Formal
) is
118 Local
: Private_Formal
;
121 TC_Validate
( Local
);
126 ---------------------------------------------------------------- C760009_1
128 with Ada
.Finalization
;
131 Initialize_Called
: Natural := 0;
132 Adjust_Called
: Natural := 0;
133 Finalize_Called
: Natural := 0;
135 procedure Reset_Counters
;
137 type Simple_Control
is new Ada
.Finalization
.Controlled
with private;
139 procedure Initialize
( AV
: in out Simple_Control
);
140 procedure Adjust
( AV
: in out Simple_Control
);
141 procedure Finalize
( AV
: in out Simple_Control
);
142 procedure Validate
( AV
: in out Simple_Control
);
144 function Item
( AV
: Simple_Control
'Class ) return String;
146 Empty
: constant Simple_Control
;
148 procedure TC_Trace
( Message
: String );
151 type Simple_Control
is new Ada
.Finalization
.Controlled
with record
155 Empty
: constant Simple_Control
:= ( Ada
.Finalization
.Controlled
with 0 );
159 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
162 package body C760009_1
is
164 -- Maintenance_Mode and TC_Trace are for the test writers and compiler
165 -- developers to get more information from this test as it executes.
166 -- Maintenance_Mode is always False for validation purposes.
168 Maintenance_Mode
: constant Boolean := False;
170 procedure TC_Trace
( Message
: String ) is
172 if Maintenance_Mode
then
173 Report
.Comment
( Message
);
177 procedure Reset_Counters
is
179 Initialize_Called
:= 0;
181 Finalize_Called
:= 0;
184 Master_Count
: Natural := 100; -- Help distinguish values
186 procedure Initialize
( AV
: in out Simple_Control
) is
188 Initialize_Called
:= Initialize_Called
+1;
189 AV
.Item
:= Master_Count
;
190 Master_Count
:= Master_Count
+100;
191 TC_Trace
( "Initialize _1.Simple_Control" );
194 procedure Adjust
( AV
: in out Simple_Control
) is
196 Adjust_Called
:= Adjust_Called
+1;
197 AV
.Item
:= AV
.Item
+1;
198 TC_Trace
( "Adjust _1.Simple_Control" );
201 procedure Finalize
( AV
: in out Simple_Control
) is
203 Finalize_Called
:= Finalize_Called
+1;
204 AV
.Item
:= AV
.Item
+1;
205 TC_Trace
( "Finalize _1.Simple_Control" );
208 procedure Validate
( AV
: in out Simple_Control
) is
210 Report
.Failed
("Attempt to Validate at Simple_Control level");
213 function Item
( AV
: Simple_Control
'Class ) return String is
215 return Natural'Image(AV
.Item
);
220 ---------------------------------------------------------------- C760009_2
223 with Ada
.Finalization
;
226 type Control
is new Ada
.Finalization
.Controlled
with record
227 Element_1
: C760009_1
.Simple_Control
;
228 Element_2
: C760009_1
.Simple_Control
:= C760009_1
.Empty
;
231 procedure Initialize
( AV
: in out Control
);
232 procedure Finalize
( AV
: in out Control
);
234 Initialized
: Natural := 0;
235 Finalized
: Natural := 0;
239 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
241 package body C760009_2
is
243 procedure Initialize
( AV
: in out Control
) is
245 Initialized
:= Initialized
+1;
246 C760009_1
.TC_Trace
( "Initialize _2.Control" );
249 procedure Finalize
( AV
: in out Control
) is
251 Finalized
:= Finalized
+1;
252 C760009_1
.TC_Trace
( "Finalize _2.Control" );
257 ---------------------------------------------------------------- C760009_3
263 type Master_Control
is new C760009_2
.Control
with record
267 procedure Initialize
( AC
: in out Master_Control
);
268 -- calls C760009_2.Initialize
269 -- embedded data causes 1 call to C760009_1.Initialize
271 -- Adjusting operation will
272 -- make 1 call to C760009_2.Adjust
273 -- make 2 call to C760009_1.Adjust
275 -- Finalize operation will
276 -- make 1 call to C760009_2.Finalize
277 -- make 2 call to C760009_1.Finalize
279 procedure Validate
( AC
: in out Master_Control
);
282 new C760009_0
(Master_Control
, Validate
);
286 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
290 package body C760009_3
is
292 procedure Initialize
( AC
: in out Master_Control
) is
295 C760009_2
.Initialize
(C760009_2
.Control
(AC
));
296 C760009_1
.TC_Trace
( "Initialize Master_Control" );
299 procedure Validate
( AC
: in out Master_Control
) is
301 if AC
.Data
not in 0..1000 then
302 Report
.Failed
("C760009_3.Control did not Initialize" );
308 --------------------------------------------------------------------- C760009
316 -- Comment following declaration indicates expected calls in the order:
317 -- Initialize of a C760009_2 value
318 -- Finalize of a C760009_2 value
319 -- Initialize of a C760009_1 value
320 -- Adjust of a C760009_1 value
321 -- Finalize of a C760009_1 value
323 Global_Control
: C760009_3
.Master_Control
;
326 Parent_Control
: C760009_2
.Control
;
329 -- Global_Control is a derived tagged type, the parent type
330 -- of Master_Control, Control, is derived from Controlled, and contains
331 -- two components of a Controlled type, Simple_Control. One of these
332 -- components has a default value, the other does not.
334 procedure Fail
( Which
: String; Expect
, Got
: Natural ) is
336 Report
.Failed
(Which
& " Expected" & Natural'Image(Expect
)
337 & " got" & Natural'Image(Got
) );
340 procedure Master_Assertion
( Layer_2_Inits
: Natural;
341 Layer_2_Finals
: Natural;
342 Layer_1_Inits
: Natural;
343 Layer_1_Adjs
: Natural;
344 Layer_1_Finals
: Natural;
345 Failing_Message
: String ) is
351 if C760009_2
.Initialized
/= Layer_2_Inits
then
352 Fail
("C760009_2.Initialize " & Failing_Message
,
353 Layer_2_Inits
, C760009_2
.Initialized
);
356 if C760009_2
.Finalized
not in Layer_2_Finals
..Layer_2_Finals
*2 then
357 Fail
("C760009_2.Finalize " & Failing_Message
,
358 Layer_2_Finals
, C760009_2
.Finalized
);
361 if C760009_1
.Initialize_Called
/= Layer_1_Inits
then
362 Fail
("C760009_1.Initialize " & Failing_Message
,
364 C760009_1
.Initialize_Called
);
367 if C760009_1
.Adjust_Called
not in Layer_1_Adjs
..Layer_1_Adjs
*2 then
368 Fail
("C760009_1.Adjust " & Failing_Message
,
369 Layer_1_Adjs
, C760009_1
.Adjust_Called
);
372 if C760009_1
.Finalize_Called
not in Layer_1_Finals
..Layer_1_Finals
*2 then
373 Fail
("C760009_1.Finalize " & Failing_Message
,
374 Layer_1_Finals
, C760009_1
.Finalize_Called
);
377 C760009_1
.Reset_Counters
;
378 C760009_2
.Initialized
:= 0;
379 C760009_2
.Finalized
:= 0;
381 end Master_Assertion
;
383 procedure Lesser_Assertion
( Layer_2_Inits
: Natural;
384 Layer_2_Finals
: Natural;
385 Layer_1_Inits
: Natural;
386 Layer_1_Adjs
: Natural;
387 Layer_1_Finals
: Natural;
388 Failing_Message
: String ) is
392 if C760009_2
.Initialized
> Layer_2_Inits
then
393 Fail
("C760009_2.Initialize " & Failing_Message
,
394 Layer_2_Inits
, C760009_2
.Initialized
);
397 if C760009_2
.Finalized
< Layer_2_Inits
398 or C760009_2
.Finalized
> Layer_2_Finals
*2 then
399 Fail
("C760009_2.Finalize " & Failing_Message
,
400 Layer_2_Finals
, C760009_2
.Finalized
);
403 if C760009_1
.Initialize_Called
> Layer_1_Inits
then
404 Fail
("C760009_1.Initialize " & Failing_Message
,
406 C760009_1
.Initialize_Called
);
409 if C760009_1
.Adjust_Called
> Layer_1_Adjs
*2 then
410 Fail
("C760009_1.Adjust " & Failing_Message
,
411 Layer_1_Adjs
, C760009_1
.Adjust_Called
);
414 if C760009_1
.Finalize_Called
< Layer_1_Inits
415 or C760009_1
.Finalize_Called
> Layer_1_Finals
*2 then
416 Fail
("C760009_1.Finalize " & Failing_Message
,
417 Layer_1_Finals
, C760009_1
.Finalize_Called
);
420 C760009_1
.Reset_Counters
;
421 C760009_2
.Initialized
:= 0;
422 C760009_2
.Finalized
:= 0;
424 end Lesser_Assertion
;
426 begin -- Main test procedure.
428 Report
.Test
("C760009", "Check that for an extension_aggregate whose " &
429 "ancestor_part is a subtype_mark, Initialize " &
430 "is called on all controlled subcomponents of " &
431 "the ancestor part. Also check that the " &
432 "utilization of a controlled type for a generic " &
433 "actual parameter supports the correct behavior " &
434 "in the instantiated software" );
436 C760009_1
.TC_Trace
( "=====> Case 0 <=====" );
438 C760009_1
.Reset_Counters
;
439 C760009_2
.Initialized
:= 0;
440 C760009_2
.Finalized
:= 0;
442 C760009_3
.Validate
( Global_Control
); -- check that it Initialized correctly
444 C760009_1
.TC_Trace
( "=====> Case 1 <=====" );
446 C760009_3
.Check_1
.TC_Check_1
( ( C760009_2
.Control
with Data
=> 1 ) );
447 Lesser_Assertion
( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" );
448 -- | | | | + Finalize 2 embedded in aggregate
449 -- | | | | + Finalize 2 at assignment in TC_Check_1
450 -- | | | | + Finalize 2 embedded in local variable
451 -- | | | + Adjust 2 caused by assignment in TC_Check_1
452 -- | | | + Adjust at declaration in TC_Check_1
453 -- | | + Initialize at declaration in TC_Check_1
454 -- | | + Initialize of aggregate object
455 -- | + Finalize of assignment target
456 -- | + Finalize of local variable
457 -- | + Finalize of aggregate object
458 -- + Initialize of aggregate object
459 -- + Initialize of local variable
462 C760009_1
.TC_Trace
( "=====> Case 2 <=====" );
464 C760009_3
.Check_1
.TC_Check_2
( Global_Control
);
465 Master_Assertion
( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" );
466 -- | | | | + Finalize 2 at assignment in TC_Check_2
467 -- | | | | + Finalize 2 embedded in local variable
468 -- | | | + Adjust 2 caused by assignment in TC_Check_2
469 -- | | | + Adjust at declaration in TC_Check_2
470 -- | | + Initialize at declaration in TC_Check_2
471 -- | + Finalize of assignment target
472 -- | + Finalize of local variable
473 -- + Initialize of local variable
476 C760009_1
.TC_Trace
( "=====> Case 3 <=====" );
478 Global_Control
:= ( C760009_2
.Control
with Data
=> 2 );
479 Lesser_Assertion
( 1, 1, 1, 3, 2, "Aggregate -> object" );
480 -- | | | | + Finalize 2 by assignment
481 -- | | | + Adjust 2 caused by assignment
482 -- | | | + Adjust in aggregate creation
483 -- | | + Initialize of aggregate object
484 -- | + Finalize of assignment target
485 -- + Initialize of aggregate object
488 C760009_1
.TC_Trace
( "=====> Case 4 <=====" );
490 C760009_3
.Check_1
.TC_Check_3
( Global_Control
);
491 Master_Assertion
( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" );
492 -- | | | | + Finalize 2 at assignment in TC_Check_3
493 -- | | | | + Finalize 2 embedded in local variable
494 -- | | | + Adjust 2 at assignment in TC_Check_3
495 -- | | | + Adjust in local variable creation
496 -- | | + Initialize of local variable in TC_Check_3
497 -- | + Finalize of assignment target
498 -- | + Finalize of local variable
499 -- + Initialize of local variable
502 C760009_1
.TC_Trace
( "=====> Case 5 <=====" );
504 Global_Control
:= ( Parent_Control
with Data
=> 3 );
505 Lesser_Assertion
( 1, 1, 1, 3, 2, "Object Aggregate -> object" );
506 -- | | | | + Finalize 2 by assignment
507 -- | | | + Adjust 2 caused by assignment
508 -- | | | + Adjust in aggregate creation
509 -- | | + Initialize of aggregate object
510 -- | + Finalize of assignment target
511 -- + Initialize of aggregate object
515 C760009_1
.TC_Trace
( "=====> Case 6 <=====" );
517 -- perform this check a second time to make sure nothing is "remembered"
519 C760009_3
.Check_1
.TC_Check_3
( Global_Control
);
520 Master_Assertion
( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" );
521 -- | | | | + Finalize 2 at assignment in TC_Check_3
522 -- | | | | + Finalize 2 embedded in local variable
523 -- | | | + Adjust 2 at assignment in TC_Check_3
524 -- | | | + Adjust in local variable creation
525 -- | | + Initialize of local variable in TC_Check_3
526 -- | + Finalize of assignment target
527 -- | + Finalize of local variable
528 -- + Initialize of local variable