gcc/testsuite/ada/acats/tests/c7/c760010.a

   1 -- C760010.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 explicit calls to Initialize, Adjust and Finalize
  28 --      procedures that raise exceptions propagate the exception raised,
  29 --      not Program_Error.  Check this for both a user defined exception
  30 --      and a language defined exception.  Check that implicit calls to
  31 --      initialize procedures that raise an exception propagate the
  32 --      exception raised, not Program_Error;
  33 --
  34 --      Check that the utilization of a controlled type as the actual for
  35 --      a generic formal tagged private parameter supports the correct
  36 --      behavior in the instantiated software.
  37 --
  38 -- TEST DESCRIPTION:
  39 --      Declares a generic package instantiated to check that controlled
  40 --      types are not impacted by the "generic boundary."
  41 --      This instance is then used to perform the tests of various calls to
  42 --      the procedures.  After each operation in the main program that should
  43 --      cause implicit calls where an exception is raised, the program handles
  44 --      Program_Error.  After each explicit call, the program handles the
  45 --      Expected_Error.  Handlers for the opposite exception are provided to
  46 --      catch the obvious failure modes.  The predefined exception
  47 --      Tasking_Error is used to be certain that some other reason has not
  48 --      raised a predefined exception.
  49 --
  50 --
  51 -- DATA STRUCTURES
  52 --
  53 --      C760010_1.Simple_Control is derived from
  54 --        Ada.Finalization.Controlled
  55 --
  56 --      C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control
  57 --        by way of generic instantiation
  58 --
  59 --
  60 -- CHANGE HISTORY:
  61 --      01 MAY 95   SAIC    Initial version
  62 --      23 APR 96   SAIC    Fix visibility problem for 2.1
  63 --      14 NOV 96   SAIC    Revisit for 2.1 release
  64 --      26 JUN 98   EDS     Added pragma Elaborate_Body to
  65 --                          package C760010_0.Check_Formal_Tagged
  66 --                          to avoid possible instantiation error
  67 --!
  68
  69 ---------------------------------------------------------------- C760010_0
  70
  71 package C760010_0 is
  72
  73   User_Defined_Exception : exception;
  74
  75   type Actions is ( No_Action,
  76                     Init_Raise_User_Defined, Init_Raise_Standard,
  77                     Adj_Raise_User_Defined,  Adj_Raise_Standard,
  78                     Fin_Raise_User_Defined,  Fin_Raise_Standard );
  79
  80   Action : Actions := No_Action;
  81
  82   function Unique return Natural;
  83
  84 end C760010_0;
  85
  86 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  87
  88 package body C760010_0 is
  89
  90   Value : Natural := 101;
  91
  92   function Unique return Natural is
  93   begin
  94     Value := Value +1;
  95     return Value;
  96   end Unique;
  97
  98 end C760010_0;
  99
 100 ---------------------------------------------------------------- C760010_0
 101 ------------------------------------------------------ Check_Formal_Tagged
 102
 103 generic
 104
 105   type Formal_Tagged is tagged private;
 106
 107 package C760010_0.Check_Formal_Tagged is
 108
 109   pragma Elaborate_Body;
 110
 111   type Embedded_Derived is new Formal_Tagged with record
 112     TC_Meaningless_Value : Natural := Unique;
 113   end record;
 114
 115   procedure Initialize( ED: in out Embedded_Derived );
 116   procedure Adjust    ( ED: in out Embedded_Derived );
 117   procedure Finalize  ( ED: in out Embedded_Derived );
 118
 119 end C760010_0.Check_Formal_Tagged;
 120
 121
 122 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 123
 124 with Report;
 125 package body C760010_0.Check_Formal_Tagged is
 126
 127
 128   procedure Initialize( ED: in out Embedded_Derived ) is
 129   begin
 130     ED.TC_Meaningless_Value := Unique;
 131     case Action is
 132       when Init_Raise_User_Defined => raise User_Defined_Exception;
 133       when Init_Raise_Standard     => raise Tasking_Error;
 134       when others                  => null;
 135     end case;
 136   end Initialize;
 137
 138   procedure Adjust    ( ED: in out Embedded_Derived ) is
 139   begin
 140     ED.TC_Meaningless_Value := Unique;
 141     case Action is
 142       when Adj_Raise_User_Defined => raise User_Defined_Exception;
 143       when Adj_Raise_Standard     => raise Tasking_Error;
 144       when others                 => null;
 145     end case;
 146   end Adjust;
 147
 148   procedure Finalize  ( ED: in out Embedded_Derived ) is
 149   begin
 150     ED.TC_Meaningless_Value := Unique;
 151     case Action is
 152       when Fin_Raise_User_Defined => raise User_Defined_Exception;
 153       when Fin_Raise_Standard     => raise Tasking_Error;
 154       when others                 => null;
 155     end case;
 156   end Finalize;
 157
 158 end C760010_0.Check_Formal_Tagged;
 159
 160 ---------------------------------------------------------------- C760010_1
 161
 162 with Ada.Finalization;
 163 package C760010_1 is
 164
 165   procedure Check_Counters(Init,Adj,Fin : Natural; Message: String);
 166   procedure Reset_Counters;
 167
 168   type Simple_Control is new Ada.Finalization.Controlled with record
 169     Item: Integer;
 170   end record;
 171   procedure Initialize( AV: in out Simple_Control );
 172   procedure Adjust    ( AV: in out Simple_Control );
 173   procedure Finalize  ( AV: in out Simple_Control );
 174
 175 end C760010_1;
 176
 177 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 178
 179 with Report;
 180 package body C760010_1 is
 181
 182   Initialize_Called : Natural;
 183   Adjust_Called     : Natural;
 184   Finalize_Called   : Natural;
 185
 186   procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is
 187   begin
 188     if Init /= Initialize_Called then
 189       Report.Failed("Initialize mismatch " & Message);
 190     end if;
 191     if Adj /= Adjust_Called then
 192       Report.Failed("Adjust mismatch " & Message);
 193     end if;
 194     if Fin /= Finalize_Called then
 195       Report.Failed("Finalize mismatch " & Message);
 196     end if;
 197   end Check_Counters;
 198
 199   procedure Reset_Counters is
 200   begin
 201     Initialize_Called := 0;
 202     Adjust_Called     := 0;
 203     Finalize_Called   := 0;
 204   end Reset_Counters;
 205
 206   procedure Initialize( AV: in out Simple_Control ) is
 207   begin
 208     Initialize_Called := Initialize_Called +1;
 209     AV.Item := 0;
 210   end Initialize;
 211
 212   procedure Adjust    ( AV: in out Simple_Control ) is
 213   begin
 214     Adjust_Called := Adjust_Called +1;
 215     AV.Item := AV.Item +1;
 216   end Adjust;
 217
 218   procedure Finalize  ( AV: in out Simple_Control ) is
 219   begin
 220     Finalize_Called := Finalize_Called +1;
 221     AV.Item := AV.Item +1;
 222   end Finalize;
 223
 224 end C760010_1;
 225
 226 ---------------------------------------------------------------- C760010_2
 227
 228 with C760010_0.Check_Formal_Tagged;
 229 with C760010_1;
 230 package C760010_2 is
 231   new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control);
 232
 233 ---------------------------------------------------------------------------
 234
 235 with Report;
 236 with C760010_0;
 237 with C760010_1;
 238 with C760010_2;
 239 procedure C760010 is
 240
 241   use type C760010_0.Actions;
 242
 243   procedure Case_Failure(Message: String) is
 244   begin
 245     Report.Failed(Message & " for case "
 246                   & C760010_0.Actions'Image(C760010_0.Action) );
 247   end Case_Failure;
 248
 249   procedure Check_Implicit_Initialize is
 250     Item   : C760010_2.Embedded_Derived;  -- exception here propagates to
 251     Gadget : C760010_2.Embedded_Derived;  -- caller
 252   begin
 253     if C760010_0.Action
 254        in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
 255     then
 256       Case_Failure("Anticipated exception at implicit init");
 257     end if;
 258     begin
 259       Item := Gadget;                     -- exception here handled locally
 260       if C760010_0.Action in C760010_0.Adj_Raise_User_Defined
 261                                    .. C760010_0.Fin_Raise_Standard then
 262         Case_Failure ("Anticipated exception at assignment");
 263       end if;
 264     exception
 265       when Program_Error =>
 266         if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined
 267                                    .. C760010_0.Fin_Raise_Standard then
 268           Report.Failed("Program_Error in Check_Implicit_Initialize");
 269         end if;
 270       when Tasking_Error =>
 271         Report.Failed("Tasking_Error in Check_Implicit_Initialize");
 272       when C760010_0.User_Defined_Exception =>
 273         Report.Failed("User_Error in Check_Implicit_Initialize");
 274       when others =>
 275         Report.Failed("Wrong exception Check_Implicit_Initialize");
 276     end;
 277   end Check_Implicit_Initialize;
 278
 279 ---------------------------------------------------------------------------
 280
 281   Global_Item : C760010_2.Embedded_Derived;
 282
 283 ---------------------------------------------------------------------------
 284
 285   procedure Check_Explicit_Initialize is
 286   begin
 287     begin
 288       C760010_2.Initialize( Global_Item );
 289     if C760010_0.Action
 290        in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard
 291     then
 292       Case_Failure("Anticipated exception at explicit init");
 293     end if;
 294     exception
 295       when Program_Error =>
 296         Report.Failed("Program_Error in Check_Explicit_Initialize");
 297       when Tasking_Error =>
 298         if C760010_0.Action /= C760010_0.Init_Raise_Standard then
 299           Report.Failed("Tasking_Error in Check_Explicit_Initialize");
 300         end if;
 301       when C760010_0.User_Defined_Exception =>
 302         if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then
 303           Report.Failed("User_Error in Check_Explicit_Initialize");
 304         end if;
 305       when others =>
 306         Report.Failed("Wrong exception in Check_Explicit_Initialize");
 307     end;
 308   end Check_Explicit_Initialize;
 309
 310 ---------------------------------------------------------------------------
 311
 312   procedure Check_Explicit_Adjust is
 313   begin
 314     begin
 315       C760010_2.Adjust( Global_Item );
 316     if C760010_0.Action
 317        in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard
 318     then
 319       Case_Failure("Anticipated exception at explicit Adjust");
 320     end if;
 321     exception
 322       when Program_Error =>
 323         Report.Failed("Program_Error in Check_Explicit_Adjust");
 324       when Tasking_Error =>
 325         if C760010_0.Action /= C760010_0.Adj_Raise_Standard then
 326           Report.Failed("Tasking_Error in Check_Explicit_Adjust");
 327         end if;
 328       when C760010_0.User_Defined_Exception =>
 329         if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then
 330           Report.Failed("User_Error in Check_Explicit_Adjust");
 331         end if;
 332       when others =>
 333         Report.Failed("Wrong exception in Check_Explicit_Adjust");
 334     end;
 335   end Check_Explicit_Adjust;
 336
 337 ---------------------------------------------------------------------------
 338
 339   procedure Check_Explicit_Finalize is
 340   begin
 341     begin
 342       C760010_2.Finalize( Global_Item );
 343     if C760010_0.Action
 344        in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard
 345     then
 346       Case_Failure("Anticipated exception at explicit Finalize");
 347     end if;
 348     exception
 349       when Program_Error =>
 350         Report.Failed("Program_Error in Check_Explicit_Finalize");
 351       when Tasking_Error =>
 352         if C760010_0.Action /= C760010_0.Fin_Raise_Standard then
 353           Report.Failed("Tasking_Error in Check_Explicit_Finalize");
 354         end if;
 355       when C760010_0.User_Defined_Exception =>
 356         if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then
 357           Report.Failed("User_Error in Check_Explicit_Finalize");
 358         end if;
 359       when others =>
 360         Report.Failed("Wrong exception in Check_Explicit_Finalize");
 361     end;
 362   end Check_Explicit_Finalize;
 363
 364 ---------------------------------------------------------------------------
 365
 366 begin  -- Main test procedure.
 367
 368   Report.Test ("C760010", "Check that explicit calls to finalization " &
 369                           "procedures that raise exceptions propagate " &
 370                           "the exception raised.  Check the utilization " &
 371                           "of a controlled type as the actual for a " &
 372                           "generic formal tagged private parameter" );
 373
 374   for Act in C760010_0.Actions loop
 375     C760010_1.Reset_Counters;
 376     C760010_0.Action := Act;
 377
 378     begin
 379       Check_Implicit_Initialize;
 380       if Act in
 381          C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then
 382         Case_Failure("No exception at Check_Implicit_Initialize");
 383       end if;
 384     exception
 385       when Tasking_Error =>
 386         if Act /= C760010_0.Init_Raise_Standard then
 387           Case_Failure("Tasking_Error at Check_Implicit_Initialize");
 388         end if;
 389       when C760010_0.User_Defined_Exception =>
 390         if Act /= C760010_0.Init_Raise_User_Defined then
 391           Case_Failure("User_Error at Check_Implicit_Initialize");
 392         end if;
 393       when Program_Error =>
 394          -- If finalize raises an exception, all other object are finalized
 395          -- first and Program_Error is raised upon leaving the master scope.
 396          -- 7.6.1:14
 397          if Act not in C760010_0.Fin_Raise_User_Defined..
 398                        C760010_0.Fin_Raise_Standard then
 399             Case_Failure("Program_Error at Check_Implicit_Initialize");
 400          end if;
 401       when others =>
 402         Case_Failure("Wrong exception at Check_Implicit_Initialize");
 403     end;
 404
 405     Check_Explicit_Initialize;
 406     Check_Explicit_Adjust;
 407     Check_Explicit_Finalize;
 408
 409     C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act));
 410
 411   end loop;
 412
 413   -- Set to No_Action to avoid exception in finalizing Global_Item
 414   C760010_0.Action := C760010_0.No_Action;
 415
 416   Report.Result;
 417
 418 end C760010;