Dead

[official-gcc.git] / gomp-20050608-branch / gcc / testsuite / ada / acats / tests / c7 / c761007.a

-- C761007.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 if a finalize procedure invoked by a transfer of control
--      due to selection of a terminate alternative attempts to propagate an
--      exception, the exception is ignored, but any other finalizations due
--      to be performed are performed.
--
--
-- TEST DESCRIPTION:
--      This test declares a nested controlled data type, and embeds an object
--      of that type within a protected type.  Objects of the protected type
--      are created and destroyed, and the actions of the embedded controlled
--      object are checked.  The container controlled type causes an exception
--      as the last part of it's finalization operation.
--
--      This test utilizes several tasks to accomplish the objective.  The
--      tasks contain delays to ensure that the expected order of processing
--      is indeed accomplished.
--
--      Subtest 1:
--        local task object runs to normal completion
--
--      Subtest 2:
--        local task aborts a nested task to cause finalization
--
--      Subtest 3: 
--        local task sleeps long enough to allow procedure started
--        asynchronously to go into infinite loop.  Procedure is then aborted
--        via ATC, causing finalization of objects.
--
--      Subtest 4:
--        local task object takes terminate alternative, causing finalization
--
--
-- CHANGE HISTORY:
--      06 JUN 95   SAIC    Initial version
--      05 APR 96   SAIC    Documentation changes
--      03 MAR 97   PWB.CTA Allowed two finalization orders for ATC test
--      02 DEC 97   EDS     Remove duplicate characters from check string.
--!

---------------------------------------------------------------- C761007_0

with Ada.Finalization;
package C761007_0 is

  type Internal is new Ada.Finalization.Controlled
    with record
      Effect : Character;
    end record;

  procedure Finalize( I: in out Internal );

  Side_Effect : String(1..80);  -- way bigger than needed
  Side_Effect_Finger : Natural := 0;

end C761007_0;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with TCTouch;
package body C761007_0 is

  procedure Finalize( I : in out Internal ) is
    Previous_Side_Effect : Boolean := False;
  begin
    -- look to see if this character has been finalized yet
    for SEI in 1..Side_Effect_Finger loop
      Previous_Side_Effect := Previous_Side_Effect
                              or Side_Effect(Side_Effect_Finger) = I.Effect;
    end loop;

    -- if not, then tack it on to the string, and touch the character
    if not Previous_Side_Effect then
      Side_Effect_Finger := Side_Effect_Finger +1;
      Side_Effect(Side_Effect_Finger) := I.Effect;
      TCTouch.Touch(I.Effect);
    end if;

  end Finalize;

end C761007_0;

---------------------------------------------------------------- C761007_1

with C761007_0;
with Ada.Finalization;
package C761007_1 is

  type Container is new Ada.Finalization.Controlled
    with record
      Effect   : Character;
      Content  : C761007_0.Internal;
    end record;

  procedure Finalize( C: in out Container );

  Side_Effect : String(1..80);  -- way bigger than needed
  Side_Effect_Finger : Natural := 0;

  This_Exception_Is_Supposed_To_Be_Ignored : exception;

end C761007_1;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

with TCTouch;
package body C761007_1 is

  procedure Finalize( C: in out Container ) is
    Previous_Side_Effect : Boolean := False;
  begin
    -- look to see if this character has been finalized yet
    for SEI in 1..Side_Effect_Finger loop
      Previous_Side_Effect := Previous_Side_Effect
                              or Side_Effect(Side_Effect_Finger) = C.Effect;
    end loop;

    -- if not, then tack it on to the string, and touch the character
    if not Previous_Side_Effect then
      Side_Effect_Finger := Side_Effect_Finger +1;
      Side_Effect(Side_Effect_Finger) := C.Effect;
      TCTouch.Touch(C.Effect);
    end if;

    raise This_Exception_Is_Supposed_To_Be_Ignored;

  end Finalize;

end C761007_1;
 
---------------------------------------------------------------- C761007_2
with C761007_1;
package C761007_2 is

  protected type Prot_W_Fin_Obj is
    procedure Set_Effects( Container, Filling: Character );
  private
    The_Data_Under_Test : C761007_1.Container;
    -- finalization for this will occur when the Prot_W_Fin_Obj object
    --  "goes out of existence" for whatever reason.
  end Prot_W_Fin_Obj;

end C761007_2;
 
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C761007_2 is

  protected body Prot_W_Fin_Obj is
    procedure Set_Effects( Container, Filling: Character ) is
    begin
      The_Data_Under_Test.Effect := Container;           -- A, etc.
      The_Data_Under_Test.Content.Effect := Filling;     -- B, etc.
    end Set_Effects;
  end Prot_W_Fin_Obj;

end C761007_2;

------------------------------------------------------------------ C761007

with Report;
with Impdef;
with TCTouch;
with C761007_0;
with C761007_1;
with C761007_2;
procedure C761007 is

  task type Subtests( Outer, Inner : Character) is
    entry Ready;
    entry Complete;
  end Subtests;

  task body Subtests is
    Local_Prot_W_Fin_Obj : C761007_2.Prot_W_Fin_Obj;
  begin
    Local_Prot_W_Fin_Obj.Set_Effects( Outer, Inner );

    accept Ready;

    select
      accept Complete;
    or terminate;       -- used in Subtest 4
    end select;
  exception
    -- the exception caused by the finalization of Local_Prot_W_Fin_Obj
    --  should never be visible to this scope.
    when others => Report.Failed("Exception in a Subtest object "
                                 & Outer & Inner);
  end Subtests;

  procedure Subtest_1 is
    -- check the case where "nothing special" happens.

    This_Subtest : Subtests( 'A', 'B' );
  begin

    This_Subtest.Ready;
    This_Subtest.Complete;

    while not This_Subtest'Terminated loop -- wait for finalization
      delay Impdef.Clear_Ready_Queue;
    end loop;

    -- in the finalization of This_Subtest, the controlled object embedded in
    -- the Prot_W_Fin_Obj will finalize.  An exception is raised in the
    -- container object, after "touching" it's tag character.
    -- The finalization of the contained controlled object must be performed.


    TCTouch.Validate( "AB", "Item embedded in task" );


  exception
    when others => Report.Failed("Undesirable exception in Subtest_1");

  end Subtest_1;

  procedure Subtest_2 is
    -- check for explicit abort

    task Subtest_Task is
      entry Complete;
    end Subtest_Task;

    task body Subtest_Task is

      task Nesting;
      task body Nesting is
        Deep_Nesting : Subtests( 'E', 'F' );
      begin
        if Report.Ident_Bool( True ) then
          -- controlled objects have been created in the elaboration of
          -- Deep_Nesting.  Deep_Nesting must call the Set_Effects operation
          -- in the Prot_W_Fin_Obj, and then hang waiting for the Complete
          -- entry call.
          Deep_Nesting.Ready;
          abort Deep_Nesting;
        else
          Report.Failed("Dead code in Nesting");
        end if;
      exception
        when others => Report.Failed("Exception in Subtest_Task.Nesting");
      end Nesting;

      Local_2 : C761007_2.Prot_W_Fin_Obj;

    begin
      -- Nesting has activated at this point, which implies the activation
      -- of Deep_Nesting as well.

      Local_2.Set_Effects( 'C', 'D' );

      -- wait for Nesting to terminate

      while not Nesting'Terminated loop
        delay Impdef.Clear_Ready_Queue;
      end loop;

      accept Complete;

    exception
      when others => Report.Failed("Exception in Subtest_Task");
    end Subtest_Task;

  begin

    -- wait for everything in Subtest_Task to happen
    Subtest_Task.Complete;

    while not Subtest_Task'Terminated loop -- wait for finalization
      delay Impdef.Clear_Ready_Queue;
    end loop;

    TCTouch.Validate( "EFCD", "Aborted nested task" );

  exception
    when others => Report.Failed("Undesirable exception in Subtest_2");
  end Subtest_2;

  procedure Subtest_3 is
    -- check abort caused by asynchronous transfer of control

    task Subtest_3_Task is
      entry Complete;
    end Subtest_3_Task;

    procedure Check_Atc_Operation is
      Check_Atc : C761007_2.Prot_W_Fin_Obj;
    begin

      Check_Atc.Set_Effects( 'G', 'H' );


      while Report.Ident_Bool( True ) loop -- wait to be aborted
        if Report.Ident_Bool( True ) then
          Impdef.Exceed_Time_Slice;
          delay Impdef.Switch_To_New_Task;
        else
          Report.Failed("Optimization prevention");
        end if;
      end loop;

      Report.Failed("Check_Atc_Operation loop completed");

    end Check_Atc_Operation;

    task body Subtest_3_Task is
      task Nesting is
        entry Complete;
      end Nesting;

      task body Nesting is
        Nesting_3 : C761007_2.Prot_W_Fin_Obj;
      begin
        Nesting_3.Set_Effects( 'G', 'H' );

        -- give Check_Atc_Operation sufficient time to perform it's
        -- Set_Effects on it's local Prot_W_Fin_Obj object
        delay Impdef.Clear_Ready_Queue;

        accept Complete;
      exception
        when others => Report.Failed("Exception in Subtest_3_Task.Nesting");
      end Nesting;

      Local_3 : C761007_2.Prot_W_Fin_Obj;

    begin -- Subtest_3_Task

      Local_3.Set_Effects( 'I', 'J' );

      select
        Nesting.Complete;
      then abort ---------------------------------------------------- cause KL
        Check_ATC_Operation;
      end select;

      accept Complete;

    exception
      when others => Report.Failed("Exception in Subtest_3_Task");
    end Subtest_3_Task;

  begin -- Subtest_3
    Subtest_3_Task.Complete;

    while not Subtest_3_Task'Terminated loop -- wait for finalization
      delay Impdef.Clear_Ready_Queue;
    end loop;

    TCTouch.Validate( "GHIJ", "Asynchronously aborted operation" );

  exception
    when others => Report.Failed("Undesirable exception in Subtest_3");
  end Subtest_3;

  procedure Subtest_4 is
    -- check the case where transfer is caused by terminate alternative
    -- highly similar to Subtest_1

    This_Subtest : Subtests( 'M', 'N' );
  begin

    This_Subtest.Ready;
    -- don't call This_Subtest.Complete;

  exception
    when others => Report.Failed("Undesirable exception in Subtest_4");

  end Subtest_4;

begin  -- Main test procedure.

  Report.Test ("C761007", "Check that if a finalize procedure invoked by " &
                          "a transfer of control or selection of a " &
                          "terminate alternative attempts to propagate " &
                          "an exception, the exception is ignored, but " &
                          "any other finalizations due to be performed " &
                          "are performed" );

  Subtest_1;  -- checks internal

  Subtest_2;  -- checks internal

  Subtest_3;  -- checks internal

  Subtest_4;
  TCTouch.Validate( "MN", "transfer due to terminate alternative" );

  Report.Result;

end C761007;