c760002.a

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

-- C760002.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 assignment to an object of a (non-limited) controlled
--      type causes the Adjust operation of the type to be called.
--      Check that Adjust is called after copying the value of the
--      source expression to the target object.
--
--      Check that Adjust is called for all controlled components when
--      the containing object is assigned.  (Test this for the cases
--      where the type of the containing object is controlled and
--      noncontrolled; test this for initialization as well as
--      assignment statements.)
--
--      Check that for an object of a controlled type with controlled
--      components, Adjust for each of the components is called before
--      the containing object is adjusted.
--
--      Check that an Adjust procedure for a Limited_Controlled type is
--      not called by the implementation.
--
-- TEST DESCRIPTION:
--      This test is loosely "derived" from C760001.
--
--      Visit Tags:
--        D - Default value at declaration
--        d - Default value at declaration, limited root
--        I - initialize at root controlled
--        i - initialize at root limited controlled
--        A - adjust at root controlled
--        X,Y,Z,x,y,z - used in test body
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      19 Dec 94   SAIC    Correct test assertion logic for Sinister case
--
--!

---------------------------------------------------------------- C760002_0

with Ada.Finalization;
package C760002_0 is
  subtype Unique_ID is Natural;
  function Unique_Value return Unique_ID;
  -- increments each time it's called

  function Most_Recent_Unique_Value return Unique_ID;
  -- returns the same value as the most recent call to Unique_Value

  type Root is tagged record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'D';  -- Default
  end record;

  procedure Initialize( R: in out Root );
  procedure Adjust    ( R: in out Root );

  type Root_Controlled is new Ada.Finalization.Controlled with record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'D'; ---------------------------------------- D
  end record;

  procedure Initialize( R: in out Root_Controlled );
  procedure Adjust    ( R: in out Root_Controlled );

  type Root_Limited_Controlled is
       new Ada.Finalization.Limited_Controlled with record
    My_ID      : Unique_ID := Unique_Value;
    Visit_Tag  : Character := 'd'; ---------------------------------------- d
  end record;

  procedure Initialize( R: in out Root_Limited_Controlled );
  procedure Adjust    ( R: in out Root_Limited_Controlled );

end C760002_0;

with Report;
package body C760002_0 is

  Global_Unique_Counter : Unique_ID := 0;
  
  function Unique_Value return Unique_ID is
  begin
    Global_Unique_Counter := Global_Unique_Counter +1;
    return Global_Unique_Counter;
  end Unique_Value;
  
  function Most_Recent_Unique_Value return Unique_ID is
  begin
    return Global_Unique_Counter;
  end Most_Recent_Unique_Value;

  procedure Initialize( R: in out Root ) is
  begin
    Report.Failed("Initialize called for Non_Controlled type");
  end Initialize;

  procedure Adjust    ( R: in out Root ) is
  begin
    Report.Failed("Adjust called for Non_Controlled type");
  end Adjust;

  procedure Initialize( R: in out Root_Controlled ) is
  begin
    R.Visit_Tag := 'I'; --------------------------------------------------- I
  end Initialize;

  procedure Adjust( R: in out Root_Controlled ) is
  begin
    R.Visit_Tag := 'A'; --------------------------------------------------- A
  end Adjust;

  procedure Initialize( R: in out Root_Limited_Controlled ) is
  begin
    R.Visit_Tag := 'i'; --------------------------------------------------- i
  end Initialize;

  procedure Adjust( R: in out Root_Limited_Controlled ) is
  begin
    Report.Failed("Adjust called for Limited_Controlled type");
  end Adjust;

end C760002_0;

---------------------------------------------------------------- C760002_1

with Ada.Finalization;
with C760002_0;
package C760002_1 is

  type Proc_ID is (None, Init, Adj, Fin);

  type Test_Controlled is new C760002_0.Root_Controlled with record
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Test_Controlled );
  procedure Adjust    ( TC: in out Test_Controlled );
  procedure Finalize  ( TC: in out Test_Controlled );

  type Nested_Controlled is new C760002_0.Root_Controlled with record
    Nested : C760002_0.Root_Controlled;
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Nested_Controlled );
  procedure Adjust    ( TC: in out Nested_Controlled );
  procedure Finalize  ( TC: in out Nested_Controlled );

  type Test_Limited_Controlled is
       new C760002_0.Root_Limited_Controlled with record
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Test_Limited_Controlled );
  procedure Adjust    ( TC: in out Test_Limited_Controlled );
  procedure Finalize  ( TC: in out Test_Limited_Controlled );

  type Nested_Limited_Controlled is
       new C760002_0.Root_Limited_Controlled with record
    Nested : C760002_0.Root_Limited_Controlled;
    Last_Proc_Called: Proc_ID := None;
  end record;

  procedure Initialize( TC: in out Nested_Limited_Controlled );
  procedure Adjust    ( TC: in out Nested_Limited_Controlled );
  procedure Finalize  ( TC: in out Nested_Limited_Controlled );

end C760002_1;

with Report;
package body C760002_1 is

  procedure Initialize( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Adj;
    C760002_0.Adjust(C760002_0.Root_Controlled(TC));
  end Adjust;

  procedure Finalize  ( TC: in out Test_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

  procedure Initialize( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Adj;
    C760002_0.Adjust(C760002_0.Root_Controlled(TC));
  end Adjust;

  procedure Finalize  ( TC: in out Nested_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;
  end Finalize;

  procedure Initialize( TC: in out Test_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Init;
    C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC));
  end Initialize;

  procedure Adjust    ( TC: in out Test_Limited_Controlled ) is
  begin
    Report.Failed("Adjust called for Test_Limited_Controlled");
  end Adjust;

  procedure Finalize  ( TC: in out Test_Limited_Controlled ) is
  begin
    TC.Last_Proc_Called := Fin;