-- C761011.A -- -- Grant of Unlimited Rights -- -- The Ada Conformity Assessment Authority (ACAA) holds unlimited -- rights in the software and documentation contained herein. Unlimited -- rights are the same as those granted by the U.S. Government for older -- parts of the Ada Conformity Assessment Test Suite, and are defined -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA -- intends to confer upon all recipients unlimited rights equal to those -- held by the ACAA. These rights include rights to use, duplicate, -- release or disclose the released technical data and computer software -- in whole or in part, in any manner and for any purpose whatsoever, and -- to have or permit others to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. --* -- -- OBJECTIVE: -- Check that if a Finalize propagates an exception, other Finalizes due -- to be performed are performed. -- Case 1: A Finalize invoked due to the end of execution of -- a master. (Defect Report 8652/0023, as reflected in Technical -- Corrigendum 1). -- Case 2: A Finalize invoked due to finalization of an anonymous -- object. (Defect Report 8652/0023, as reflected in Technical -- Corrigendum 1). -- Case 3: A Finalize invoked due to the transfer of control -- due to an exit statement. -- Case 4: A Finalize invoked due to the transfer of control -- due to a goto statement. -- Case 5: A Finalize invoked due to the transfer of control -- due to a return statement. -- Case 6: A Finalize invoked due to the transfer of control -- due to raises an exception. -- -- -- CHANGE HISTORY: -- 29 JAN 2001 PHL Initial version -- 15 MAR 2001 RLB Readied for release; added optimization blockers. -- Added test cases for paragraphs 18 and 19 of the -- standard (the previous tests were withdrawn). -- --! with Ada.Finalization; use Ada.Finalization; package C761011_0 is type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with record Finalized : Boolean := False; case D is when False => C1 : Integer; when True => C2 : Float; end case; end record; function Create (Id : Integer) return Ctrl; procedure Finalize (Obj : in out Ctrl); function Was_Finalized (Id : Integer) return Boolean; procedure Use_It (Obj : in Ctrl); -- Use Obj to prevent optimization. end C761011_0; with Report; use Report; package body C761011_0 is User_Error : exception; Finalize_Called : array (0 .. 50) of Boolean := (others => False); function Create (Id : Integer) return Ctrl is Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2))); begin case Obj.D is when False => Obj.C1 := Ident_Int (Id); when True => Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id))); end case; return Obj; end Create; procedure Finalize (Obj : in out Ctrl) is begin if not Obj.Finalized then Obj.Finalized := True; if Obj.D then if Integer (Obj.C2 / 2.0) mod Ident_Int (10) = Ident_Int (3) then raise User_Error; else Finalize_Called (Integer (Obj.C2) / 2) := True; end if; else if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then raise Tasking_Error; else Finalize_Called (Obj.C1) := True; end if; end if; end if; end Finalize; function Was_Finalized (Id : Integer) return Boolean is begin return Finalize_Called (Ident_Int (Id)); end Was_Finalized; procedure Use_It (Obj : in Ctrl) is -- Use Obj to prevent optimization. begin case Obj.D is when True => if not Equal (Boolean'Pos(Obj.Finalized), Boolean'Pos(Obj.Finalized)) then Failed ("Identity check - 1"); end if; when False => if not Equal (Obj.C1, Obj.C1) then Failed ("Identity check - 2"); end if; end case; end Use_It; end C761011_0; with Ada.Exceptions; use Ada.Exceptions; with Ada.Finalization; with C761011_0; use C761011_0; with Report; use Report; procedure C761011 is begin Test ("C761011", " Check that if a finalize propagates an exception, other finalizes " & "due to be performed are performed"); Normal: -- Case 1 begin declare Obj1 : Ctrl := Create (Ident_Int (1)); Obj2 : constant Ctrl := (Ada.Finalization.Controlled with D => False, Finalized => Ident_Bool (False), C1 => Ident_Int (2)); Obj3 : Ctrl := (Ada.Finalization.Controlled with D => True, Finalized => Ident_Bool (False), C2 => 2.0 * Float (Ident_Int (3))); -- Finalization: User_Error Obj4 : Ctrl := Create (Ident_Int (4)); begin Comment ("Finalization of normal object"); Use_It (Obj1); -- Prevent optimization of Objects. Use_It (Obj2); -- (Critical if AI-147 is adopted.) Use_It (Obj3); Use_It (Obj4); end; Failed ("No exception raised by finalization of normal object"); exception when Program_Error => if not Was_Finalized (Ident_Int (1)) or not Was_Finalized (Ident_Int (2)) or not Was_Finalized (Ident_Int (4)) then Failed ("Missing finalizations - 1"); end if; when E: others => Failed ("Exception " & Exception_Name (E) & " raised - " & Exception_Message (E) & " - 1"); end Normal; Anon: -- Case 2 begin declare Obj1 : Ctrl := (Ada.Finalization.Controlled with D => True, Finalized => Ident_Bool (False), C2 => 2.0 * Float (Ident_Int (5))); Obj2 : constant Ctrl := (Ada.Finalization.Controlled with D => False, Finalized => Ident_Bool (False), C1 => Ident_Int (6)); Obj3 : Ctrl := (Ada.Finalization.Controlled with D => True, Finalized => Ident_Bool (False), C2 => 2.0 * Float (Ident_Int (7))); Obj4 : Ctrl := Create (Ident_Int (8)); begin Comment ("Finalization of anonymous object"); -- The finalization of the anonymous object below will raise -- Tasking_Error. if Create (Ident_Int (10)).C1 /= Ident_Int (10) then Failed ("Incorrect construction of an anonymous object"); end if; Failed ("Anonymous object not finalized at the end of the " & "enclosing statement"); Use_It (Obj1); -- Prevent optimization of Objects. Use_It (Obj2); -- (Critical if AI-147 is adopted.) Use_It (Obj3); Use_It (Obj4); end; Failed ("No exception raised by finalization of an anonymous " & "object of a function"); exception when Program_Error => if not Was_Finalized (Ident_Int (5)) or not Was_Finalized (Ident_Int (6)) or not Was_Finalized (Ident_Int (7)) or not Was_Finalized (Ident_Int (8)) then Failed ("Missing finalizations - 2"); end if; when E: others => Failed ("Exception " & Exception_Name (E) & " raised - " & Exception_Message (E) & " - 2"); end Anon; An_Exit: -- Case 3 begin for Counter in 1 .. 4 loop declare Obj1 : Ctrl := Create (Ident_Int (11)); Obj2 : constant Ctrl := (Ada.Finalization.Controlled with D => False, Finalized => Ident_Bool (False), C1 => Ident_Int (12)); Obj3 : Ctrl := (Ada.Finalization.Controlled with D => True, Finalized => Ident_Bool (False), C2 => 2.0 * Float ( Ident_Int(13))); -- Finalization: User_Error Obj4 : Ctrl := Create (Ident_Int (14)); begin Comment ("Finalization because of exit of loop"); Use_It (Obj1); -- Prevent optimization of Objects. Use_It (Obj2); -- (Critical if AI-147 is adopted.) Use_It (Obj3); Use_It (Obj4); exit when not Ident_Bool (Obj2.D); Failed ("Exit not taken"); end; end loop; Failed ("No exception raised by finalization on exit"); exception when Program_Error => if not Was_Finalized (Ident_Int (11)) or not Was_Finalized (Ident_Int (12)) or not Was_Finalized (Ident_Int (14)) then Failed ("Missing finalizations - 3"); end if; when E: others => Failed ("Exception " & Exception_Name (E) & " raised - " & Exception_Message (E) & " - 3"); end An_Exit; A_Goto: -- Case 4 begin declare Obj1 : Ctrl := Create (Ident_Int (15)); Obj2 : constant Ctrl := (Ada.Finalization.Controlled with D => False, Finalized => Ident_Bool (False), C1 => Ident_Int (0)); -- Finalization: Tasking_Error Obj3 : Ctrl := Create (Ident_Int (16)); Obj4 : Ctrl := (Ada.Finalization.Controlled with D => True, Finalized => Ident_Bool (False), C2 => 2.0 * Float (Ident_Int (17))); begin Comment ("Finalization because of goto statement"); Use_It (Obj1); -- Prevent optimization of Objects. Use_It (Obj2); -- (Critical if AI-147 is adopted.) Use_It (Obj3); Use_It (Obj4); if Ident_Bool (Obj4.D) then goto Continue; end if; Failed ("Goto not taken"); end; <> Failed ("No exception raised by finalization on goto"); exception when Program_Error => if not Was_Finalized (Ident_Int (15)) or not Was_Finalized (Ident_Int (16)) or not Was_Finalized (Ident_Int (17)) then Failed ("Missing finalizations - 4"); end if; when E: others => Failed ("Exception " & Exception_Name (E) & " raised - " & Exception_Message (E) & " - 4"); end A_Goto; A_Return: -- Case 5 declare procedure Do_Something is Obj1 : Ctrl := Create (Ident_Int (18)); Obj2 : Ctrl := (Ada.Finalization.Controlled with D => True, Finalized => Ident_Bool (False), C2 => 2.0 * Float (Ident_Int (19))); Obj3 : constant Ctrl := (Ada.Finalization.Controlled with D => False, Finalized => Ident_Bool (False), C1 => Ident_Int (20)); -- Finalization: Tasking_Error begin Comment ("Finalization because of return statement"); Use_It (Obj1); -- Prevent optimization of Objects. Use_It (Obj2); -- (Critical if AI-147 is adopted.) Use_It (Obj3); if not Ident_Bool (Obj3.D) then return; end if; Failed ("Return not taken"); end Do_Something; begin Do_Something; Failed ("No exception raised by finalization on return statement"); exception when Program_Error => if not Was_Finalized (Ident_Int (18)) or not Was_Finalized (Ident_Int (19)) then Failed ("Missing finalizations - 5"); end if; when E: others => Failed ("Exception " & Exception_Name (E) & " raised - " & Exception_Message (E) & " - 5"); end A_Return; Except: -- Case 6 declare Funky_Error : exception; procedure Do_Something is Obj1 : Ctrl := (Ada.Finalization.Controlled with D => True, Finalized => Ident_Bool (False), C2 => 2.0 * Float ( Ident_Int(23))); -- Finalization: User_Error Obj2 : Ctrl := Create (Ident_Int (24)); Obj3 : Ctrl := Create (Ident_Int (25)); Obj4 : constant Ctrl := (Ada.Finalization.Controlled with D => False, Finalized => Ident_Bool (False), C1 => Ident_Int (26)); begin Comment ("Finalization because of exception propagation"); Use_It (Obj1); -- Prevent optimization of Objects. Use_It (Obj2); -- (Critical if AI-147 is adopted.) Use_It (Obj3); Use_It (Obj4); if not Ident_Bool (Obj4.D) then raise Funky_Error; end if; Failed ("Exception not raised"); end Do_Something; begin Do_Something; Failed ("No exception raised by finalization on exception " & "propagation"); exception when Program_Error => if not Was_Finalized (Ident_Int (24)) or not Was_Finalized (Ident_Int (25)) or not Was_Finalized (Ident_Int (26)) then Failed ("Missing finalizations - 6"); end if; when Funky_Error => Failed ("Wrong exception propagated"); -- Should be Program_Error (7.6.1(19)). when E: others => Failed ("Exception " & Exception_Name (E) & " raised - " & Exception_Message (E) & " - 6"); end Except; Result; end C761011;