c980001.a

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

-- C980001.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 when a construct is aborted the execution of an Initialize
--      procedure as the last step of the default initialization of a
--      controlled object is abort-deferred.
--     
--      Check that when a construct is aborted the execution of a Finalize
--      procedure as part of the finalization of a controlled object is
--      abort-deferred.
--     
--      Check that an assignment operation to an object with a controlled
--      part is an abort-deferred operation.
--
-- TEST DESCRIPTION:
--      The controlled operations which are being tested call a subprogram
--      which guarantees that the enclosing operation becomes aborted.
--
--      Each object is created with a unique value to prevent optimizations
--      due to the values being the same.
--
--      Two protected objects are utilized to warrant that the operations
--      are delayed in their execution until such time that the abort is
--      processed.  The object Hold_Up is used to hold the targeted
--      operation in execution, the object Progress is used to communicate
--      to the driver software that progress is indeed being made. 
--
--
-- CHANGE HISTORY:
--      01 MAY 95   SAIC    Initial version
--      01 MAY 96   SAIC    Revised for 2.1
--      11 DEC 96   SAIC    Final revision for 2.1
--      02 DEC 97   EDS     Remove 2 calls to C980001_0.Hold_Up.Lock
--!

---------------------------------------------------------------- C980001_0

with Impdef;
with Ada.Finalization;
package C980001_0 is

  A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0;
  Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration
   := Impdef.Switch_To_New_Task * 4.0;

  function TC_Unique return Integer;

  type Sticks_In_Initialize is new Ada.Finalization.Controlled with record
    Item: Integer := TC_Unique;
  end record;
  procedure Initialize( AV: in out Sticks_In_Initialize );

  type Sticks_In_Adjust is new Ada.Finalization.Controlled with record
    Item: Integer := TC_Unique;
  end record;
  procedure Adjust    ( AV: in out Sticks_In_Adjust );

  type Sticks_In_Finalize is new Ada.Finalization.Controlled with record
    Item: Integer := TC_Unique;
  end record;
  procedure Finalize  ( AV: in out Sticks_In_Finalize );

  Initialize_Called : Boolean := False;
  Adjust_Called     : Boolean := False;
  Finalize_Called   : Boolean := False;

  protected type Sticker is
    entry Lock;
    procedure Unlock;
    function Is_Locked return Boolean;
  private
    Locked : Boolean := False;
  end Sticker;

  Hold_Up  : Sticker;
  Progress : Sticker;

  procedure Fail_And_Clear( Message : String );


end C980001_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with Report;
with TCTouch;
package body C980001_0 is

  TC_Master_Value : Integer := 0;


  function TC_Unique return Integer is  -- make all values unique.
  begin
    TC_Master_Value := TC_Master_Value +1;
    return TC_Master_Value;
  end TC_Unique;

  protected body Sticker is

    entry Lock when not Locked is
    begin
      Locked := True;
    end Lock;

    procedure Unlock is
    begin
      Locked := False;
    end Unlock;

    function Is_Locked return Boolean is
    begin
      return Locked;
    end Is_Locked;

  end Sticker;

  procedure Initialize( AV: in out Sticks_In_Initialize ) is
  begin
    TCTouch.Touch('I');  -------------------------------------------------- I
    Hold_Up.Unlock;               -- cause the select to abort
    Initialize_Called := True;
    AV.Item := TC_Unique;
    TCTouch.Touch('i');  -------------------------------------------------- i
    Progress.Unlock;              -- allows Wait_Your_Turn to continue
  end Initialize;

  procedure Adjust    ( AV: in out Sticks_In_Adjust ) is
  begin
    TCTouch.Touch('A');  -------------------------------------------------- A
    Hold_Up.Unlock;               -- cause the select to abort
    Adjust_Called := True;
    AV.Item := TC_Unique;
    TCTouch.Touch('a');  -------------------------------------------------- a
    Progress.Unlock;
  end Adjust;

  procedure Finalize  ( AV: in out Sticks_In_Finalize ) is
  begin
    TCTouch.Touch('F');  -------------------------------------------------- F
    Hold_Up.Unlock;               -- cause the select to abort
    Finalize_Called := True;
    AV.Item := TC_Unique;
    TCTouch.Touch('f');  -------------------------------------------------- f
    Progress.Unlock;
  end Finalize;

  procedure Fail_And_Clear( Message : String ) is
  begin
    Report.Failed(Message);
    Hold_Up.Unlock;
    Progress.Unlock;
  end Fail_And_Clear;

end C980001_0;
 
---------------------------------------------------------------------------

with Report;
with TCTouch;
with Impdef;
with C980001_0;
procedure C980001 is

  procedure Check_Initialize_Conditions is
  begin
    if not C980001_0.Initialize_Called then
      C980001_0.Fail_And_Clear("Initialize did not correctly complete");
    end if;
    TCTouch.Validate("Ii", "Initialization Sequence");
  end Check_Initialize_Conditions;

  procedure Check_Adjust_Conditions is
  begin
    if not C980001_0.Adjust_Called then
      C980001_0.Fail_And_Clear("Adjust did not correctly complete");
    end if;
    TCTouch.Validate("Aa", "Adjust Sequence");
  end Check_Adjust_Conditions;

  procedure Check_Finalize_Conditions is
  begin
    if not C980001_0.Finalize_Called then
      C980001_0.Fail_And_Clear("Finalize did not correctly complete");
    end if;
    TCTouch.Validate("FfFfFf", "Finalization Sequence",
                     Order_Meaningful => False);
  end Check_Finalize_Conditions;

  procedure Wait_Your_Turn is
    Overrun : Natural := 0;
  begin
    while C980001_0.Progress.Is_Locked loop  -- and waits
      delay C980001_0.A_Little_While;
      Overrun := Overrun +1;
      if Overrun > 10 then  
        C980001_0.Fail_And_Clear("Overrun expired lock");
      end if;
    end loop;
  end Wait_Your_Turn;

begin  -- Main test procedure.

  Report.Test ("C980001", "Check the interaction between asynchronous " &
                          "transfer of control and controlled types" );

  C980001_0.Progress.Lock;
  C980001_0.Hold_Up.Lock;

  select
    C980001_0.Hold_Up.Lock;  -- Init will unlock

    Wait_Your_Turn;  -- abortable part is stuck in Initialize
    Check_Initialize_Conditions;

  then abort
    declare
      Object : C980001_0.Sticks_In_Initialize;
    begin
      delay Impdef.Minimum_Task_Switch;
      if Report.Ident_Int( Object.Item ) /= Object.Item then
        Report.Failed("Optimization foil caused failure");
      end if;
      C980001_0.Fail_And_Clear(
                           "Initialize test executed beyond expected region");
    end;
  end select;

  C980001_0.Progress.Lock;

  select
    C980001_0.Hold_Up.Lock;  -- Adjust will unlock

    Wait_Your_Turn;  -- abortable part is stuck in Adjust
    Check_Adjust_Conditions;

  then abort
    declare
      Object1 : C980001_0.Sticks_In_Adjust;
      Object2 : C980001_0.Sticks_In_Adjust;
    begin
      Object1 := Object2;
      delay Impdef.Minimum_Task_Switch;
      if Report.Ident_Int( Object2.Item )
         /= Report.Ident_Int( Object1.Item ) then
        Report.Failed("Optimization foil 1 caused failure");
      end if;
      C980001_0.Fail_And_Clear("Adjust test executed beyond expected region");
    end;
  end select;

  C980001_0.Progress.Lock;

  select
    C980001_0.Hold_Up.Lock;  -- Finalize will unlock

    Wait_Your_Turn;  -- abortable part is stuck in Finalize
    Check_Finalize_Conditions;

  then abort
    declare
      Object1 : C980001_0.Sticks_In_Finalize;
      Object2 : C980001_0.Sticks_In_Finalize;
    begin
      Object1 := Object2;  -- cause a finalize call
      delay Impdef.Minimum_Task_Switch;
      if Report.Ident_Int( Object2.Item )
         /= Report.Ident_Int( Object1.Item ) then
        Report.Failed("Optimization foil 2 caused failure");
      end if;
      C980001_0.Fail_And_Clear(
                             "Finalize test executed beyond expected region");
    end;
  end select;

  Report.Result;

exception
  when others => C980001_0.Fail_And_Clear("Exception in main");
                 Report.Result;
end C980001;