path: root/gcc/testsuite/ada/acats/tests/c7/c761011.a

-- 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;
         <<Continue>>
            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;