llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/c9/c953001.a

-- C953001.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 the evaluation of an entry_barrier condition
--      propagates an exception, the exception Program_Error
--      is propagated to all current callers of all entries of the
--      protected object.
--
-- TEST DESCRIPTION:
--      This test declares a protected object (PO) with two entries and
--      a 5 element entry family.
--      All the entries are always closed.  However, one of the entries
--      (Oh_No) will get a constraint_error in its barrier_evaluation
--      whenever the global variable Blow_Up is true.
--      An array of tasks is created where the tasks wait on the various
--      entries of the protected object.  Once all the tasks are waiting
--      the main procedure calls the entry Oh_No and causes an exception
--      to be propagated to all the tasks.  The tasks record the fact 
--      that they got the correct exception in global variables that
--      can be checked after the tasks complete.
--
--
-- CHANGE HISTORY:
--      19 OCT 95   SAIC    ACVC 2.1
--
--!


with Report;
with ImpDef;
procedure C953001 is
    Verbose : constant Boolean := False;
    Max_Tasks : constant := 12;

      -- note status and error conditions
    Blocked_Entry_Taken : Boolean := False;
    In_Oh_No            : Boolean := False;
    Task_Passed : array (1..Max_Tasks) of Boolean := (1..Max_Tasks => False);

begin
  Report.Test ("C953001",
               "Check that an exception in an entry_barrier condition" &
               " causes Program_Error to be propagated to all current" &
               " callers of all entries of the protected object");

  declare -- test encapsulation
    -- miscellaneous values
    Cows : Integer := Report.Ident_Int (1);
    Came_Home : Integer := Report.Ident_Int (2);

    -- make the Barrier_Condition fail only when we want it to
    Blow_Up : Boolean := False;

    function Barrier_Condition return Boolean is
    begin
      if Blow_Up then
         return 5 mod Report.Ident_Int(0) = 1;
      else
         return False;
      end if;
    end Barrier_Condition;

    subtype Family_Index is Integer range 1..5;

    protected PO is
      entry Block1;
      entry Oh_No;
      entry Family (Family_Index);
    end PO;

    protected body PO is
      entry Block1 when Report.Ident_Int(0) = Report.Ident_Int(1) is
      begin
        Blocked_Entry_Taken := True;
      end Block1;

      -- barrier will get a Constraint_Error (divide by 0)
      entry Oh_No when Barrier_Condition is
      begin
        In_Oh_No := True;
      end Oh_No;

      entry Family (for Member in Family_Index) when Cows = Came_Home is
      begin
        Blocked_Entry_Taken := True;
      end Family;
    end PO;
     

    task type Waiter is
      entry Take_Id (Id : Integer);
    end Waiter;

    Bunch_of_Waiters : array (1..Max_Tasks) of Waiter;

    task body Waiter is
      Me : Integer;
      Action : Integer;
    begin
      accept Take_Id (Id : Integer) do
         Me := Id;
      end Take_Id;

      Action := Me mod (Family_Index'Last + 1);
      begin
        if Action = 0 then
          PO.Block1; 
        else
          PO.Family (Action);
        end if;
        Report.Failed ("no exception for task" & Integer'Image (Me));
      exception
         when Program_Error =>
           Task_Passed (Me) := True;
           if Verbose then
             Report.Comment ("pass for task" & Integer'Image (Me));
           end if;
         when others =>
           Report.Failed ("wrong exception raised in task" &
                          Integer'Image (Me));
      end;
    end Waiter;


  begin   -- test encapsulation
    for I in 1..Max_Tasks loop
      Bunch_Of_Waiters(I).Take_Id (I);
    end loop;

    -- give all the Waiters time to get queued
    delay 2*ImpDef.Clear_Ready_Queue;

    -- cause the protected object to fail
    begin
      Blow_Up := True;
      PO.Oh_No;
      Report.Failed ("no exception in call to PO.Oh_No");
    exception
      when Constraint_Error =>
         Report.Failed ("Constraint_Error instead of Program_Error");
      when Program_Error =>
         if Verbose then
           Report.Comment ("main exception passed");
         end if;
      when others =>
         Report.Failed ("wrong exception in main");
    end;
  end;    -- test encapsulation

  -- all the tasks have now completed.
  -- check the flags for pass/fail info
  if Blocked_Entry_Taken then
     Report.Failed ("blocked entry taken");
  end if;
  if In_Oh_No then
     Report.Failed ("entry taken with exception in barrier");
  end if;
  for I in 1..Max_Tasks loop
    if not Task_Passed (I) then
      Report.Failed ("task" & Integer'Image (I) & " did not pass");
    end if;
  end loop;

  Report.Result;
end C953001;