gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c7/c761011.a

   1 -- C761011.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     The Ada Conformity Assessment Authority (ACAA) holds unlimited
   6 --     rights in the software and documentation contained herein. Unlimited
   7 --     rights are the same as those granted by the U.S. Government for older
   8 --     parts of the Ada Conformity Assessment Test Suite, and are defined
   9 --     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
  10 --     intends to confer upon all recipients unlimited rights equal to those
  11 --     held by the ACAA. These rights include rights to use, duplicate,
  12 --     release or disclose the released technical data and computer software
  13 --     in whole or in part, in any manner and for any purpose whatsoever, and
  14 --     to have or permit others 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 if a Finalize propagates an exception, other Finalizes due
  28 --    to be performed are performed.
  29 --        Case 1: A Finalize invoked due to the end of execution of
  30 --        a master. (Defect Report 8652/0023, as reflected in Technical
  31 --        Corrigendum 1).
  32 --        Case 2: A Finalize invoked due to finalization of an anonymous
  33 --        object. (Defect Report 8652/0023, as reflected in Technical
  34 --        Corrigendum 1).
  35 --        Case 3: A Finalize invoked due to the transfer of control
  36 --        due to an exit statement.
  37 --        Case 4: A Finalize invoked due to the transfer of control
  38 --        due to a goto statement.
  39 --        Case 5: A Finalize invoked due to the transfer of control
  40 --        due to a return statement.
  41 --        Case 6: A Finalize invoked due to the transfer of control
  42 --        due to raises an exception.
  43 --
  44 --
  45 -- CHANGE HISTORY:
  46 --    29 JAN 2001   PHL   Initial version
  47 --    15 MAR 2001   RLB   Readied for release; added optimization blockers.
  48 --                        Added test cases for paragraphs 18 and 19 of the
  49 --                        standard (the previous tests were withdrawn).
  50 --
  51 --!
  52 with Ada.Finalization;
  53 use Ada.Finalization;
  54 package C761011_0 is
  55
  56     type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with
  57         record
  58             Finalized : Boolean := False;
  59             case D is
  60                 when False =>
  61                     C1 : Integer;
  62                 when True =>
  63                     C2 : Float;
  64             end case;
  65         end record;
  66
  67     function Create (Id : Integer) return Ctrl;
  68     procedure Finalize (Obj : in out Ctrl);
  69     function Was_Finalized (Id : Integer) return Boolean;
  70     procedure Use_It (Obj : in Ctrl);
  71        -- Use Obj to prevent optimization.
  72
  73 end C761011_0;
  74
  75 with Report;
  76 use Report;
  77 package body C761011_0 is
  78
  79     User_Error : exception;
  80
  81     Finalize_Called : array (0 .. 50) of Boolean := (others => False);
  82
  83     function Create (Id : Integer) return Ctrl is
  84         Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2)));
  85     begin
  86         case Obj.D is
  87             when False =>
  88                 Obj.C1 := Ident_Int (Id);
  89             when True =>
  90                 Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id)));
  91         end case;
  92         return Obj;
  93     end Create;
  94
  95     procedure Finalize (Obj : in out Ctrl) is
  96     begin
  97         if not Obj.Finalized then
  98             Obj.Finalized := True;
  99             if Obj.D then
 100                 if Integer (Obj.C2 / 2.0) mod Ident_Int (10) =
 101                    Ident_Int (3) then
 102                     raise User_Error;
 103                 else
 104                     Finalize_Called (Integer (Obj.C2) / 2) := True;
 105                 end if;
 106             else
 107                 if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then
 108                     raise Tasking_Error;
 109                 else
 110                     Finalize_Called (Obj.C1) := True;
 111                 end if;
 112             end if;
 113         end if;
 114     end Finalize;
 115
 116     function Was_Finalized (Id : Integer) return Boolean is
 117     begin
 118         return Finalize_Called (Ident_Int (Id));
 119     end Was_Finalized;
 120
 121     procedure Use_It (Obj : in Ctrl) is
 122        -- Use Obj to prevent optimization.
 123     begin
 124         case Obj.D is
 125             when True =>
 126                 if not Equal (Boolean'Pos(Obj.Finalized),
 127                               Boolean'Pos(Obj.Finalized)) then
 128                     Failed ("Identity check - 1");
 129                 end if;
 130             when False =>
 131                 if not Equal (Obj.C1, Obj.C1) then
 132                     Failed ("Identity check - 2");
 133                 end if;
 134         end case;
 135     end Use_It;
 136
 137 end C761011_0;
 138
 139 with Ada.Exceptions;
 140 use Ada.Exceptions;
 141 with Ada.Finalization;
 142 with C761011_0;
 143 use C761011_0;
 144 with Report;
 145 use Report;
 146 procedure C761011 is
 147 begin
 148     Test
 149        ("C761011",
 150         " Check that if a finalize propagates an exception, other finalizes " &
 151          "due to be performed are performed");
 152
 153     Normal: -- Case 1
 154         begin
 155             declare
 156                 Obj1 : Ctrl := Create (Ident_Int (1));
 157                 Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
 158                                          D => False,
 159                                          Finalized => Ident_Bool (False),
 160                                          C1 => Ident_Int (2));
 161                 Obj3 : Ctrl :=
 162                    (Ada.Finalization.Controlled with
 163                     D => True,
 164                     Finalized => Ident_Bool (False),
 165                     C2 => 2.0 * Float (Ident_Int
 166                                           (3))); -- Finalization: User_Error
 167                 Obj4 : Ctrl := Create (Ident_Int (4));
 168             begin
 169                 Comment ("Finalization of normal object");
 170                 Use_It (Obj1); -- Prevent optimization of Objects.
 171                 Use_It (Obj2); -- (Critical if AI-147 is adopted.)
 172                 Use_It (Obj3);
 173                 Use_It (Obj4);
 174             end;
 175             Failed ("No exception raised by finalization of normal object");
 176         exception
 177             when Program_Error =>
 178                 if not Was_Finalized (Ident_Int (1)) or
 179                    not Was_Finalized (Ident_Int (2)) or
 180                    not Was_Finalized (Ident_Int (4)) then
 181                     Failed ("Missing finalizations - 1");
 182                 end if;
 183             when E: others =>
 184                 Failed ("Exception " & Exception_Name (E) &
 185                         " raised - " & Exception_Message (E) & " - 1");
 186         end Normal;
 187
 188     Anon: -- Case 2
 189         begin
 190             declare
 191                 Obj1 : Ctrl := (Ada.Finalization.Controlled with
 192                                 D => True,
 193                                 Finalized => Ident_Bool (False),
 194                                 C2 => 2.0 * Float (Ident_Int (5)));
 195                 Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
 196                                          D => False,
 197                                          Finalized => Ident_Bool (False),
 198                                          C1 => Ident_Int (6));
 199                 Obj3 : Ctrl := (Ada.Finalization.Controlled with
 200                                 D => True,
 201                                 Finalized => Ident_Bool (False),
 202                                 C2 => 2.0 * Float (Ident_Int (7)));
 203                 Obj4 : Ctrl := Create (Ident_Int (8));
 204             begin
 205                 Comment ("Finalization of anonymous object");
 206
 207                 -- The finalization of the anonymous object below will raise
 208                 -- Tasking_Error.
 209                 if Create (Ident_Int (10)).C1 /= Ident_Int (10) then
 210                     Failed ("Incorrect construction of an anonymous object");
 211                 end if;
 212                 Failed ("Anonymous object not finalized at the end of the " &
 213                         "enclosing statement");
 214                 Use_It (Obj1); -- Prevent optimization of Objects.
 215                 Use_It (Obj2); -- (Critical if AI-147 is adopted.)
 216                 Use_It (Obj3);
 217                 Use_It (Obj4);
 218             end;
 219             Failed ("No exception raised by finalization of an anonymous " &
 220                     "object of a function");
 221         exception
 222             when Program_Error =>
 223                 if not Was_Finalized (Ident_Int (5)) or
 224                    not Was_Finalized (Ident_Int (6)) or
 225                    not Was_Finalized (Ident_Int (7)) or
 226                    not Was_Finalized (Ident_Int (8)) then
 227                     Failed ("Missing finalizations - 2");
 228                 end if;
 229             when E: others =>
 230                 Failed ("Exception " & Exception_Name (E) &
 231                         " raised - " & Exception_Message (E) & " - 2");
 232         end Anon;
 233
 234     An_Exit: -- Case 3
 235         begin
 236             for Counter in 1 .. 4 loop
 237                 declare
 238                     Obj1 : Ctrl := Create (Ident_Int (11));
 239                     Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
 240                                              D => False,
 241                                              Finalized => Ident_Bool (False),
 242                                              C1 => Ident_Int (12));
 243                     Obj3 : Ctrl :=
 244                         (Ada.Finalization.Controlled with
 245                          D => True,
 246                          Finalized => Ident_Bool (False),
 247                          C2 => 2.0 * Float (
 248                                Ident_Int(13))); -- Finalization: User_Error
 249                     Obj4 : Ctrl := Create (Ident_Int (14));
 250                 begin
 251                     Comment ("Finalization because of exit of loop");
 252
 253                     Use_It (Obj1); -- Prevent optimization of Objects.
 254                     Use_It (Obj2); -- (Critical if AI-147 is adopted.)
 255                     Use_It (Obj3);
 256                     Use_It (Obj4);
 257
 258                     exit when not Ident_Bool (Obj2.D);
 259
 260                     Failed ("Exit not taken");
 261                 end;
 262             end loop;
 263             Failed ("No exception raised by finalization on exit");
 264         exception
 265             when Program_Error =>
 266                 if not Was_Finalized (Ident_Int (11)) or
 267                    not Was_Finalized (Ident_Int (12)) or
 268                    not Was_Finalized (Ident_Int (14)) then
 269                     Failed ("Missing finalizations - 3");
 270                 end if;
 271             when E: others =>
 272                 Failed ("Exception " & Exception_Name (E) &
 273                         " raised - " & Exception_Message (E) & " - 3");
 274         end An_Exit;
 275
 276     A_Goto: -- Case 4
 277         begin
 278             declare
 279                 Obj1 : Ctrl := Create (Ident_Int (15));
 280                 Obj2 : constant Ctrl := (Ada.Finalization.Controlled with
 281                                          D => False,
 282                                          Finalized => Ident_Bool (False),
 283                                          C1 => Ident_Int (0));
 284                              -- Finalization: Tasking_Error
 285                 Obj3 : Ctrl := Create (Ident_Int (16));
 286                 Obj4 : Ctrl := (Ada.Finalization.Controlled with
 287                                 D => True,
 288                                 Finalized => Ident_Bool (False),
 289                                 C2 => 2.0 * Float (Ident_Int (17)));
 290             begin
 291                 Comment ("Finalization because of goto statement");
 292
 293                 Use_It (Obj1); -- Prevent optimization of Objects.
 294                 Use_It (Obj2); -- (Critical if AI-147 is adopted.)
 295                 Use_It (Obj3);
 296                 Use_It (Obj4);
 297
 298                 if Ident_Bool (Obj4.D) then
 299                    goto Continue;
 300                 end if;
 301
 302                 Failed ("Goto not taken");
 303             end;
 304          <<Continue>>
 305             Failed ("No exception raised by finalization on goto");
 306         exception
 307             when Program_Error =>
 308                 if not Was_Finalized (Ident_Int (15)) or
 309                    not Was_Finalized (Ident_Int (16)) or
 310                    not Was_Finalized (Ident_Int (17)) then
 311                     Failed ("Missing finalizations - 4");
 312                 end if;
 313             when E: others =>
 314                 Failed ("Exception " & Exception_Name (E) &
 315                         " raised - " & Exception_Message (E) & " - 4");
 316         end A_Goto;
 317
 318     A_Return: -- Case 5
 319         declare
 320             procedure Do_Something is
 321                 Obj1 : Ctrl := Create (Ident_Int (18));
 322                 Obj2 : Ctrl := (Ada.Finalization.Controlled with
 323                                 D => True,
 324                                 Finalized => Ident_Bool (False),
 325                                 C2 => 2.0 * Float (Ident_Int (19)));
 326                 Obj3 : constant Ctrl := (Ada.Finalization.Controlled with
 327                                          D => False,
 328                                          Finalized => Ident_Bool (False),
 329                                          C1 => Ident_Int (20));
 330                              -- Finalization: Tasking_Error
 331             begin
 332                 Comment ("Finalization because of return statement");
 333
 334                 Use_It (Obj1); -- Prevent optimization of Objects.
 335                 Use_It (Obj2); -- (Critical if AI-147 is adopted.)
 336                 Use_It (Obj3);
 337
 338                 if not Ident_Bool (Obj3.D) then
 339                    return;
 340                 end if;
 341
 342                 Failed ("Return not taken");
 343             end Do_Something;
 344         begin
 345             Do_Something;
 346             Failed ("No exception raised by finalization on return statement");
 347         exception
 348             when Program_Error =>
 349                 if not Was_Finalized (Ident_Int (18)) or
 350                    not Was_Finalized (Ident_Int (19)) then
 351                     Failed ("Missing finalizations - 5");
 352                 end if;
 353             when E: others =>
 354                 Failed ("Exception " & Exception_Name (E) &
 355                         " raised - " & Exception_Message (E) & " - 5");
 356         end A_Return;
 357
 358     Except: -- Case 6
 359         declare
 360             Funky_Error : exception;
 361
 362             procedure Do_Something is
 363                 Obj1 : Ctrl :=
 364                     (Ada.Finalization.Controlled with
 365                      D => True,
 366                      Finalized => Ident_Bool (False),
 367                      C2 => 2.0 * Float (
 368                            Ident_Int(23))); -- Finalization: User_Error
 369                 Obj2 : Ctrl := Create (Ident_Int (24));
 370                 Obj3 : Ctrl := Create (Ident_Int (25));
 371                 Obj4 : constant Ctrl := (Ada.Finalization.Controlled with
 372                                          D => False,
 373                                          Finalized => Ident_Bool (False),
 374                                          C1 => Ident_Int (26));
 375             begin
 376                 Comment ("Finalization because of exception propagation");
 377
 378                 Use_It (Obj1); -- Prevent optimization of Objects.
 379                 Use_It (Obj2); -- (Critical if AI-147 is adopted.)
 380                 Use_It (Obj3);
 381                 Use_It (Obj4);
 382
 383                 if not Ident_Bool (Obj4.D) then
 384                    raise Funky_Error;
 385                 end if;
 386
 387                 Failed ("Exception not raised");
 388             end Do_Something;
 389         begin
 390             Do_Something;
 391             Failed ("No exception raised by finalization on exception " &
 392                     "propagation");
 393         exception
 394             when Program_Error =>
 395                 if not Was_Finalized (Ident_Int (24)) or
 396                    not Was_Finalized (Ident_Int (25)) or
 397                    not Was_Finalized (Ident_Int (26)) then
 398                     Failed ("Missing finalizations - 6");
 399                 end if;
 400             when Funky_Error =>
 401                 Failed ("Wrong exception propagated");
 402                     -- Should be Program_Error (7.6.1(19)).
 403             when E: others =>
 404                 Failed ("Exception " & Exception_Name (E) &
 405                         " raised - " & Exception_Message (E) & " - 6");
 406         end Except;
 407
 408     Result;
 409 end C761011;
 410