|
111
|
1 -- C761002.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 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.
|
|
|
32 --
|
|
|
33 -- Check that Unchecked_Deallocation of a controlled
|
|
|
34 -- object causes finalization of that object.
|
|
|
35 --
|
|
|
36 -- TEST DESCRIPTION:
|
|
|
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
|
|
|
47 -- that point.
|
|
|
48 --
|
|
|
49 --
|
|
|
50 -- CHANGE HISTORY:
|
|
|
51 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
52 --
|
|
|
53 --!
|
|
|
54
|
|
|
55 with Ada.Finalization;
|
|
|
56 package C761002_0 is
|
|
|
57 type Global is new Ada.Finalization.Controlled with null record;
|
|
|
58 procedure Finalize( It: in out Global );
|
|
|
59
|
|
|
60 type Second is new Ada.Finalization.Limited_Controlled with null record;
|
|
|
61 procedure Finalize( It: in out Second );
|
|
|
62 end C761002_0;
|
|
|
63
|
|
|
64 with Report;
|
|
|
65 with TCTouch;
|
|
|
66 package body C761002_0 is
|
|
|
67
|
|
|
68 procedure Finalize( It: in out Global ) is
|
|
|
69 begin
|
|
|
70 TCTouch.Touch('F'); ------------------------------------------------- F
|
|
|
71 end Finalize;
|
|
|
72
|
|
|
73 procedure Finalize( It: in out Second ) is
|
|
|
74 begin
|
|
|
75 TCTouch.Touch('S'); ------------------------------------------------- S
|
|
|
76 end Finalize;
|
|
|
77 end C761002_0;
|
|
|
78
|
|
|
79 with Report;
|
|
|
80 with TCTouch;
|
|
|
81 with C761002_0;
|
|
|
82 with Unchecked_Deallocation;
|
|
|
83 procedure C761002 is
|
|
|
84
|
|
|
85 -- check the straightforward case
|
|
|
86 procedure Subtest_1 is
|
|
|
87 type Access_1 is access C761002_0.Global;
|
|
|
88 V1 : Access_1;
|
|
|
89 procedure Allocate is
|
|
|
90 V2 : Access_1;
|
|
|
91 begin
|
|
|
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
|
|
|
95 end Allocate;
|
|
|
96 begin
|
|
|
97 Allocate;
|
|
|
98 -- no calls to Finalize should have occurred at this point
|
|
|
99 TCTouch.Validate("","Allocated nested, retained");
|
|
|
100 end Subtest_1;
|
|
|
101
|
|
|
102 -- check Unchecked_Deallocation
|
|
|
103 procedure Subtest_2 is
|
|
|
104 type Access_2 is access C761002_0.Global;
|
|
|
105 procedure Free is
|
|
|
106 new Unchecked_Deallocation(C761002_0.Global, Access_2);
|
|
|
107 V1 : Access_2;
|
|
|
108 V2 : Access_2;
|
|
|
109
|
|
|
110 procedure Allocate is
|
|
|
111 begin
|
|
|
112 V1 := new C761002_0.Global;
|
|
|
113 V2 := new C761002_0.Global;
|
|
|
114 end Allocate;
|
|
|
115
|
|
|
116 begin
|
|
|
117 Allocate;
|
|
|
118 -- no calls to Finalize should have occurred at this point.
|
|
|
119 TCTouch.Validate("","Allocated nested, non-local");
|
|
|
120
|
|
|
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
|
|
|
125
|
|
|
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;
|
|
|
131 V1 : Access_3;
|
|
|
132 begin
|
|
|
133 declare
|
|
|
134 V2 : Access_3 := new C761002_0.Global;
|
|
|
135 begin
|
|
|
136 V1 := V2;
|
|
|
137 end;
|
|
|
138 TCTouch.Validate("","Local Block, normal exit");
|
|
|
139 -- the allocated object should be finalized on leaving this scope
|
|
|
140 end With_Local_Block;
|
|
|
141
|
|
|
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;
|
|
|
145 begin
|
|
|
146 if Fake = 0 then
|
|
|
147 declare
|
|
|
148 V2 : Access_4;
|
|
|
149 begin
|
|
|
150 V2 := new C761002_0.Global;
|
|
|
151 return; -- the two allocated objects should be finalized
|
|
|
152 end; -- upon leaving this scope
|
|
|
153 else
|
|
|
154 V1 := null;
|
|
|
155 end if;
|
|
|
156 end With_Local_Block_Return;
|
|
|
157
|
|
|
158 procedure With_Goto(Fake: Integer) is
|
|
|
159 type Access_5 is access C761002_0.Global;
|
|
|
160 V1 : Access_5 := new C761002_0.Global;
|
|
|
161 V2 : Access_5;
|
|
|
162 V3 : Access_5;
|
|
|
163 begin
|
|
|
164 if Fake = 0 then
|
|
|
165 declare
|
|
|
166 type Access_6 is access C761002_0.Second;
|
|
|
167 V6 : Access_6;
|
|
|
168 begin
|
|
|
169 V6 := new C761002_0.Second;
|
|
|
170 goto check;
|
|
|
171 end;
|
|
|
172 else
|
|
|
173 V2 := V1;
|
|
|
174 end if;
|
|
|
175 V3 := V2;
|
|
|
176 <<check>>
|
|
|
177 TCTouch.Validate("S","goto past master end");
|
|
|
178 end With_Goto;
|
|
|
179
|
|
|
180 begin
|
|
|
181 With_Local_Block;
|
|
|
182 TCTouch.Validate("F","Local Block, normal exit, after master");
|
|
|
183
|
|
|
184 With_Local_Block_Return( Report.Ident_Int(0) );
|
|
|
185 TCTouch.Validate("FF","Local Block, return from block");
|
|
|
186
|
|
|
187 With_Goto( Report.Ident_Int(0) );
|
|
|
188 TCTouch.Validate("F","With Goto");
|
|
|
189
|
|
|
190 end Subtest_3;
|
|
|
191
|
|
|
192 procedure Subtest_4 is
|
|
|
193
|
|
|
194 Oops : exception;
|
|
|
195
|
|
|
196 procedure Alley( Fake: Integer ) is
|
|
|
197 type Access_1 is access C761002_0.Global;
|
|
|
198 V1 : Access_1;
|
|
|
199 begin
|
|
|
200 V1 := new C761002_0.Global;
|
|
|
201 if Fake = 1 then
|
|
|
202 raise Oops;
|
|
|
203 end if;
|
|
|
204 V1 := null;
|
|
|
205 end Alley;
|
|
|
206
|
|
|
207 begin
|
|
|
208 Catch: begin
|
|
|
209 Alley( Report.Ident_Int(1) );
|
|
|
210 exception
|
|
|
211 when Oops => TCTouch.Validate("F","leaving via exception");
|
|
|
212 when others => Report.Failed("Wrong exception");
|
|
|
213 end Catch;
|
|
|
214 end Subtest_4;
|
|
|
215
|
|
|
216 begin -- Main test procedure.
|
|
|
217
|
|
|
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" );
|
|
|
223
|
|
|
224 Subtest_1;
|
|
|
225 -- leaving the scope of the access type should finalize the
|
|
|
226 -- collection
|
|
|
227 TCTouch.Validate("F","Allocated nested, Subtest 1");
|
|
|
228
|
|
|
229 Subtest_2;
|
|
|
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");
|
|
|
234
|
|
|
235 Subtest_3;
|
|
|
236 -- there should be no remaining finalizations from this subtest
|
|
|
237 TCTouch.Validate("","Localized objects");
|
|
|
238
|
|
|
239 Subtest_4;
|
|
|
240 -- there should be no remaining finalizations from this subtest
|
|
|
241 TCTouch.Validate("","Exception testing");
|
|
|
242
|
|
|
243 Report.Result;
|
|
|
244
|
|
|
245 end C761002;
|
