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

   1 -- CB40005.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 raised in non-generic code can be handled by
  28 --      a procedure in a generic package.  Check that the exception identity
  29 --      can be properly retrieved from the generic code and used by the
  30 --      non-generic code.
  31 --
  32 -- TEST DESCRIPTION:
  33 --      This test models a possible usage paradigm for the type:
  34 --        Ada.Exceptions.Exception_Occurrence.
  35 --
  36 --      A generic package takes access to procedure types (allowing it to
  37 --      be used at any accessibility level) and defines a "fail soft"
  38 --      procedure that takes designators to a procedure to call, a
  39 --      procedure to call in the event that it fails, and a function to
  40 --      call to determine the next action.
  41 --
  42 --      In the event an exception occurs on the call to the first procedure,
  43 --      the exception is stored in a stack; along with the designator to the
  44 --      procedure that caused it; allowing the procedure to be called again,
  45 --      or the exception to be re-raised.
  46 --
  47 --      A full implementation of such a tool would use a more robust storage
  48 --      mechanism, and would provide a more flexible interface.
  49 --
  50 --
  51 -- CHANGE HISTORY:
  52 --      29 MAR 96   SAIC   Initial version
  53 --      12 NOV 96   SAIC   Revised for 2.1 release
  54 --
  55 --!
  56
  57 ----------------------------------------------------------------- CB40005_0
  58
  59 with Ada.Exceptions;
  60 generic
  61   type Proc_Pointer is access procedure;
  62   type Func_Pointer is access function return Proc_Pointer;
  63 package CB40005_0 is -- Fail_Soft
  64
  65
  66   procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer;
  67                             Proc_To_Call_On_Exception : Proc_Pointer := null;
  68                             Retry_Routine : Func_Pointer := null );
  69
  70   function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence;
  71
  72   function Top_Event_Procedure return Proc_Pointer;
  73
  74   procedure Pop_Event;
  75
  76   function Event_Stack_Size return Natural;
  77
  78 end CB40005_0; -- Fail_Soft
  79
  80 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CB40005_0
  81
  82 with Report;
  83 package body CB40005_0 is
  84
  85   type History_Event is record
  86     Exception_Event  : Ada.Exceptions.Exception_Occurrence_Access;
  87     Procedure_Called : Proc_Pointer;
  88   end record;
  89
  90   procedure Store_Event( Proc_Called : Proc_Pointer;
  91                          Error       : Ada.Exceptions.Exception_Occurrence );
  92
  93   procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer;
  94                             Proc_To_Call_On_Exception : Proc_Pointer := null;
  95                             Retry_Routine : Func_Pointer := null ) is
  96
  97     Current_Proc_To_Call : Proc_Pointer := Proc_To_Call;
  98
  99   begin
 100     while Current_Proc_To_Call /= null loop
 101       begin
 102         Current_Proc_To_Call.all;  -- call procedure through pointer
 103         Current_Proc_To_Call := null;
 104       exception
 105         when Capture: others =>
 106           Store_Event( Current_Proc_To_Call, Capture );
 107           if Proc_To_Call_On_Exception /= null then
 108             Proc_To_Call_On_Exception.all;
 109           end if;
 110           if Retry_Routine /= null then
 111             Current_Proc_To_Call := Retry_Routine.all;
 112           else
 113             Current_Proc_To_Call := null;
 114           end if;
 115       end;
 116     end loop;
 117   end Fail_Soft_Call;
 118
 119   Stack : array(1..10) of History_Event;  -- minimal, sufficient for testing
 120
 121   Stack_Top : Natural := 0;
 122
 123   procedure Store_Event( Proc_Called : Proc_Pointer;
 124                          Error       : Ada.Exceptions.Exception_Occurrence )
 125   is
 126   begin
 127     Stack_Top := Stack_Top +1;
 128     Stack(Stack_Top) := ( Ada.Exceptions.Save_Occurrence(Error),
 129                           Proc_Called );
 130   end Store_Event;
 131
 132   function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence is
 133   begin
 134     if Stack_Top > 0 then
 135       return Stack(Stack_Top).Exception_Event.all;
 136     else
 137       return Ada.Exceptions.Null_Occurrence;
 138     end if;
 139   end Top_Event_Exception;
 140
 141   function Top_Event_Procedure return Proc_Pointer is
 142   begin
 143     if Stack_Top > 0 then
 144       return Stack(Stack_Top).Procedure_Called;
 145     else
 146       return null;
 147     end if;
 148   end Top_Event_Procedure;
 149
 150   procedure Pop_Event is
 151   begin
 152     if Stack_Top > 0 then
 153       Stack_Top := Stack_Top -1;
 154     else
 155       Report.Failed("Stack Error");
 156     end if;
 157   end Pop_Event;
 158
 159   function Event_Stack_Size return Natural is
 160   begin
 161     return Stack_Top;
 162   end Event_Stack_Size;
 163
 164 end CB40005_0;
 165
 166 ------------------------------------------------------------------- CB40005
 167
 168 with Report;
 169 with TCTouch;
 170 with CB40005_0;
 171 with Ada.Exceptions;
 172 procedure CB40005 is
 173
 174   type Proc_Pointer is access procedure;
 175   type Func_Pointer is access function return Proc_Pointer;
 176
 177   package Fail_Soft is new CB40005_0(Proc_Pointer, Func_Pointer);
 178
 179   procedure Cause_Standard_Exception;
 180
 181   procedure Cause_Visible_Exception;
 182
 183   procedure Cause_Invisible_Exception;
 184
 185   Exception_Procedure_Pointer : Proc_Pointer;
 186
 187   Visible_Exception : exception;
 188
 189   procedure Action_On_Exception;
 190
 191   function Retry_Procedure return Proc_Pointer;
 192
 193   Raise_Error : Boolean;
 194
 195   -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 196
 197   procedure Cause_Standard_Exception is
 198   begin
 199     TCTouch.Touch('S');  --------------------------------------------------- S
 200     if Raise_Error then
 201       raise Constraint_Error;
 202     end if;
 203   end Cause_Standard_Exception;
 204
 205   procedure Cause_Visible_Exception is
 206   begin
 207     TCTouch.Touch('V');  --------------------------------------------------- V
 208     if Raise_Error then
 209       raise Visible_Exception;
 210     end if;
 211   end Cause_Visible_Exception;
 212
 213   procedure Cause_Invisible_Exception is
 214     Invisible_Exception : exception;
 215   begin
 216     TCTouch.Touch('I');  --------------------------------------------------- I
 217     if Raise_Error then
 218       raise Invisible_Exception;
 219     end if;
 220   end Cause_Invisible_Exception;
 221
 222   procedure Action_On_Exception is
 223   begin
 224     TCTouch.Touch('A');  --------------------------------------------------- A
 225   end Action_On_Exception;
 226
 227   function Retry_Procedure return Proc_Pointer is
 228   begin
 229     TCTouch.Touch('R');  --------------------------------------------------- R
 230     return Action_On_Exception'Access;
 231   end Retry_Procedure;
 232
 233          -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 234
 235 begin  -- Main test procedure.
 236
 237   Report.Test ("CB40005", "Check that exceptions raised in non-generic " &
 238                           "code can be handled by a procedure in a generic " &
 239                           "package.  Check that the exception identity can " &
 240                           "be properly retrieved from the generic code and " &
 241                           "used by the non-generic code" );
 242
 243   -- first, check that the no exception cases cause no action on the stack
 244   Raise_Error := False;
 245
 246   Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access );    -- S
 247
 248   Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access,       -- V
 249                             Action_On_Exception'Access,
 250                             Retry_Procedure'Access );
 251
 252   Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access,     -- I
 253                             null,
 254                             Retry_Procedure'Access );
 255
 256   TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Empty stack");
 257
 258   TCTouch.Validate( "SVI", "Non error case check" );
 259
 260   -- second, check that error cases add to the stack
 261   Raise_Error := True;
 262
 263   Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access );    -- S
 264
 265   Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access,       -- V
 266                             Action_On_Exception'Access,           -- A
 267                             Retry_Procedure'Access );             -- RA
 268
 269   Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access,     -- I
 270                             null,
 271                             Retry_Procedure'Access );             -- RA
 272
 273   TCTouch.Assert( Fail_Soft.Event_Stack_Size = 3, "Stack = 3");
 274
 275   TCTouch.Validate( "SVARAIRA", "Error case check" );
 276
 277   -- check that the exceptions and procedure were stored correctly
 278   -- on the stack
 279   Raise_Error := False;
 280
 281   -- return procedure pointer from top of stack and call the procedure
 282   -- through that pointer:
 283
 284   Fail_Soft.Top_Event_Procedure.all;
 285
 286   TCTouch.Validate( "I", "Invisible case unwind" );
 287
 288   begin
 289     Ada.Exceptions.Raise_Exception(
 290       Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
 291     Report.Failed("1: Exception not raised");
 292   exception
 293     when Constraint_Error  => Report.Failed("1: Raised Constraint_Error");
 294     when Visible_Exception => Report.Failed("1: Raised Visible_Exception");
 295     when others            => null; -- expected case
 296   end;
 297
 298   Fail_Soft.Pop_Event;
 299
 300   -- return procedure pointer from top of stack and call the procedure
 301   -- through that pointer:
 302
 303   Fail_Soft.Top_Event_Procedure.all;
 304
 305   TCTouch.Validate( "V", "Visible case unwind" );
 306
 307   begin
 308     Ada.Exceptions.Raise_Exception(
 309       Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
 310     Report.Failed("2: Exception not raised");
 311   exception
 312     when Constraint_Error  => Report.Failed("2: Raised Constraint_Error");
 313     when Visible_Exception => null; -- expected case
 314     when others            => Report.Failed("2: Raised Invisible_Exception");
 315   end;
 316
 317   Fail_Soft.Pop_Event;
 318
 319   Fail_Soft.Top_Event_Procedure.all;
 320
 321   TCTouch.Validate( "S", "Standard case unwind" );
 322
 323   begin
 324     Ada.Exceptions.Raise_Exception(
 325       Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) );
 326     Report.Failed("3: Exception not raised");
 327   exception
 328     when Constraint_Error  => null; -- expected case
 329     when Visible_Exception => Report.Failed("3: Raised Visible_Exception");
 330     when others            => Report.Failed("3: Raised Invisible_Exception");
 331   end;
 332
 333   Fail_Soft.Pop_Event;
 334
 335   TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Stack empty after pops");
 336
 337   Report.Result;
 338
 339 end CB40005;