Subversion Repositories openrisc

-- C760012.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 record components that have per-object access discriminant

--      constraints are initialized in the order of their component

--      declarations, and after any components that are not so constrained.

--

--      Check that record components that have per-object access discriminant

--      constraints are finalized in the reverse order of their component

--      declarations, and before any components that are not so constrained.

--

-- TEST DESCRIPTION:

--      The type List_Item is the "container" type.  It holds two fields that

--      have per-object access discriminant constraints, and two fields that

--      are not discriminated.  These four fields are all controlled types.

--      A fifth field is a pointer used to maintain a linked list of these

--      data objects.  Each component is of a unique type which allows for

--      the test to simply track the order of initialization and finalization.

--

--      The types and their purpose are:

--        Constrained_First  - a controlled discriminated type

--        Constrained_Second - a controlled discriminated type

--        Simple_First       - a controlled type with no discriminant

--        Simple_Second      - a controlled type with no discriminant

--

--      The required order of operations:

--        Initialize

--          ( Simple_First | Simple_Second )   -- no "internal order" required

--          Constrained_First

--          Constrained_Second

--        Finalize

--          Constrained_Second

--          Constrained_First

--          ( Simple_First | Simple_Second )   -- must be inverse of init.

--

--

-- CHANGE HISTORY:

--      23 MAY 95   SAIC    Initial version

--      02 MAY 96   SAIC    Reorganized for 2.1

--      05 DEC 96   SAIC    Simplified for 2.1; added init/fin ordering check

--      31 DEC 97   EDS     Remove references to and uses of

--                          Initialization_Sequence

--!

---------------------------------------------------------------- C760012_0

with Ada.Finalization;

with Ada.Unchecked_Deallocation;

package C760012_0 is

  type List_Item;

  type List is access all List_Item;

  package Firsts is  -- distinguish first from second

    type Constrained_First(Container : access List_Item) is

           new Ada.Finalization.Limited_Controlled with null record;

    procedure Initialize( T : in out Constrained_First );

    procedure Finalize  ( T : in out Constrained_First );

    type Simple_First is new Ada.Finalization.Controlled with

      record

        My_Init_Seq_Number : Natural;

      end record;

    procedure Initialize( T : in out Simple_First );

    procedure Finalize  ( T : in out Simple_First );

  end Firsts;

  type Constrained_Second(Container : access List_Item) is

         new Ada.Finalization.Limited_Controlled with null record;

  procedure Initialize( T : in out Constrained_Second );

  procedure Finalize  ( T : in out Constrained_Second );

  type Simple_Second is new Ada.Finalization.Controlled with

    record

      My_Init_Seq_Number : Natural;

    end record;

  procedure Initialize( T : in out Simple_Second );

  procedure Finalize  ( T : in out Simple_Second );

  -- by 3.8(18);6.0 the following type contains components constrained

  -- by per-object expressions

  type List_Item is new Ada.Finalization.Limited_Controlled

    with record

      ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S

      SimpleA  : Firsts.Simple_First;                          -- A T

      SimpleB  : Simple_Second;                                -- A T

      ContentB : Constrained_Second( List_Item'Access );       -- D R

      Next     : List;                                         -- | |

    end record;                                                -- | |

  procedure Initialize( L : in out List_Item ); ------------------+ |

  procedure Finalize  ( L : in out List_Item ); --------------------+

  -- the tags are the same for SimpleA and SimpleB due to the fact that

  -- the language does not specify an ordering with respect to this

  -- component pair. 7.6(12) does specify the rest of the ordering.

  procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List);

end C760012_0;

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

with TCTouch;

package body C760012_0 is

  package body Firsts is

    procedure Initialize( T : in out Constrained_First ) is

    begin

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

    end Initialize;

    procedure Finalize  ( T : in out Constrained_First ) is

    begin

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

    end Finalize;

    procedure Initialize( T : in out Simple_First ) is

    begin

      T.My_Init_Seq_Number := 0;

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

    end Initialize;

    procedure Finalize  ( T : in out Simple_First ) is

    begin

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

    end Finalize;

  end Firsts;

  procedure Initialize( T : in out Constrained_Second ) is

  begin

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

  end Initialize;

  procedure Finalize  ( T : in out Constrained_Second ) is

  begin

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

  end Finalize;

  procedure Initialize( T : in out Simple_Second ) is

  begin

    T.My_Init_Seq_Number := 0;

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

  end Initialize;

  procedure Finalize  ( T : in out Simple_Second ) is

  begin

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

  end Finalize;

  procedure Initialize( L : in out List_Item ) is

  begin

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

  end Initialize;

  procedure Finalize  ( L : in out List_Item ) is

  begin

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

  end Finalize;

end C760012_0;

--------------------------------------------------------------------- C760012

with Report;

with TCTouch;

with C760012_0;

procedure C760012 is

  use type C760012_0.List;

  procedure Subtest_1 is

  -- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints

  -- 7.6.1(9);6.0 dictates the order of finalization of the components

    One_Of_Them : C760012_0.List_Item;

  begin

    if One_Of_Them.Next /= null then  -- just to hold the subtest in place

      Report.Failed("No default value for Next");

    end if;

  end Subtest_1;

  List : C760012_0.List;

  procedure Subtest_2 is

  begin

    List := new C760012_0.List_Item;

    List.Next := new C760012_0.List_Item;

  end Subtest_2;

  procedure Subtest_3 is

  begin

    C760012_0.Deallocate( List.Next );

    C760012_0.Deallocate( List );

  end Subtest_3;

begin  -- Main test procedure.

  Report.Test ("C760012", "Check that record components that have " &

                          "per-object access discriminant constraints " &

                          "are initialized in the order of their " &

                          "component declarations, and after any " &

                          "components that are not so constrained.  " &

                          "Check that record components that have " &

                          "per-object access discriminant constraints " &

                          "are finalized in the reverse order of their " &

                          "component declarations, and before any " &

                          "components that are not so constrained" );

  Subtest_1;

  TCTouch.Validate("AACDFQRSTT", "One object");

  Subtest_2;

  TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated");

  Subtest_3;

  TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated");

  Report.Result;

end C760012;