Subversion Repositories openrisc

-- C761002.A

--

--                             Grant of Unlimited Rights

--

--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,

--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained

--     unlimited rights in the software and documentation contained herein.

--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making

--     this public release, the Government intends to confer upon all

--     recipients unlimited rights  equal to those held by the Government.

--     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 objects of a controlled type that are created

--      by an allocator are finalized at the appropriate time.  In

--      particular, check that such objects are not finalized due to

--      completion of the master in which they were allocated if the

--      corresponding access type is declared outside of that master.

--

--      Check that Unchecked_Deallocation of a controlled

--      object causes finalization of that object.

--

-- TEST DESCRIPTION:

--      This test derives a type from Ada.Finalization.Controlled, and

--      declares access types to that type in various scope scenarios.

--      The dispatching procedure Finalize is redefined for the derived

--      type to perform a check that it has been called at the

--      correct time.  This is accomplished using a global variable

--      which indicates what state the software is currently

--      executing.  The test utilizes the TCTouch facilities to

--      verify that Finalize is called the correct number of times, at

--      the correct times.  Several calls are made to validate passing

--      the null string to check that Finalize has NOT been called at

--      that point.

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

--!

with Ada.Finalization;

package C761002_0 is

  type Global is new Ada.Finalization.Controlled with null record;

  procedure Finalize( It: in out Global );

  type Second is new Ada.Finalization.Limited_Controlled with null record;

  procedure Finalize( It: in out Second );

end C761002_0;

with Report;

with TCTouch;

package body C761002_0 is

  procedure Finalize( It: in out Global ) is

  begin

    TCTouch.Touch('F');  ------------------------------------------------- F

  end Finalize;

  procedure Finalize( It: in out Second ) is

  begin

    TCTouch.Touch('S');  ------------------------------------------------- S

  end Finalize;

end C761002_0;

with Report;

with TCTouch;

with C761002_0;

with Unchecked_Deallocation;

procedure C761002 is

  -- check the straightforward case

  procedure Subtest_1 is

    type Access_1 is access C761002_0.Global;

    V1 : Access_1;

    procedure Allocate is

      V2 : Access_1;

    begin

      V2 := new C761002_0.Global;

      V1 := V2;  -- "dead" assignment must not be optimized away due to

                 -- finalization "side effects", many more of these follow

    end Allocate;

  begin

    Allocate;

    -- no calls to Finalize should have occurred at this point

    TCTouch.Validate("","Allocated nested, retained");

  end Subtest_1;

  -- check Unchecked_Deallocation

  procedure Subtest_2 is

    type Access_2 is access C761002_0.Global;

    procedure Free is

              new Unchecked_Deallocation(C761002_0.Global, Access_2);

    V1 : Access_2;

    V2 : Access_2;

    procedure Allocate is

    begin

      V1 := new C761002_0.Global;

      V2 := new C761002_0.Global;

    end Allocate;

  begin

    Allocate;

    -- no calls to Finalize should have occurred at this point.

    TCTouch.Validate("","Allocated nested, non-local");

    Free(V1); -- instance of Unchecked_Deallocation

    -- should cause the finalization of V1.all

    TCTouch.Validate("F","Unchecked Deallocation");

  end Subtest_2; -- leaving this scope should cause the finalization of V2.all

  -- check various master-exit scenarios

  -- the "Fake" parameters are used to avoid unwanted optimizations

  procedure Subtest_3 is

    procedure With_Local_Block is

      type Access_3 is access C761002_0.Global;

      V1 : Access_3;

    begin

      declare

        V2 : Access_3 := new C761002_0.Global;

      begin

        V1 := V2;

      end;

      TCTouch.Validate("","Local Block, normal exit");

      -- the allocated object should be finalized on leaving this scope

    end With_Local_Block;

    procedure With_Local_Block_Return(Fake: Integer) is

      type Access_4 is access C761002_0.Global;

      V1 : Access_4 := new C761002_0.Global;

    begin

      if Fake = 0 then

        declare

          V2 : Access_4;

        begin

          V2 := new C761002_0.Global;

          return; -- the two allocated objects should be finalized

        end;      -- upon leaving this scope

      else

        V1 := null;

      end if;

    end With_Local_Block_Return;

    procedure With_Goto(Fake: Integer) is

      type Access_5 is access C761002_0.Global;

      V1 : Access_5 := new C761002_0.Global;

      V2 : Access_5;

      V3 : Access_5;

    begin

      if Fake = 0 then

        declare

          type Access_6 is access C761002_0.Second;

          V6 : Access_6;

        begin

          V6 := new C761002_0.Second;

          goto check;

        end;

      else

        V2 := V1;

      end if;

      V3 := V2;

<>

      TCTouch.Validate("S","goto past master end");

     end With_Goto;

  begin

    With_Local_Block;

    TCTouch.Validate("F","Local Block, normal exit, after master");

    With_Local_Block_Return( Report.Ident_Int(0) );

    TCTouch.Validate("FF","Local Block, return from block");

    With_Goto( Report.Ident_Int(0) );

    TCTouch.Validate("F","With Goto");

  end Subtest_3;

  procedure Subtest_4 is

    Oops : exception;

    procedure Alley( Fake: Integer ) is

      type Access_1 is access C761002_0.Global;

      V1 : Access_1;

    begin

      V1 := new C761002_0.Global;

      if Fake = 1 then

        raise Oops;

      end if;

      V1 := null;

    end Alley;

  begin

    Catch: begin

      Alley( Report.Ident_Int(1) );

    exception

      when Oops   => TCTouch.Validate("F","leaving via exception");

      when others => Report.Failed("Wrong exception");

    end Catch;

  end Subtest_4;

begin  -- Main test procedure.

  Report.Test ("C761002", "Check that objects of a controlled type created "

                        & "by an allocator are finalized appropriately. "

                        & "Check that Unchecked_Deallocation of a "

                        & "controlled object causes finalization "

                        & "of that object" );

  Subtest_1;

  -- leaving the scope of the access type should finalize the

  -- collection

  TCTouch.Validate("F","Allocated nested, Subtest 1");

  Subtest_2;

  -- Unchecked_Deallocation already finalized one of the two

  -- objects allocated, the other should be the only one finalized

  -- at leaving the scope of the access type.

  TCTouch.Validate("F","Allocated non-local");

  Subtest_3;

  -- there should be no remaining finalizations from this subtest

  TCTouch.Validate("","Localized objects");

  Subtest_4;

  -- there should be no remaining finalizations from this subtest

  TCTouch.Validate("","Exception testing");

  Report.Result;

end C761002;