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 Program_Error is raised when:
28 -- * an exception is raised if Finalize invoked as part of an
29 -- assignment operation; or
30 -- * an exception is raised if Adjust invoked as part of an assignment
31 -- operation, after any other adjustment due to be performed are
33 -- * an exception is raised if Finalize invoked as part of a call on
34 -- Unchecked_Deallocation, after any other finalizations to be
35 -- performed are performed.
38 -- This test defines these four controlled types:
43 -- The type name conveys the associated failure. The operations in type
44 -- good will "touch" the boolean array indicating correct path
45 -- utilization for the purposes of checking "other <operations> are
46 -- performed", where <operations> ::= initialization, adjusting, and
52 -- 12 APR 94 SAIC Initial version
53 -- 02 MAY 96 SAIC Visibility fixed for 2.1
54 -- 13 FEB 97 PWB.CTA Corrected value of Events_Occurring at line 286
55 -- 01 DEC 97 EDS Made correction wrt RM 7.6(21)
56 -- 16 MAR 01 RLB Corrected Adjust cases to avoid problems with
57 -- RM 7.6.1(16/1) from Technical Corrigendum 1.
61 ------------------------------------------------------------- C761006_Support
63 package C761006_Support
is
65 type Events
is ( Good_Initialize
, Good_Adjust
, Good_Finalize
);
67 type Event_Array
is array(Events
) of Boolean;
69 Events_Occurring
: Event_Array
:= (others => False);
71 Propagating_Exception
: exception;
73 procedure Raise_Propagating_Exception
(Do_It
: Boolean);
75 function Unique_Value
return Natural;
79 ------------------------------------------------------------- C761006_Support
82 package body C761006_Support
is
84 procedure Raise_Propagating_Exception
(Do_It
: Boolean) is
86 if Report
.Ident_Bool
(Do_It
) then
87 raise Propagating_Exception
;
89 end Raise_Propagating_Exception
;
93 function Unique_Value
return Natural is
101 ------------------------------------------------------------------- C761006_0
103 with Ada
.Finalization
;
104 with C761006_Support
;
107 type Good
is new Ada
.Finalization
.Controlled
109 Initialized
: Boolean := False;
110 Adjusted
: Boolean := False;
111 Unique
: Natural := C761006_Support
.Unique_Value
;
114 procedure Initialize
( It
: in out Good
);
115 procedure Adjust
( It
: in out Good
);
116 procedure Finalize
( It
: in out Good
);
118 type Bad_Initialize
is private;
120 type Bad_Adjust
is private;
122 type Bad_Finalize
is private;
124 Inits_Order
: String(1..255);
125 Inits_Called
: Natural := 0;
127 type Bad_Initialize
is new Ada
.Finalization
.Controlled
129 procedure Initialize
( It
: in out Bad_Initialize
);
131 type Bad_Adjust
is new Ada
.Finalization
.Controlled
133 procedure Adjust
( It
: in out Bad_Adjust
);
136 new Ada
.Finalization
.Controlled
with null record;
137 procedure Finalize
( It
: in out Bad_Finalize
);
140 ------------------------------------------------------------------- C761006_1
142 with Ada
.Finalization
;
146 type Init_Check_Root
is new Ada
.Finalization
.Controlled
with record
147 Good_Component
: C761006_0
.Good
;
148 Init_Fails
: C761006_0
.Bad_Initialize
;
151 type Adj_Check_Root
is new Ada
.Finalization
.Controlled
with record
152 Good_Component
: C761006_0
.Good
;
153 Adj_Fails
: C761006_0
.Bad_Adjust
;
156 type Fin_Check_Root
is new Ada
.Finalization
.Controlled
with record
157 Good_Component
: C761006_0
.Good
;
158 Fin_Fails
: C761006_0
.Bad_Finalize
;
163 ------------------------------------------------------------------- C761006_2
168 type Init_Check
is new C761006_1
.Init_Check_Root
with null record;
169 type Adj_Check
is new C761006_1
.Adj_Check_Root
with null record;
170 type Fin_Check
is new C761006_1
.Fin_Check_Root
with null record;
174 ------------------------------------------------------------------- C761006_0
177 with C761006_Support
;
178 package body C761006_0
is
180 package Sup
renames C761006_Support
;
182 procedure Initialize
( It
: in out Good
) is
184 Sup
.Events_Occurring
( Sup
.Good_Initialize
) := True;
185 It
.Initialized
:= True;
188 procedure Adjust
( It
: in out Good
) is
190 Sup
.Events_Occurring
( Sup
.Good_Adjust
) := True;
192 It
.Unique
:= C761006_Support
.Unique_Value
;
195 procedure Finalize
( It
: in out Good
) is
197 Sup
.Events_Occurring
( Sup
.Good_Finalize
) := True;
200 procedure Initialize
( It
: in out Bad_Initialize
) is
202 Sup
.Raise_Propagating_Exception
(Report
.Ident_Bool
(True));
205 procedure Adjust
( It
: in out Bad_Adjust
) is
207 Sup
.Raise_Propagating_Exception
(Report
.Ident_Bool
(True));
210 procedure Finalize
( It
: in out Bad_Finalize
) is
212 Sup
.Raise_Propagating_Exception
(Report
.Ident_Bool
(True));
217 --------------------------------------------------------------------- C761006
222 with C761006_Support
;
224 with Ada
.Finalization
;
225 with Unchecked_Deallocation
;
228 package Sup
renames C761006_Support
;
229 use type Sup
.Event_Array
;
231 type Procedure_Handle
is access procedure;
233 type Test_ID
is ( Simple
, Initialize
, Adjust
, Finalize
);
235 Sub_Tests
: array(Test_ID
) of Procedure_Handle
;
237 procedure Simple_Test
is
238 A_Good_Object
: C761006_0
.Good
; -- should call Initialize
240 if not A_Good_Object
.Initialized
then
241 Report
.Failed
("Good object not initialized");
244 -- should call Adjust
245 A_Good_Object
:= ( Ada
.Finalization
.Controlled
246 with Unique
=> 0, others => False );
247 if not A_Good_Object
.Adjusted
then
248 Report
.Failed
("Good object not adjusted");
251 -- should call Finalize before end of scope
254 procedure Initialize_Test
is
257 This_Object_Fails_In_Initialize
: C761006_2
.Init_Check
;
259 Report
.Failed
("Exception in Initialize did not occur");
262 Report
.Failed
("Initialize caused exception at wrong lex");
265 Report
.Failed
("Error in execution sequence");
268 when Sup
.Propagating_Exception
=> -- this is correct
269 if not Sup
.Events_Occurring
(Sup
.Good_Initialize
) then
270 Report
.Failed
("Initialization of Good Component did not occur");
274 procedure Adjust_Test
is
275 This_Object_OK
: C761006_2
.Adj_Check
;
276 This_Object_Target
: C761006_2
.Adj_Check
;
279 Check_Adjust_Due_To_Assignment
: begin
280 This_Object_Target
:= This_Object_OK
;
281 Report
.Failed
("Adjust did not propagate any exception");
283 when Program_Error
=> -- expected case
284 if not This_Object_Target
.Good_Component
.Adjusted
then
285 Report
.Failed
("other adjustment not performed");
288 Report
.Failed
("Adjust propagated wrong exception");
289 end Check_Adjust_Due_To_Assignment
;
291 C761006_Support
.Events_Occurring
:= (True, False, False);
293 Check_Adjust_Due_To_Initial_Assignment
: declare
294 Another_Target
: C761006_2
.Adj_Check
:= This_Object_OK
;
296 Report
.Failed
("Adjust did not propagate any exception");
298 when others => Report
.Failed
("Adjust caused exception at wrong lex");
299 end Check_Adjust_Due_To_Initial_Assignment
;
302 when Program_Error
=> -- expected case
303 if Sup
.Events_Occurring
(Sup
.Good_Finalize
) /=
304 Sup
.Events_Occurring
(Sup
.Good_Adjust
) then
305 -- RM 7.6.1(16/1) says that the good Adjust may or may not
306 -- be performed; but if it is, then the Finalize must be
307 -- performed; and if it is not, then the Finalize must not
309 if Sup
.Events_Occurring
(Sup
.Good_Finalize
) then
310 Report
.Failed
("Good adjust not performed with bad adjust, " &
311 "but good finalize was");
313 Report
.Failed
("Good adjust performed with bad adjust, " &
314 "but good finalize was not");
318 Report
.Failed
("Adjust propagated wrong exception");
321 procedure Finalize_Test
is
323 Fin_Not_Perf
: constant String := "other finalizations not performed";
325 procedure Finalize_15
is
326 Item
: C761006_2
.Fin_Check
;
327 Target
: C761006_2
.Fin_Check
;
331 -- finalization of Item should cause PE
332 -- ARM7.6:21 allows the implementation to omit the assignment of the
333 -- value into an anonymous object, which is the point at which Adjust
334 -- is normally called. However, this would result in Program_Error's
335 -- being raised before the call to Adjust, with the consequence that
336 -- Adjust is never called.
339 when Program_Error
=> -- expected case
340 if not Sup
.Events_Occurring
(Sup
.Good_Finalize
) then
341 Report
.Failed
("Assignment: " & Fin_Not_Perf
);
344 Report
.Failed
("Other exception in Finalize_15");
346 -- finalization of Item/Target should cause PE
349 -- check failure in finalize due to Unchecked_Deallocation
351 type Shark
is access C761006_2
.Fin_Check
;
354 new Unchecked_Deallocation
( C761006_2
.Fin_Check
, Shark
);
356 procedure Finalize_17
is
357 White
: Shark
:= new C761006_2
.Fin_Check
;
361 when Program_Error
=>
362 if not Sup
.Events_Occurring
(Sup
.Good_Finalize
) then
363 Report
.Failed
("Unchecked_Deallocation: " & Fin_Not_Perf
);
369 Exception_In_Finalization
: begin
372 when Program_Error
=> null; -- anticipated
373 end Exception_In_Finalization
;
375 Use_Of_Unchecked_Deallocation
: begin
379 Report
.Failed
("Unchecked_Deallocation check, unwanted exception");
380 end Use_Of_Unchecked_Deallocation
;
384 begin -- Main test procedure.
386 Report
.Test
("C761006", "Check that exceptions raised in Initialize, " &
387 "Adjust and Finalize are processed correctly" );
389 Sub_Tests
:= (Simple_Test
'Access, Initialize_Test
'Access,
390 Adjust_Test
'Access, Finalize_Test
'Access);
392 for Test
in Sub_Tests
'Range loop
395 Sup
.Events_Occurring
:= (others => False);
400 when Simple | Adjust
=>
401 if Sup
.Events_Occurring
/= Sup
.Event_Array
' ( others => True ) then
402 Report.Failed ( "Other operation missing in " &
403 Test_ID'Image ( Test ) );
408 -- Note that for Good_Adjust, we may get either True or False
409 if Sup.Events_Occurring ( Sup.Good_Initialize ) = False or
410 Sup.Events_Occurring ( Sup.Good_Finalize ) = False
412 Report.Failed ( "Other operation missing in " &
413 Test_ID'Image ( Test ) );
418 when How: others => Report.Failed( Ada.Exceptions.Exception_Name( How )
419 & " from " & Test_ID'Image( Test ) );