Subversion Repositories openrisc_me

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