c760009.a

来自「linux下编程用 编译软件」· A 代码 · 共 534 行 · 第 1/2 页

-- C760009.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 for an extension_aggregate whose ancestor_part is a
--      subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) )
--      Initialize is called on all controlled subcomponents of the
--      ancestor part; if the type of the ancestor part is itself controlled,
--      the Initialize procedure of the ancestor type is called, unless that
--      Initialize procedure is abstract.
--
--      Check that the utilization of a controlled type for a generic actual
--      parameter supports the correct behavior in the instantiated package.
--
-- TEST DESCRIPTION:
--      Declares a generic package instantiated to check that controlled
--      types are not impacted by the "generic boundary."
--      This instance is then used to perform the tests of various
--      aggregate formations of the controlled type.  After each operation
--      in the main program that should cause implicit calls, the "state" of
--      the software is checked.  The "state" of the software is maintained in
--      several variables which count the calls to the Initialize, Adjust and
--      Finalize procedures in each context.  Given the nature of the
--      language rules, the test specifies a minimum number of times that
--      these subprograms should have been called.  The test also checks cases
--      where the subprograms should not have been called.
--     
--      As per the example in AARM 7.6(11a..d);6.0, the distinctions between
--      the presence/absence of default values is tested.
--
-- DATA STRUCTURES
--
--      C760009_3.Master_Control is derived from
--        C760009_2.Control is derived from
--          Ada.Finalization.Controlled
--
--      C760009_1.Simple_Control is derived from
--        Ada.Finalization.Controlled
--
--      C760009_3.Master_Control contains
--        Standard.Integer
--
--      C760009_2.Control contains
--        C760009_1.Simple_Control (default value)
--        C760009_1.Simple_Control (default initialized)
--
--
-- CHANGE HISTORY:
--      01 MAY 95   SAIC    Initial version
--      19 FEB 96   SAIC    Fixed elaboration Initialize count
--      14 NOV 96   SAIC    Allowed for 7.6(21) optimizations
--      13 FEB 97   PWB.CTA Initialized counters at lines 127-129
--      26 JUN 98   EDS     Added pragma Elaborate_Body to C760009_0
--                          to avoid possible instantiation error
--!

---------------------------------------------------------------- C760009_0

with Ada.Finalization;
generic

  type Private_Formal is private;

  with procedure TC_Validate( APF: in out Private_Formal );

package C760009_0 is -- Check_1

  pragma Elaborate_Body;
  procedure TC_Check_1( APF: in     Private_Formal );
  procedure TC_Check_2( APF:    out Private_Formal );
  procedure TC_Check_3( APF: in out Private_Formal );

end C760009_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body C760009_0 is -- Check_1

    procedure TC_Check_1( APF: in     Private_Formal ) is
      Local : Private_Formal;
    begin
      Local := APF;
      TC_Validate( Local );
    end TC_Check_1;

    procedure TC_Check_2( APF:    out Private_Formal ) is
      Local : Private_Formal;  -- initialized by virtue of actual being
                               -- Controlled
    begin
      APF := Local;
      TC_Validate( APF );
    end TC_Check_2;

    procedure TC_Check_3( APF: in out Private_Formal ) is
      Local : Private_Formal;
    begin
      Local := APF;
      TC_Validate( Local );
    end TC_Check_3;

end C760009_0;
 
---------------------------------------------------------------- C760009_1

with Ada.Finalization;
package C760009_1 is

  Initialize_Called : Natural := 0;
  Adjust_Called     : Natural := 0;
  Finalize_Called   : Natural := 0;

  procedure Reset_Counters;

  type Simple_Control is new Ada.Finalization.Controlled with private;

  procedure Initialize( AV: in out Simple_Control );
  procedure Adjust    ( AV: in out Simple_Control );
  procedure Finalize  ( AV: in out Simple_Control );
  procedure Validate  ( AV: in out Simple_Control );

  function Item( AV: Simple_Control'Class ) return String;

  Empty : constant Simple_Control;

  procedure TC_Trace( Message: String );

private
  type Simple_Control is new Ada.Finalization.Controlled with record
    Item: Natural;
  end record;

  Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 );

end C760009_1;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
package body C760009_1 is

  -- Maintenance_Mode and TC_Trace are for the test writers and compiler
  -- developers to get more information from this test as it executes.
  -- Maintenance_Mode is always False for validation purposes.

  Maintenance_Mode : constant Boolean := False;

  procedure TC_Trace( Message: String ) is
  begin
    if Maintenance_Mode then
      Report.Comment( Message );
    end if;
  end TC_Trace;

  procedure Reset_Counters is
  begin
    Initialize_Called := 0;
    Adjust_Called     := 0;
    Finalize_Called   := 0;
  end Reset_Counters;

  Master_Count : Natural := 100;  -- Help distinguish values

  procedure Initialize( AV: in out Simple_Control ) is
  begin
    Initialize_Called := Initialize_Called +1;
    AV.Item := Master_Count;
    Master_Count := Master_Count +100;
    TC_Trace( "Initialize _1.Simple_Control" );
  end Initialize;

  procedure Adjust    ( AV: in out Simple_Control ) is
  begin
    Adjust_Called := Adjust_Called +1;
    AV.Item := AV.Item +1;
    TC_Trace( "Adjust _1.Simple_Control" );
  end Adjust;

  procedure Finalize  ( AV: in out Simple_Control ) is
  begin
    Finalize_Called := Finalize_Called +1;
    AV.Item := AV.Item +1;
    TC_Trace( "Finalize _1.Simple_Control" );
  end Finalize;

  procedure Validate  ( AV: in out Simple_Control ) is
  begin
    Report.Failed("Attempt to Validate at Simple_Control level");
  end Validate;

  function Item( AV: Simple_Control'Class ) return String is
  begin
    return Natural'Image(AV.Item);
  end Item;

end C760009_1;
 
---------------------------------------------------------------- C760009_2

with C760009_1;
with Ada.Finalization;
package C760009_2 is

  type Control is new Ada.Finalization.Controlled with record
    Element_1 : C760009_1.Simple_Control;
    Element_2 : C760009_1.Simple_Control := C760009_1.Empty;
  end record;

  procedure Initialize( AV: in out Control );
  procedure Finalize  ( AV: in out Control );

  Initialized : Natural := 0;
  Finalized   : Natural := 0;

end C760009_2;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C760009_2 is

  procedure Initialize( AV: in out Control ) is
  begin
    Initialized := Initialized +1;
    C760009_1.TC_Trace( "Initialize _2.Control" );
  end Initialize;

  procedure Finalize  ( AV: in out Control ) is
  begin
    Finalized := Finalized +1;
    C760009_1.TC_Trace( "Finalize _2.Control" );
  end Finalize;

end C760009_2;
 
---------------------------------------------------------------- C760009_3

with C760009_0;
with C760009_2;
package C760009_3 is

  type Master_Control is new C760009_2.Control with record
    Data: Integer;
  end record;

  procedure Initialize( AC: in out Master_Control );