Subversion Repositories openrisc

-- C760011.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 the anonymous objects of a controlled type associated with

--      function results and aggregates are finalized no later than the

--      end of the innermost enclosing declarative_item or statement.  Also

--      check this for function calls and aggregates of a noncontrolled type

--      with controlled components.

--

-- TEST DESCRIPTION:

--      This test defines a controlled type with a discriminant, the

--      discriminant is use as an index into a global table to indicate that

--      the object has been finalized.  The controlled type is used as the

--      component of a non-controlled type, and the non-controlled type is

--      used for the same set of tests.  Following is a table of the tests

--      performed and their associated tag character.

--

--      7.6(21) allows for the optimizations that remove these temporary

--      objects from ever existing.  As such this test checks that in the

--      case the object was initialized (the only access we have to

--      determining if it ever existed) it must subsequently be finalized.

--

-- CASE TABLE:

--      A - aggregate test, controlled

--      B - aggregate test, controlled

--      C - aggregate test, non_controlled

--      D - function test, controlled

--      E - function test, non_controlled

--      F - formal parameter function test, controlled

--      G - formal parameter aggregate test, controlled

--      H - formal parameter function test, non_controlled

--      I - formal parameter aggregate test, non_controlled

--

--      X - scratch object, not consequential to the objective

--      Y - scratch object, not consequential to the objective

--      Z - scratch object, not consequential to the objective

--

--

-- CHANGE HISTORY:

--      22 MAY 95   SAIC    Initial version

--      24 APR 96   SAIC    Minor doc fixes, visibility patch

--      14 NOV 96   SAIC    Revised for release 2.1

--

--!

------------------------------------------------------------------- C760011_0

with Ada.Finalization;

package C760011_0 is

  type Tracking_Array is array(Character range 'A'..'Z') of Boolean;

  Initialized : Tracking_Array := (others => False);

  Finalized   : Tracking_Array := (others => False);

  type Controlled_Type(Tag : Character) is

    new Ada.Finalization.Controlled with record

      TC_Component : String(1..4) := "ACVC";

    end record;

  procedure Initialize( It: in out Controlled_Type );

  procedure Finalize  ( It: in out Controlled_Type );

  function Create(With_Tag: Character) return Controlled_Type;

  type Non_Controlled(Tag : Character := 'Y') is record

    Controlled_Component : Controlled_Type(Tag);

  end record;

  procedure Initialize( It: in out Non_Controlled );

  procedure Finalize  ( It: in out Non_Controlled );

  function Create(With_Tag: Character) return Non_Controlled;

  Under_Debug : constant Boolean := False;  -- construction lines

end C760011_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;

package body C760011_0 is

  procedure Initialize( It: in out Controlled_Type ) is

  begin

    It.TC_Component := (others => It.Tag);

    if It.Tag in Tracking_Array'Range then

      Initialized(It.Tag) := True;

    end if;

    if Under_Debug then

      Report.Comment("Initializing Tag: " & It.Tag );

    end if;

  end Initialize;

  procedure Finalize( It: in out Controlled_Type ) is

  begin

    if Under_Debug then

      Report.Comment("Finalizing for Tag: " & It.Tag );

    end if;

    if It.Tag in Finalized'Range then

      Finalized(It.Tag) := True;

    end if;

  end Finalize;

  function Create(With_Tag: Character) return Controlled_Type is

  begin

    return Controlled_Type'(Ada.Finalization.Controlled

                            with Tag          => With_Tag,

                                 TC_Component => "*CON" );

  end Create;

  procedure Initialize( It: in out Non_Controlled ) is

  begin

    Report.Failed("Called Initialize for Non_Controlled");

  end Initialize;

  procedure Finalize( It: in out Non_Controlled ) is

  begin

    Report.Failed("Called Finalize for Non_Controlled");

  end Finalize;

  function Create(With_Tag: Character) return Non_Controlled is

  begin

    return Non_Controlled'(Tag => With_Tag, Controlled_Component => (

                                  Ada.Finalization.Controlled

                                    with Tag          => With_Tag,

                                         TC_Component => "#NON" ) );

  end Create;

end C760011_0;

--------------------------------------------------------------------- C760011

with Report;

with TCTouch;

with C760011_0;

with Ada.Finalization; -- needed to be able to create extension aggregates

procedure C760011 is

  use type C760011_0.Controlled_Type;

  use type C760011_0.Controlled_Type'Class;

  use type C760011_0.Non_Controlled;

  subtype AFC is Ada.Finalization.Controlled;

  procedure Check_Result( Tag : Character; Message : String ) is

  -- make allowance for 7.6(21) optimizations

  begin

    if C760011_0.Initialized(Tag) then

      TCTouch.Assert(C760011_0.Finalized(Tag),Message);

    elsif C760011_0.Under_Debug then

      Report.Comment("Optimized away: " & Tag );

    end if;

  end Check_Result;

  procedure Subtest_1 is

    procedure Subtest_1_Local_1 is

      An_Object : C760011_0.Controlled_Type'Class

                := C760011_0.Controlled_Type'(AFC with 'X', "ONE*");

                   -- initialize An_Object

    begin

      if C760011_0.Controlled_Type(An_Object)

         = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then

        Report.Failed("Comparison bad");  -- A = X !!!

      end if;

    end Subtest_1_Local_1;

    -- An_Object must be Finalized by this point.

    procedure Subtest_1_Local_2 is

      An_Object : C760011_0.Controlled_Type('B');

    begin

      An_Object := (AFC with 'B',  "TWO!" );

      if Report.Ident_Char(An_Object.Tag) /= 'B' then

        Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!");

      end if;

    exception

      when others => Report.Failed("Bad controlled assignment");

    end Subtest_1_Local_2;

    -- An_Object must be Finalized by this point.

    procedure Subtest_1_Local_3 is

      An_Object : C760011_0.Non_Controlled('C');

    begin

      TCTouch.Assert_Not(C760011_0.Finalized('C'),

                           "Non_Controlled declaration C");

      An_Object := C760011_0.Non_Controlled'('C', Controlled_Component

                                     => (AFC with 'C', "TEE!"));

      if Report.Ident_Char(An_Object.Tag) /= 'C' then

        Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!");

      end if;

    end Subtest_1_Local_3;

    -- Only controlled components of An_Object must be finalized; it is an

    -- error to call Finalize for An_Object

  begin

    Subtest_1_Local_1;

    Check_Result( 'A', "Aggregate in subprogram 1" );

    Subtest_1_Local_2;

    Check_Result( 'B', "Aggregate in subprogram 2" );

    Subtest_1_Local_3;

    Check_Result( 'C', "Embedded aggregate in subprogram 3" );

  end Subtest_1;

  procedure Subtest_2 is

    -- using 'Z' for both evades order issues

    Con_Object : C760011_0.Controlled_Type('Z');

    Non_Object : C760011_0.Non_Controlled('Z');

  begin

    if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then

      Report.Failed("Con_Object catastrophe");

    end if;

     -- Controlled function result should be finalized by now

    Check_Result( 'D', "Function Result" );

    if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then

      Report.Failed("Non_Object catastrophe");

    end if;

     -- Controlled component of function result should be finalized by now

    Check_Result( 'E', "Function Result" );

  end Subtest_2;

  procedure Subtest_3(Con : in C760011_0.Controlled_Type) is

  begin

    if Con.Tag not in 'F'..'G' then

      Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' '

                    & Report.Ident_Str(Con.TC_Component));

    end if;

  end Subtest_3;

  procedure Subtest_4(Non : in C760011_0.Non_Controlled) is

  begin

    if Non.Tag not in 'H'..'I' then

      Report.Failed("Bad value passed to subtest 4 "

                   & Non.Tag & ' '

                   & Report.Ident_Str(Non.Controlled_Component.TC_Component));

    end if;

  end Subtest_4;

begin  -- Main test procedure.

  Report.Test ("C760011", "Check that anonymous objects of controlled " &

                          "types or types containing controlled types " &

                          "are finalized no later than the end of the " &

                          "innermost enclosing declarative_item or " &

                          "statement" );

  Subtest_1;

  Subtest_2;

  Subtest_3(C760011_0.Create('F'));

  Check_Result( 'F', "Function as formal F" );

  Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI"));

  Check_Result( 'G', "Aggregate as formal G" );

  Subtest_4(C760011_0.Create('H'));

  Check_Result( 'H', "Function as formal H" );

  Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO")));

  Check_Result( 'I', "Aggregate as formal I" );

  Report.Result;

end C760011;