Subversion Repositories openrisc_me

-- C761012.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 an anonymous object is finalized with its enclosing master if

--    a transfer of control or exception occurs prior to performing its normal

--    finalization.  (Defect Report 8652/0023, as reflected in

--    Technical Corrigendum 1, RM95 7.6.1(13.1/1)).

--

-- CHANGE HISTORY:

--    29 JAN 2001   PHL   Initial version.

--     5 DEC 2001   RLB   Reformatted for ACATS.

--

--!

with Ada.Finalization;

use Ada.Finalization;

package C761012_0 is

    type Ctrl (D : Boolean) is new Controlled with

        record

            case D is

                when False =>

                    C1 : Integer;

                when True =>

                    C2 : Float;

            end case;

        end record;

    function Create return Ctrl;

    procedure Finalize (Obj : in out Ctrl);

    function Finalize_Was_Called return Boolean;

end C761012_0;

with Report;

use Report;

package body C761012_0 is

    Finalization_Flag : Boolean := False;

    function Create return Ctrl is

        Obj : Ctrl (Ident_Bool (True));

    begin

        Obj.C2 := 3.0;

        return Obj;

    end Create;

    procedure Finalize (Obj : in out Ctrl) is

    begin

        Finalization_Flag := True;

    end Finalize;

    function Finalize_Was_Called return Boolean is

    begin

        if Finalization_Flag then

            Finalization_Flag := False;

            return True;

        else

            return False;

        end if;

    end Finalize_Was_Called;

end C761012_0;

with Ada.Exceptions;

use Ada.Exceptions;

with C761012_0;

use C761012_0;

with Report;

use Report;

procedure C761012 is

begin

    Test ("C761012",

          "Check that an anonymous object is finalized with its enclosing " &

             "master if a transfer of control or exception occurs prior to " &

             "performing its normal finalization");

    Excep:

        begin

            declare

                I : Integer := Create.C1; -- Raises Constraint_Error

            begin

                Failed

                   ("Improper component selection did not raise Constraint_Error, I =" &

                    Integer'Image (I));

            exception

                when Constraint_Error =>

                    Failed ("Constraint_Error caught by the wrong handler");

            end;

            Failed ("Transfer of control did not happen correctly");

        exception

            when Constraint_Error =>

                if not Finalize_Was_Called then

                    Failed ("Finalize wasn't called when the master was left " &

                            "- Constraint_Error");

                end if;

            when E: others =>

                Failed ("Exception " & Exception_Name (E) &

                        " raised - " & Exception_Information (E));

        end Excep;

    Transfer:

        declare

            Finalize_Was_Called_Before_Leaving_Exit : Boolean;

        begin

            begin

                loop

                    exit when Create.C2 = 3.0;

                end loop;

                Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called;

                if Finalize_Was_Called_Before_Leaving_Exit then

                    Comment ("Finalize called before the transfer of control");

                end if;

            end;

            if not Finalize_Was_Called and then

               not Finalize_Was_Called_Before_Leaving_Exit then

                Failed ("Finalize wasn't called when the master was left " &

                        "- transfer of control");

            end if;

        end Transfer;

    Result;

end C761012;