gcc/testsuite/ada/acats/tests/cb/cb20007.a

   1 -- CB20007.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 can be directly propagated to
  28 --      the calling unit by 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 propagated directly from the protected
  37 --      operations to the calling unit.
  38 --
  39 --      Ensure that the exceptions are raised and correctly propagated directly
  40 --      to the calling unit from protected procedures and functions.
  41 --
  42 --
  43 -- CHANGE HISTORY:
  44 --      06 Dec 94   SAIC    ACVC 2.0
  45 --
  46 --!
  47
  48 package CB20007_0 is               -- Package Semaphore.
  49
  50    Handled_In_Function_Caller,
  51    Handled_In_Procedure_Caller : Boolean := False;
  52
  53    Resource_Overflow,
  54    Resource_Underflow          : exception;
  55
  56    protected type Counting_Semaphore (Max_Resources : Integer) is
  57       procedure Secure;
  58       function  Resource_Limit_Exceeded return Boolean;
  59       procedure Release;
  60    private
  61       Count : Integer := Max_Resources;
  62    end Counting_Semaphore;
  63
  64 end CB20007_0;
  65
  66      --=================================================================--
  67
  68 with Report;
  69
  70 package body CB20007_0 is                  -- Package Semaphore.
  71
  72    protected body Counting_Semaphore is
  73
  74       procedure Secure is
  75       begin
  76          if (Count = 0) then               -- No resources left to secure.
  77             raise Resource_Underflow;
  78             Report.Failed ("Program control not transferred by raise");
  79          else
  80             Count := Count - 1;            -- Available resources decremented.
  81          end if;
  82          -- No exception handlers here, direct propagation to calling unit.
  83       end Secure;
  84
  85
  86       function Resource_Limit_Exceeded return Boolean is
  87       begin
  88          if (Count > Max_Resources) then
  89             raise Resource_Overflow;       -- Exception used as control flow
  90                                            -- mechanism.
  91             Report.Failed ("Program control not transferred by raise");
  92          else
  93             return (False);
  94          end if;
  95          -- No exception handlers here, direct propagation to calling unit.
  96       end Resource_Limit_Exceeded;
  97
  98
  99       procedure Release is
 100       begin
 101          Count := Count + 1;               -- Count of resources available
 102                                            -- incremented.
 103          if Resource_Limit_Exceeded then   -- Call to protected operation
 104             Count := Count - 1;            -- function that raises an
 105                                            -- exception.
 106             Report.Failed("Resource limit exceeded");
 107          end if;
 108          -- No exception handler here for exception raised in function.
 109          -- Exception will propagate directly to calling unit.
 110       end Release;
 111
 112
 113    end Counting_Semaphore;
 114
 115 end CB20007_0;
 116
 117
 118      --=================================================================--
 119
 120
 121 with CB20007_0;                           -- Package Semaphore.
 122 with Report;
 123
 124 procedure CB20007 is
 125 begin
 126
 127    Test_Block:
 128    declare
 129
 130       package Semaphore renames CB20007_0;
 131
 132       Total_Resources_Available : constant := 1;
 133
 134       Resources : Semaphore.Counting_Semaphore (Total_Resources_Available);
 135                                              -- An object of protected type.
 136
 137    begin
 138
 139       Report.Test ("CB20007", "Check that exceptions are raised and can "   &
 140                               "be directly propagated to the calling unit " &
 141                               "by protected operations" );
 142
 143       Allocate_Resources:
 144       declare
 145          Loop_Count : Integer := Total_Resources_Available + 1;
 146       begin                                   -- Force exception.
 147          for I in 1..Loop_Count loop
 148             Resources.Secure;
 149          end loop;
 150          Report.Failed ("Exception not propagated from protected " &
 151                         " operation in Allocate_Resources");
 152       exception
 153          when Semaphore.Resource_Underflow =>              -- Exception prop.
 154             Semaphore.Handled_In_Procedure_Caller := True; -- from protected
 155                                                            -- procedure.
 156          when others =>
 157             Report.Failed ("Unknown exception during resource allocation");
 158       end Allocate_Resources;
 159
 160
 161       Deallocate_Resources:
 162       declare
 163          Loop_Count : Integer := Total_Resources_Available + 1;
 164       begin                                   -- Force exception.
 165          for I in 1..Loop_Count loop
 166             Resources.Release;
 167          end loop;
 168          Report.Failed ("Exception not propagated from protected " &
 169                         "operation in Deallocate_Resources");
 170       exception
 171          when Semaphore.Resource_Overflow =>              -- Exception prop
 172             Semaphore.Handled_In_Function_Caller := True; -- from protected
 173                                                           -- function.
 174          when others =>
 175             Report.Failed ("Exception raised during resource deallocation");
 176       end Deallocate_Resources;
 177
 178
 179       if not (Semaphore.Handled_In_Procedure_Caller and -- Incorrect exception
 180               Semaphore.Handled_In_Function_Caller)     -- handling in
 181       then                                              -- protected ops.
 182           Report.Failed
 183             ("Improper exception propagation by protected operations");
 184       end if;
 185
 186    exception
 187
 188       when others =>
 189          Report.Failed ("Unexpected exception " &
 190                         " raised and propagated in test");
 191    end Test_Block;
 192
 193
 194    Report.Result;
 195
 196 end CB20007;