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 an object of a controlled type is finalized with the
28 -- enclosing master is complete.
29 -- Check that finalization occurs in the case where the master is
30 -- left by a transfer of control.
31 -- Specifically check for types where the derived types do not have
34 -- Check that finalization of controlled objects is
35 -- performed in the correct order. In particular, check that if
36 -- multiple objects of controlled types are declared immediately
37 -- within the same declarative part then they are finalized in the
38 -- reverse order of their creation.
41 -- This test checks these conditions for subprograms and
42 -- block statements; both variables and constants of controlled
43 -- types; cases of a controlled component of a record type, as
44 -- well as an array with controlled components.
46 -- The base controlled types used for the test are defined
47 -- with a character discriminant. The initialize procedure for
48 -- the types will record the order of creation in a globally
49 -- accessible array, the finalize procedure for the types will call
50 -- TCTouch with that tag character. The test can then check that
51 -- the order of finalization is indeed the reverse of the order of
52 -- creation (assuming that the implementation calls Initialize in
53 -- the order that the objects are created).
57 -- 06 Dec 94 SAIC ACVC 2.0
58 -- 04 Nov 95 SAIC Fixed bugs for ACVC 2.0.1
62 package C761004_Support
is
64 function Pick_Char
return Character;
65 -- successive calls to Pick_Char return distinct characters which may
66 -- be assigned to objects to track an order sequence. These characters
67 -- are then used in calls to TCTouch.Touch.
69 procedure Validate
(Initcount
: Natural; Testnumber
:Natural);
70 -- does a little extra processing prior to calling TCTouch.Validate,
71 -- specifically, it reverses the stored string of characters, and checks
72 -- for a correct count.
74 Inits_Order
: String(1..255);
75 Inits_Called
: Natural := 0;
81 package body C761004_Support
is
82 type Pick_Rotation
is mod 52;
83 type Pick_String
is array(Pick_Rotation
) of Character;
85 From
: constant Pick_String
:= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
86 & "abcdefghijklmnopqrstuvwxyz";
87 Recent_Pick
: Pick_Rotation
:= Pick_Rotation
'Last;
89 function Pick_Char
return Character is
91 Recent_Pick
:= Recent_Pick
+1;
92 return From
(Recent_Pick
);
95 function Invert
(S
:String) return String is
96 T
: String(1..S
'Length);
99 for SI
in reverse S
'Range loop
106 procedure Validate
(Initcount
: Natural; Testnumber
:Natural) is
107 Number
: constant String := Natural'Image(Testnumber
);
109 if Inits_Called
/= Initcount
then
110 Report
.Failed
("Wrong number of inits, Subtest " & Number
);
114 Invert
(Inits_Order
(1..Inits_Called
)),
115 "Subtest " & Number
, True);
121 ----------------------------------------------------------------- C761004_0
123 with Ada
.Finalization
;
125 type Global
is new Ada
.Finalization
.Controlled
with record
128 procedure Initialize
( It
: in out Global
);
129 procedure Finalize
( It
: in out Global
);
131 type Second
is new Ada
.Finalization
.Limited_Controlled
with record
134 procedure Initialize
( It
: in out Second
);
135 procedure Finalize
( It
: in out Second
);
140 with C761004_Support
;
141 package body C761004_0
is
143 package Sup
renames C761004_Support
;
145 procedure Initialize
( It
: in out Global
) is
147 Sup
.Inits_Called
:= Sup
.Inits_Called
+1;
148 It
.Tag
:= Sup
.Pick_Char
;
149 Sup
.Inits_Order
(Sup
.Inits_Called
) := It
.Tag
;
152 procedure Finalize
( It
: in out Global
) is
154 TCTouch
.Touch
(It
.Tag
); --------------------------------------------- Tag
157 procedure Initialize
( It
: in out Second
) is
159 Sup
.Inits_Called
:= Sup
.Inits_Called
+1;
160 It
.Tag
:= Sup
.Pick_Char
;
161 Sup
.Inits_Order
(Sup
.Inits_Called
) := It
.Tag
;
164 procedure Finalize
( It
: in out Second
) is
166 TCTouch
.Touch
(It
.Tag
); --------------------------------------------- Tag
170 ------------------------------------------------------------------- C761004
175 with C761004_Support
;
176 with Ada
.Finalization
; -- needed to be able to create extension aggregates
179 Verbose
: constant Boolean := False;
181 package Sup
renames C761004_Support
;
183 -- Subtest 1, general case. Check that several objects declared in a
184 -- subprogram are created, and finalized in opposite order.
186 Subtest_1_Expected_Inits
: constant := 3;
188 procedure Subtest_1
is
189 Item_1
: C761004_0
.Global
;
190 Item_2
, Item_3
: C761004_0
.Global
;
192 if Item_2
.Tag
= Item_3
.Tag
then -- not germane to the test
193 Report
.Failed
("Duplicate tag");-- but helps prevent code elimination
197 -- Subtest 2, extension of the general case. Check that several objects
198 -- created identically on the stack (via a recursive procedure) are
199 -- finalized in the opposite order of their creation.
200 Subtest_2_Expected_Inits
: constant := 12;
201 User_Exception
: exception;
203 procedure Subtest_2
is
205 Item_1
: C761004_0
.Global
;
207 -- combine recursion and exit by exception:
209 procedure Nested
(Recurs
: Natural) is
210 Item_3
: C761004_0
.Global
;
213 Report
.Comment
("going in: " & Item_3
.Tag
);
216 raise User_Exception
;
222 Item_2
: C761004_0
.Global
;
228 -- subtest 3, check the case of objects embedded in structures:
231 Subtest_3_Expected_Inits
: constant := 3;
232 procedure Subtest_3
is
233 type G_List
is array(Positive range <>) of C761004_0
.Global
;
234 type Pandoras_Box
is record
238 procedure Nested
(Recursions
: Natural) is
239 Merlin
: Pandoras_Box
;
241 if Recursions
> 1 then
242 Nested
(Recursions
-1);
244 TCTouch
.Validate
("","Final Nested call");
252 -- subtest 4, check the case of objects embedded in structures:
255 Subtest_4_Expected_Inits
: constant := 3;
256 procedure Subtest_4
is
257 type S_List
is array(Positive range <>) of C761004_0
.Second
;
258 type Pandoras_Box
is record
262 procedure Nested
(Recursions
: Natural) is
263 Merlin
: Pandoras_Box
;
265 if Recursions
> 1 then
266 Nested
(Recursions
-1);
268 TCTouch
.Validate
("","Final Nested call");
276 begin -- Main test procedure.
278 Report
.Test
("C761004", "Check that an object of a controlled type "
279 & "is finalized when the enclosing master is "
280 & "complete, left by a transfer of control, "
281 & "and performed in the correct order" );
284 Sup
.Validate
(Subtest_1_Expected_Inits
,1);
286 Subtest_2_Frame
: begin
287 Sup
.Inits_Called
:= 0;
290 when User_Exception
=> null;
291 when others => Report
.Failed
("Wrong Exception, Subtest 2");
293 Sup
.Validate
(Subtest_2_Expected_Inits
,2);
295 Sup
.Inits_Called
:= 0;
297 Sup
.Validate
(Subtest_3_Expected_Inits
,3);
299 Sup
.Inits_Called
:= 0;
301 Sup
.Validate
(Subtest_4_Expected_Inits
,4);