1-- C761011.A
2--
3--                             Grant of Unlimited Rights
4--
5--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
6--     rights in the software and documentation contained herein. Unlimited
7--     rights are the same as those granted by the U.S. Government for older
8--     parts of the Ada Conformity Assessment Test Suite, and are defined
9--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10--     intends to confer upon all recipients unlimited rights equal to those
11--     held by the ACAA. These rights include rights to use, duplicate,
12--     release or disclose the released technical data and computer software
13--     in whole or in part, in any manner and for any purpose whatsoever, and
14--     to have or permit others 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 if a Finalize propagates an exception, other Finalizes due
28--    to be performed are performed.
29--        Case 1: A Finalize invoked due to the end of execution of
30--        a master. (Defect Report 8652/0023, as reflected in Technical
31--        Corrigendum 1).
32--        Case 2: A Finalize invoked due to finalization of an anonymous
33--        object. (Defect Report 8652/0023, as reflected in Technical
34--        Corrigendum 1).
35--        Case 3: A Finalize invoked due to the transfer of control
36--        due to an exit statement.
37--        Case 4: A Finalize invoked due to the transfer of control
38--        due to a goto statement.
39--        Case 5: A Finalize invoked due to the transfer of control
40--        due to a return statement.
41--        Case 6: A Finalize invoked due to the transfer of control
42--        due to raises an exception.
43--
44--
45-- CHANGE HISTORY:
46--    29 JAN 2001   PHL   Initial version
47--    15 MAR 2001   RLB   Readied for release; added optimization blockers.
48--                        Added test cases for paragraphs 18 and 19 of the
49--                        standard (the previous tests were withdrawn).
50--
51--!
52with Ada.Finalization;
53use Ada.Finalization;
54package C761011_0 is
55
56    type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with
57        record
58            Finalized : Boolean := False;
59            case D is
60                when False =>
61                    C1 : Integer;
62                when True =>
63                    C2 : Float;
64            end case;
65        end record;
66
67    function Create (Id : Integer) return Ctrl;
68    procedure Finalize (Obj : in out Ctrl);
69    function Was_Finalized (Id : Integer) return Boolean;
70    procedure Use_It (Obj : in Ctrl);
71       -- Use Obj to prevent optimization.
72
73end C761011_0;
74
75with Report;
76use Report;
77package body C761011_0 is
78
79    User_Error : exception;
80
81    Finalize_Called : array (0 .. 50) of Boolean := (others => False);
82
83    function Create (Id : Integer) return Ctrl is
84        Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2)));
85    begin
86        case Obj.D is
87            when False =>
88                Obj.C1 := Ident_Int (Id);
89            when True =>
90                Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id)));
91        end case;
92        return Obj;
93    end Create;
94
95    procedure Finalize (Obj : in out Ctrl) is
96    begin
97        if not Obj.Finalized then
98            Obj.Finalized := True;
99            if Obj.D then
100                if Integer (Obj.C2 / 2.0) mod Ident_Int (10) =
101                   Ident_Int (3) then
102                    raise User_Error;
103                else
104                    Finalize_Called (Integer (Obj.C2) / 2) := True;
105                end if;
106            else
107                if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then
108                    raise Tasking_Error;
109                else
110                    Finalize_Called (Obj.C1) := True;
111                end if;
112            end if;
113        end if;
114    end Finalize;
115
116    function Was_Finalized (Id : Integer) return Boolean is
117    begin
118        return Finalize_Called (Ident_Int (Id));
119    end Was_Finalized;
120
121    procedure Use_It (Obj : in Ctrl) is
122       -- Use Obj to prevent optimization.
123    begin
124        case Obj.D is
125            when True =>
126                if not Equal (Boolean'Pos(Obj.Finalized),
127                              Boolean'Pos(Obj.Finalized)) then
128                    Failed ("Identity check - 1");
129                end if;
130            when False =>
131                if not Equal (Obj.C1, Obj.C1) then
132                    Failed ("Identity check - 2");
133                end if;
134        end case;
135    end Use_It;
136
137end C761011_0;
138
139with Ada.Exceptions;
140use Ada.Exceptions;
141with Ada.Finalization;
142with C761011_0;
143use C761011_0;
144with Report;
145use Report;
146procedure C761011 is
147begin
148    Test
149       ("C761011",
150        " Check that if a finalize propagates an exception, other finalizes " &
151         "due to be performed are performed");
152
153    Normal: -- Case 1
154        begin
155            declare
156                Obj1 : Ctrl := Create (Ident_Int (1));
157                Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
158                                         D => False,
159                                         Finalized => Ident_Bool (False),
160                                         C1 => Ident_Int (2));
161                Obj3 : Ctrl :=
162                   (Ada.Finalization.Controlled with
163                    D => True,
164                    Finalized => Ident_Bool (False),
165                    C2 => 2.0 * Float (Ident_Int
166                                          (3))); -- Finalization: User_Error
167                Obj4 : Ctrl := Create (Ident_Int (4));
168            begin
169                Comment ("Finalization of normal object");
170                Use_It (Obj1); -- Prevent optimization of Objects.
171                Use_It (Obj2); -- (Critical if AI-147 is adopted.)
172                Use_It (Obj3);
173                Use_It (Obj4);
174            end;
175            Failed ("No exception raised by finalization of normal object");
176        exception
177            when Program_Error =>
178                if not Was_Finalized (Ident_Int (1)) or
179                   not Was_Finalized (Ident_Int (2)) or
180                   not Was_Finalized (Ident_Int (4)) then
181                    Failed ("Missing finalizations - 1");
182                end if;
183            when E: others =>
184                Failed ("Exception " & Exception_Name (E) &
185                        " raised - " & Exception_Message (E) & " - 1");
186        end Normal;
187
188    Anon: -- Case 2
189        begin
190            declare
191                Obj1 : Ctrl := (Ada.Finalization.Controlled with
192                                D => True,
193                                Finalized => Ident_Bool (False),
194                                C2 => 2.0 * Float (Ident_Int (5)));
195                Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
196                                         D => False,
197                                         Finalized => Ident_Bool (False),
198                                         C1 => Ident_Int (6));
199                Obj3 : Ctrl := (Ada.Finalization.Controlled with
200                                D => True,
201                                Finalized => Ident_Bool (False),
202                                C2 => 2.0 * Float (Ident_Int (7)));
203                Obj4 : Ctrl := Create (Ident_Int (8));
204            begin
205                Comment ("Finalization of anonymous object");
206
207                -- The finalization of the anonymous object below will raise
208                -- Tasking_Error.
209                if Create (Ident_Int (10)).C1 /= Ident_Int (10) then
210                    Failed ("Incorrect construction of an anonymous object");
211                end if;
212                Failed ("Anonymous object not finalized at the end of the " &
213                        "enclosing statement");
214                Use_It (Obj1); -- Prevent optimization of Objects.
215                Use_It (Obj2); -- (Critical if AI-147 is adopted.)
216                Use_It (Obj3);
217                Use_It (Obj4);
218            end;
219            Failed ("No exception raised by finalization of an anonymous " &
220                    "object of a function");
221        exception
222            when Program_Error =>
223                if not Was_Finalized (Ident_Int (5)) or
224                   not Was_Finalized (Ident_Int (6)) or
225                   not Was_Finalized (Ident_Int (7)) or
226                   not Was_Finalized (Ident_Int (8)) then
227                    Failed ("Missing finalizations - 2");
228                end if;
229            when E: others =>
230                Failed ("Exception " & Exception_Name (E) &
231                        " raised - " & Exception_Message (E) & " - 2");
232        end Anon;
233
234    An_Exit: -- Case 3
235        begin
236            for Counter in 1 .. 4 loop
237                declare
238                    Obj1 : Ctrl := Create (Ident_Int (11));
239                    Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
240                                             D => False,
241                                             Finalized => Ident_Bool (False),
242                                             C1 => Ident_Int (12));
243                    Obj3 : Ctrl :=
244                        (Ada.Finalization.Controlled with
245                         D => True,
246                         Finalized => Ident_Bool (False),
247                         C2 => 2.0 * Float (
248                               Ident_Int(13))); -- Finalization: User_Error
249                    Obj4 : Ctrl := Create (Ident_Int (14));
250                begin
251                    Comment ("Finalization because of exit of loop");
252
253                    Use_It (Obj1); -- Prevent optimization of Objects.
254                    Use_It (Obj2); -- (Critical if AI-147 is adopted.)
255                    Use_It (Obj3);
256                    Use_It (Obj4);
257
258                    exit when not Ident_Bool (Obj2.D);
259
260                    Failed ("Exit not taken");
261                end;
262            end loop;
263            Failed ("No exception raised by finalization on exit");
264        exception
265            when Program_Error =>
266                if not Was_Finalized (Ident_Int (11)) or
267                   not Was_Finalized (Ident_Int (12)) or
268                   not Was_Finalized (Ident_Int (14)) then
269                    Failed ("Missing finalizations - 3");
270                end if;
271            when E: others =>
272                Failed ("Exception " & Exception_Name (E) &
273                        " raised - " & Exception_Message (E) & " - 3");
274        end An_Exit;
275
276    A_Goto: -- Case 4
277        begin
278            declare
279                Obj1 : Ctrl := Create (Ident_Int (15));
280                Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
281                                         D => False,
282                                         Finalized => Ident_Bool (False),
283                                         C1 => Ident_Int (0));
284                             -- Finalization: Tasking_Error
285                Obj3 : Ctrl := Create (Ident_Int (16));
286                Obj4 : Ctrl := (Ada.Finalization.Controlled with
287                                D => True,
288                                Finalized => Ident_Bool (False),
289                                C2 => 2.0 * Float (Ident_Int (17)));
290            begin
291                Comment ("Finalization because of goto statement");
292
293                Use_It (Obj1); -- Prevent optimization of Objects.
294                Use_It (Obj2); -- (Critical if AI-147 is adopted.)
295                Use_It (Obj3);
296                Use_It (Obj4);
297
298                if Ident_Bool (Obj4.D) then
299                   goto Continue;
300                end if;
301
302                Failed ("Goto not taken");
303            end;
304         <<Continue>>
305            Failed ("No exception raised by finalization on goto");
306        exception
307            when Program_Error =>
308                if not Was_Finalized (Ident_Int (15)) or
309                   not Was_Finalized (Ident_Int (16)) or
310                   not Was_Finalized (Ident_Int (17)) then
311                    Failed ("Missing finalizations - 4");
312                end if;
313            when E: others =>
314                Failed ("Exception " & Exception_Name (E) &
315                        " raised - " & Exception_Message (E) & " - 4");
316        end A_Goto;
317
318    A_Return: -- Case 5
319        declare
320            procedure Do_Something is
321                Obj1 : Ctrl := Create (Ident_Int (18));
322                Obj2 : Ctrl := (Ada.Finalization.Controlled with
323                                D => True,
324                                Finalized => Ident_Bool (False),
325                                C2 => 2.0 * Float (Ident_Int (19)));
326                Obj3 : constant Ctrl := (Ada.Finalization.Controlled with
327                                         D => False,
328                                         Finalized => Ident_Bool (False),
329                                         C1 => Ident_Int (20));
330                             -- Finalization: Tasking_Error
331            begin
332                Comment ("Finalization because of return statement");
333
334                Use_It (Obj1); -- Prevent optimization of Objects.
335                Use_It (Obj2); -- (Critical if AI-147 is adopted.)
336                Use_It (Obj3);
337
338                if not Ident_Bool (Obj3.D) then
339                   return;
340                end if;
341
342                Failed ("Return not taken");
343            end Do_Something;
344        begin
345            Do_Something;
346            Failed ("No exception raised by finalization on return statement");
347        exception
348            when Program_Error =>
349                if not Was_Finalized (Ident_Int (18)) or
350                   not Was_Finalized (Ident_Int (19)) then
351                    Failed ("Missing finalizations - 5");
352                end if;
353            when E: others =>
354                Failed ("Exception " & Exception_Name (E) &
355                        " raised - " & Exception_Message (E) & " - 5");
356        end A_Return;
357
358    Except: -- Case 6
359        declare
360            Funky_Error : exception;
361
362            procedure Do_Something is
363                Obj1 : Ctrl :=
364                    (Ada.Finalization.Controlled with
365                     D => True,
366                     Finalized => Ident_Bool (False),
367                     C2 => 2.0 * Float (
368                           Ident_Int(23))); -- Finalization: User_Error
369                Obj2 : Ctrl := Create (Ident_Int (24));
370                Obj3 : Ctrl := Create (Ident_Int (25));
371                Obj4 : constant Ctrl := (Ada.Finalization.Controlled with
372                                         D => False,
373                                         Finalized => Ident_Bool (False),
374                                         C1 => Ident_Int (26));
375            begin
376                Comment ("Finalization because of exception propagation");
377
378                Use_It (Obj1); -- Prevent optimization of Objects.
379                Use_It (Obj2); -- (Critical if AI-147 is adopted.)
380                Use_It (Obj3);
381                Use_It (Obj4);
382
383                if not Ident_Bool (Obj4.D) then
384                   raise Funky_Error;
385                end if;
386
387                Failed ("Exception not raised");
388            end Do_Something;
389        begin
390            Do_Something;
391            Failed ("No exception raised by finalization on exception " &
392                    "propagation");
393        exception
394            when Program_Error =>
395                if not Was_Finalized (Ident_Int (24)) or
396                   not Was_Finalized (Ident_Int (25)) or
397                   not Was_Finalized (Ident_Int (26)) then
398                    Failed ("Missing finalizations - 6");
399                end if;
400            when Funky_Error =>
401                Failed ("Wrong exception propagated");
402                    -- Should be Program_Error (7.6.1(19)).
403            when E: others =>
404                Failed ("Exception " & Exception_Name (E) &
405                        " raised - " & Exception_Message (E) & " - 6");
406        end Except;
407
408    Result;
409end C761011;
410
411