gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cb/cb20001.a

   1 -- CB20001.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 exceptions can be handled in accept bodies, and that a
  28 --      task object that has an exception handled in an accept body is still
  29 --      viable for future use.
  30 --
  31 -- TEST DESCRIPTION:
  32 --      Declare a task that has exception handlers within an accept
  33 --      statement in the task body.  Declare a task object, and make entry
  34 --      calls with data that will cause various exceptions to be raised
  35 --      by the accept statement.  Ensure that the exceptions are:
  36 --         1) raised and handled locally in the accept body
  37 --         2) raised in the accept body and handled/reraised to be handled
  38 --            by the task body
  39 --         3) raised in the accept body and propagated to the calling
  40 --            procedure.
  41 --
  42 --
  43 -- CHANGE HISTORY:
  44 --      06 Dec 94   SAIC    ACVC 2.0
  45 --
  46 --!
  47
  48 with Report;
  49
  50 package CB20001_0 is
  51
  52    Incorrect_Data,
  53    Location_Error,
  54    Off_Screen_Data           : exception;
  55
  56    TC_Handled_In_Accept,
  57    TC_Reraised_In_Accept,
  58    TC_Handled_In_Task_Block,
  59    TC_Handled_In_Caller      : boolean := False;
  60
  61    type Location_Type is range 0 .. 2000;
  62
  63    task type Submarine_Type is
  64       entry Contact (Location : in Location_Type);
  65    end Submarine_Type;
  66
  67    Current_Position : Location_Type := 0;
  68
  69 end CB20001_0;
  70
  71
  72      --=================================================================--
  73
  74
  75 package body CB20001_0 is
  76
  77
  78    task body Submarine_Type is
  79    begin
  80       loop
  81
  82          Task_Block:
  83          begin
  84             select
  85                accept Contact (Location : in Location_Type) do
  86                   if Location > 1000 then
  87                      raise Off_Screen_Data;
  88                   elsif (Location > 500) and (Location <= 1000) then
  89                      raise Location_Error;
  90                   elsif (Location > 100) and (Location <= 500) then
  91                      raise Incorrect_Data;
  92                   else
  93                      Current_Position := Location;
  94                   end if;
  95                exception
  96                   when Off_Screen_Data =>
  97                      TC_Handled_In_Accept := True;
  98                   when Location_Error =>
  99                      TC_Reraised_In_Accept := True;
 100                      raise;   -- Reraise the Location_Error exception
 101                               -- in the task block.
 102                end Contact;
 103             or
 104                terminate;
 105             end select;
 106
 107          exception
 108
 109             when Off_Screen_Data =>
 110                 TC_Handled_In_Accept := False;
 111                 Report.Failed ("Off_Screen_Data exception " &
 112                                "improperly handled in task block");
 113
 114             when Location_Error =>
 115                 TC_Handled_In_Task_Block := True;
 116          end Task_Block;
 117
 118       end loop;
 119
 120    exception
 121
 122       when Location_Error | Off_Screen_Data =>
 123          TC_Handled_In_Accept := False;
 124          TC_Handled_In_Task_Block := False;
 125          Report.Failed ("Exception improperly propagated out to task body");
 126       when others =>
 127          null;
 128    end Submarine_Type;
 129
 130 end CB20001_0;
 131
 132
 133      --=================================================================--
 134
 135
 136 with CB20001_0;
 137 with Report;
 138 with ImpDef;
 139
 140 procedure CB20001 is
 141
 142    package Submarine_Tracking renames CB20001_0;
 143
 144    Trident       : Submarine_Tracking.Submarine_Type;   -- Declare task
 145    Sonar_Contact : Submarine_Tracking.Location_Type;
 146
 147    TC_LEB_Error,
 148    TC_Main_Handler_Used : Boolean := False;
 149
 150 begin
 151
 152    Report.Test ("CB20001", "Check that exceptions can be handled " &
 153                            "in accept bodies");
 154
 155
 156    Off_Screen_Block:
 157    begin
 158       Sonar_Contact := 1500;
 159       Trident.Contact (Sonar_Contact);  -- Cause Off_Screen_Data exception
 160                                         -- to be raised and handled in a task
 161                                         -- accept body.
 162    exception
 163       when Submarine_Tracking.Off_Screen_Data =>
 164           TC_Main_Handler_Used := True;
 165           Report.Failed ("Off_Screen_Data exception improperly handled " &
 166                          "in calling procedure");
 167       when others =>
 168           Report.Failed ("Exception handled unexpectedly in " &
 169                          "Off_Screen_Block");
 170    end Off_Screen_Block;
 171
 172
 173    Location_Error_Block:
 174    begin
 175       Sonar_Contact := 700;
 176       Trident.Contact (Sonar_Contact);  -- Cause Location_Error exception
 177                                         -- to be raised in task accept body,
 178                                         -- propogated to a task block, and
 179                                         -- handled there.  Corresponding
 180                                         -- exception propagated here also.
 181       Report.Failed ("Expected exception not raised");
 182    exception
 183       when Submarine_Tracking.Location_Error =>
 184           TC_LEB_Error := True;
 185       when others =>
 186           Report.Failed ("Exception handled unexpectedly in " &
 187                          "Location_Error_Block");
 188    end Location_Error_Block;
 189
 190
 191    Incorrect_Data_Block:
 192    begin
 193       Sonar_Contact := 200;
 194       Trident.Contact (Sonar_Contact);  -- Cause Incorrect_Data exception
 195                                         -- to be raised in task accept body,
 196                                         -- propogated to calling procedure.
 197       Report.Failed ("Expected exception not raised");
 198    exception
 199       when Submarine_Tracking.Incorrect_Data =>
 200           Submarine_Tracking.TC_Handled_In_Caller := True;
 201       when others =>
 202           Report.Failed ("Exception handled unexpectedly in " &
 203                          "Incorrect_Data_Block");
 204    end Incorrect_Data_Block;
 205
 206
 207    if TC_Main_Handler_Used or
 208       not (Submarine_Tracking.TC_Handled_In_Caller     and -- Check to see that
 209            Submarine_Tracking.TC_Handled_In_Task_Block and -- all exceptions
 210            Submarine_Tracking.TC_Handled_In_Accept     and -- were handled in
 211            Submarine_Tracking.TC_Reraised_In_Accept    and -- proper locations.
 212            TC_LEB_Error)
 213    then
 214       Report.Failed ("Exceptions handled in incorrect locations");
 215    end if;
 216
 217    if Integer(Submarine_Tracking.Current_Position) /= 0 then
 218       Report.Failed ("Variable incorrectly written in task processing");
 219    end if;
 220
 221    delay ImpDef.Minimum_Task_Switch;
 222    if Trident'Callable then
 223       Report.Failed ("Task didn't terminate with exception propagation");
 224    end if;
 225
 226    Report.Result;
 227
 228 end CB20001;