c760012.a

来自「linux下编程用 编译软件」· A 代码 · 共 257 行

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