old-autovect-branch/gcc/testsuite/ada/acats/tests/cb/cb20006.a

   1 -- CB20006.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 are raised and properly handled (including
  28 --      propagation by reraise) in protected operations.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      Declare a package with a protected type, including protected operation
  32 --      declarations and private data, simulating a counting semaphore.
  33 --      In the main procedure, perform calls on protected operations
  34 --      of the protected object designed to induce the raising of exceptions.
  35 --
  36 --      The exceptions raised are to be initially handled in the protected
  37 --      operations, but this handling involves the reraise of the exception
  38 --      and the propagation of the exception to the caller.
  39 --
  40 --      Ensure that the exceptions are raised, handled / reraised successfully
  41 --      in protected procedures and functions.  Use "others" handlers in the
  42 --      protected operations.
  43 --
  44 --
  45 -- CHANGE HISTORY:
  46 --      06 Dec 94   SAIC    ACVC 2.0
  47 --
  48 --!
  49
  50 package CB20006_0 is               -- Package Semaphore.
  51
  52    Reraised_In_Function,
  53    Reraised_In_Procedure,
  54    Handled_In_Function_Caller,
  55    Handled_In_Procedure_Caller   : Boolean := False;
  56
  57    Resource_Overflow,
  58    Resource_Underflow            : exception;
  59
  60    protected type Counting_Semaphore (Max_Resources : Integer) is
  61       procedure Secure;
  62       function  Resource_Limit_Exceeded return Boolean;
  63       procedure Release;
  64    private
  65       Count : Integer := Max_Resources;
  66    end Counting_Semaphore;
  67
  68 end CB20006_0;
  69
  70      --=================================================================--
  71
  72 with Report;
  73
  74 package body CB20006_0 is                 -- Package Semaphore.
  75
  76    protected body Counting_Semaphore is
  77
  78       procedure Secure is
  79       begin
  80          if (Count = 0) then              -- No resources left to secure.
  81             raise Resource_Underflow;
  82             Report.Failed
  83               ("Program control not transferred by raise in Procedure Secure");
  84          else
  85             Count := Count - 1;           -- Available resources decremented.
  86          end if;
  87       exception
  88          when Resource_Underflow =>
  89             Reraised_In_Procedure := True;
  90             raise;                        -- Exception propagated to caller.
  91             Report.Failed ("Exception not propagated to caller from Secure");
  92          when others =>
  93             Report.Failed ("Unexpected exception raised in Secure");
  94       end Secure;
  95
  96
  97       function Resource_Limit_Exceeded return Boolean is
  98       begin
  99          if (Count > Max_Resources) then
 100             raise Resource_Overflow;      -- Exception used as control flow
 101                                           -- mechanism.
 102             Report.Failed
 103               ("Specific raise did not alter program control" &
 104                " from Resource_Limit_Exceeded");
 105          else
 106             return (False);
 107          end if;
 108       exception
 109          when others =>
 110             Reraised_In_Function := True;
 111             raise;                         -- Exception propagated to caller.
 112             Report.Failed ("Exception not propagated to caller" &
 113                            " from Resource_Limit_Exceeded");
 114       end Resource_Limit_Exceeded;
 115
 116
 117       procedure Release is
 118       begin
 119          Count := Count + 1;               -- Count of resources available
 120                                            -- incremented.
 121          if Resource_Limit_Exceeded then   -- Call to protected operation
 122             Count := Count - 1;            -- function that raises/reraises
 123                                            -- an exception.
 124             Report.Failed("Resource limit exceeded");
 125          end if;
 126
 127       exception
 128          when others =>
 129             raise;                         -- Reraised and propagated again.
 130              Report.Failed ("Exception not reraised by procedure Release");
 131       end Release;
 132
 133
 134    end Counting_Semaphore;
 135
 136 end CB20006_0;
 137
 138
 139      --=================================================================--
 140
 141
 142 with CB20006_0;                           -- Package Semaphore.
 143 with Report;
 144
 145 procedure CB20006 is
 146 begin
 147
 148    Report.Test ("CB20006", "Check that exceptions are raised and " &
 149                            "handled / reraised and propagated "    &
 150                            "correctly by protected operations" );
 151
 152    Test_Block:
 153    declare
 154
 155       package Semaphore renames CB20006_0;
 156
 157       Total_Resources_Available : constant := 1;
 158
 159       Resources : Semaphore.Counting_Semaphore (Total_Resources_Available);
 160                                              -- An object of protected type.
 161
 162    begin
 163
 164       Allocate_Resources:
 165       declare
 166          Loop_Count : Integer := Total_Resources_Available + 1;
 167       begin
 168          for I in 1..Loop_Count loop -- Force exception
 169             Resources.Secure;
 170          end loop;
 171          Report.Failed
 172            ("Exception not propagated from protected operation Secure");
 173       exception
 174          when Semaphore.Resource_Underflow =>        -- Exception propagated
 175            Semaphore.Handled_In_Procedure_Caller := True;  -- from protected
 176          when others =>                                    -- procedure.
 177            Semaphore.Handled_In_Procedure_Caller := False;
 178       end Allocate_Resources;
 179
 180
 181       Deallocate_Resources:
 182       declare
 183          Loop_Count : Integer := Total_Resources_Available + 1;
 184       begin
 185          for I in 1..Loop_Count loop -- Force exception
 186             Resources.Release;
 187          end loop;
 188          Report.Failed
 189            ("Exception not propagated from protected operation Release");
 190       exception
 191          when Semaphore.Resource_Overflow =>        -- Exception propagated
 192             Semaphore.Handled_In_Function_Caller := True; -- from protected
 193          when others =>                                   -- function.
 194             Semaphore.Handled_In_Function_Caller := False;
 195       end Deallocate_Resources;
 196
 197
 198       if not (Semaphore.Reraised_In_Procedure and
 199               Semaphore.Reraised_In_Function  and
 200               Semaphore.Handled_In_Procedure_Caller and
 201               Semaphore.Handled_In_Function_Caller)
 202       then                                       -- Incorrect excpt. handling
 203          Report.Failed                           -- in protected operations.
 204            ("Improper exception handling/reraising by protected operations");
 205       end if;
 206
 207    exception
 208
 209       when others =>
 210          Report.Failed ("Unexpected exception " &
 211                         " raised and propagated in test");
 212    end Test_Block;
 213
 214    Report.Result;
 215
 216
 217 end CB20006;