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 objects of a controlled type that are created
28 -- by an allocator are finalized at the appropriate time. In
29 -- particular, check that such objects are not finalized due to
30 -- completion of the master in which they were allocated if the
31 -- corresponding access type is declared outside of that master.
33 -- Check that Unchecked_Deallocation of a controlled
34 -- object causes finalization of that object.
37 -- This test derives a type from Ada.Finalization.Controlled, and
38 -- declares access types to that type in various scope scenarios.
39 -- The dispatching procedure Finalize is redefined for the derived
40 -- type to perform a check that it has been called at the
41 -- correct time. This is accomplished using a global variable
42 -- which indicates what state the software is currently
43 -- executing. The test utilizes the TCTouch facilities to
44 -- verify that Finalize is called the correct number of times, at
45 -- the correct times. Several calls are made to validate passing
46 -- the null string to check that Finalize has NOT been called at
51 -- 06 Dec 94 SAIC ACVC 2.0
55 with Ada
.Finalization
;
57 type Global
is new Ada
.Finalization
.Controlled
with null record;
58 procedure Finalize
( It
: in out Global
);
60 type Second
is new Ada
.Finalization
.Limited_Controlled
with null record;
61 procedure Finalize
( It
: in out Second
);
66 package body C761002_0
is
68 procedure Finalize
( It
: in out Global
) is
70 TCTouch
.Touch
('F'); ------------------------------------------------- F
73 procedure Finalize
( It
: in out Second
) is
75 TCTouch
.Touch
('S'); ------------------------------------------------- S
82 with Unchecked_Deallocation
;
85 -- check the straightforward case
86 procedure Subtest_1
is
87 type Access_1
is access C761002_0
.Global
;
92 V2
:= new C761002_0
.Global
;
93 V1
:= V2
; -- "dead" assignment must not be optimized away due to
94 -- finalization "side effects", many more of these follow
98 -- no calls to Finalize should have occurred at this point
99 TCTouch
.Validate
("","Allocated nested, retained");
102 -- check Unchecked_Deallocation
103 procedure Subtest_2
is
104 type Access_2
is access C761002_0
.Global
;
106 new Unchecked_Deallocation
(C761002_0
.Global
, Access_2
);
110 procedure Allocate
is
112 V1
:= new C761002_0
.Global
;
113 V2
:= new C761002_0
.Global
;
118 -- no calls to Finalize should have occurred at this point.
119 TCTouch
.Validate
("","Allocated nested, non-local");
121 Free
(V1
); -- instance of Unchecked_Deallocation
122 -- should cause the finalization of V1.all
123 TCTouch
.Validate
("F","Unchecked Deallocation");
124 end Subtest_2
; -- leaving this scope should cause the finalization of V2.all
126 -- check various master-exit scenarios
127 -- the "Fake" parameters are used to avoid unwanted optimizations
128 procedure Subtest_3
is
129 procedure With_Local_Block
is
130 type Access_3
is access C761002_0
.Global
;
134 V2
: Access_3
:= new C761002_0
.Global
;
138 TCTouch
.Validate
("","Local Block, normal exit");
139 -- the allocated object should be finalized on leaving this scope
140 end With_Local_Block
;
142 procedure With_Local_Block_Return
(Fake
: Integer) is
143 type Access_4
is access C761002_0
.Global
;
144 V1
: Access_4
:= new C761002_0
.Global
;
150 V2
:= new C761002_0
.Global
;
151 return; -- the two allocated objects should be finalized
152 end; -- upon leaving this scope
156 end With_Local_Block_Return
;
158 procedure With_Goto
(Fake
: Integer) is
159 type Access_5
is access C761002_0
.Global
;
160 V1
: Access_5
:= new C761002_0
.Global
;
166 type Access_6
is access C761002_0
.Second
;
169 V6
:= new C761002_0
.Second
;
177 TCTouch
.Validate
("S","goto past master end");
182 TCTouch
.Validate
("F","Local Block, normal exit, after master");
184 With_Local_Block_Return
( Report
.Ident_Int
(0) );
185 TCTouch
.Validate
("FF","Local Block, return from block");
187 With_Goto
( Report
.Ident_Int
(0) );
188 TCTouch
.Validate
("F","With Goto");
192 procedure Subtest_4
is
196 procedure Alley
( Fake
: Integer ) is
197 type Access_1
is access C761002_0
.Global
;
200 V1
:= new C761002_0
.Global
;
209 Alley
( Report
.Ident_Int
(1) );
211 when Oops
=> TCTouch
.Validate
("F","leaving via exception");
212 when others => Report
.Failed
("Wrong exception");
216 begin -- Main test procedure.
218 Report
.Test
("C761002", "Check that objects of a controlled type created "
219 & "by an allocator are finalized appropriately. "
220 & "Check that Unchecked_Deallocation of a "
221 & "controlled object causes finalization "
222 & "of that object" );
225 -- leaving the scope of the access type should finalize the
227 TCTouch
.Validate
("F","Allocated nested, Subtest 1");
230 -- Unchecked_Deallocation already finalized one of the two
231 -- objects allocated, the other should be the only one finalized
232 -- at leaving the scope of the access type.
233 TCTouch
.Validate
("F","Allocated non-local");
236 -- there should be no remaining finalizations from this subtest
237 TCTouch
.Validate
("","Localized objects");
240 -- there should be no remaining finalizations from this subtest
241 TCTouch
.Validate
("","Exception testing");