gcc/testsuite/ada/acats/tests/c9/c954017.a

   1 -- C954017.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that when an exception is raised in the rendezvous of a task
  28 --      that was called by a requeue the exception is propagated to the
  29 --      original caller and that the requeuing task is unaffected.
  30 --
  31 -- TEST DESCRIPTION:
  32 --      The Intermediate task requeues a call from the Original_Caller to the
  33 --      Receiver.  While the Receiver is in the accept body for this
  34 --      rendezvous a Constraint_Error exception is raised.  Check that the
  35 --      exception is propagated to the Original_Caller, that the Receiver's
  36 --      normal exception logic is employed and that the Intermediate task
  37 --      is undisturbed.
  38 --      There are several delay loops in this test any one of which could
  39 --      cause it to hang (and thus fail).
  40 --
  41 --
  42 -- CHANGE HISTORY:
  43 --      06 Dec 94   SAIC    ACVC 2.0
  44 --      25 Nov 95   SAIC    Fixed shared global variable problem for
  45 --                          ACVC 2.0.1
  46 --
  47 --!
  48
  49 with Report;
  50 with ImpDef;
  51
  52
  53 procedure C954017 is
  54
  55    TC_Original_Caller_Complete   : Boolean := false;
  56    TC_Intermediate_Complete      : Boolean := false;
  57    TC_Receiver_Complete          : Boolean := false;
  58    TC_Exception                  : Exception;
  59
  60
  61    protected type Shared_Boolean (Initial_Value : Boolean := False) is
  62       procedure Set_True;
  63       procedure Set_False;
  64       function  Value return Boolean;
  65    private
  66       Current_Value : Boolean := Initial_Value;
  67    end Shared_Boolean;
  68
  69    protected body Shared_Boolean is
  70       procedure Set_True is
  71       begin
  72          Current_Value := True;
  73       end Set_True;
  74
  75       procedure Set_False is
  76       begin
  77          Current_Value := False;
  78       end Set_False;
  79
  80       function Value return Boolean is
  81       begin
  82          return Current_Value;
  83       end Value;
  84    end Shared_Boolean;
  85
  86    TC_Exception_Process_Complete : Shared_Boolean (False);
  87
  88    task Original_Caller is
  89       entry Start;
  90    end Original_Caller;
  91
  92    task Intermediate is
  93       entry Input;
  94    end Intermediate;
  95
  96    task Receiver is
  97       entry Input;
  98    end Receiver;
  99
 100
 101    task body Original_Caller is
 102    begin
 103       accept Start;    -- wait for the trigger from Main
 104
 105       Intermediate.Input;
 106       Report.Failed ("Exception not propagated to Original_Caller");
 107
 108    exception
 109       when TC_Exception =>
 110                TC_Original_Caller_Complete := true;     -- Expected behavior
 111       when others        =>
 112                Report.Failed ("Unexpected Exception in Original_Caller task");
 113    end Original_Caller;
 114
 115
 116    task body Intermediate is
 117    begin
 118       accept Input do
 119          -- Within this accept call another task
 120          requeue Receiver.Input with abort;
 121       end Input;
 122
 123       -- Wait for Main to ensure that the exception housekeeping is finished
 124       while not TC_Exception_Process_Complete.Value loop
 125          delay ImpDef.Minimum_Task_Switch;
 126       end loop;
 127
 128       TC_Intermediate_Complete := true;
 129
 130    exception
 131       when others =>
 132                   Report.Failed ("Unexpected exception in Intermediate task");
 133    end Intermediate;
 134
 135
 136    task body Receiver is
 137    --
 138    begin
 139       accept Input do
 140          null;  -- the user code for the rendezvous is stubbed out
 141
 142          -- Test Control: Raise an exception in the destination task which
 143          -- should then be propagated
 144          raise TC_Exception;
 145
 146       end Input;
 147    exception
 148       when TC_Exception =>
 149             TC_Receiver_Complete := true;  -- expected behavior
 150       when others        =>
 151             Report.Failed ("Unexpected Exception in Receiver Task");
 152    end Receiver;
 153
 154
 155 begin
 156
 157    Report.Test ("C954017", "Requeue: exception processing");
 158
 159    Original_Caller.Start;   -- Start the test after the Report.Test
 160
 161    -- Wait for the whole of the exception process to complete
 162    while not ( Original_Caller'terminated and Receiver'terminated ) loop
 163       delay ImpDef.Minimum_Task_Switch;
 164    end loop;
 165
 166    -- Inform the Intermediate task that the process is complete to allow
 167    -- it to continue to completion itself
 168    TC_Exception_Process_Complete.Set_True;
 169
 170    -- Wait for everything to settle before reporting the result
 171    while not ( Intermediate'terminated ) loop
 172       delay ImpDef.Minimum_Task_Switch;
 173    end loop;
 174
 175
 176    if not ( TC_Original_Caller_Complete and
 177             TC_Intermediate_Complete    and
 178             TC_Receiver_Complete)       then
 179       Report.Failed ("Proper paths not traversed");
 180    end if;
 181
 182    Report.Result;
 183
 184 end C954017;