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

   1 -- C761006.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 Program_Error is raised when:
  28 --        * an exception is raised if Finalize invoked as part of an
  29 --          assignment operation; or
  30 --        * an exception is raised if Adjust invoked as part of an assignment
  31 --          operation, after any other adjustment due to be performed are
  32 --          performed; or
  33 --        * an exception is raised if Finalize invoked as part of a call on
  34 --          Unchecked_Deallocation, after any other finalizations to be
  35 --          performed are performed.
  36 --
  37 -- TEST DESCRIPTION:
  38 --      This test defines these four controlled types:
  39 --        Good
  40 --        Bad_Initialize
  41 --        Bad_Adjust
  42 --        Bad_Finalize
  43 --      The type name conveys the associated failure.  The operations in type
  44 --      good will "touch" the boolean array indicating correct path
  45 --      utilization for the purposes of checking "other <operations> are
  46 --      performed", where <operations> ::= initialization, adjusting, and
  47 --      finalization
  48 --
  49 --
  50 --
  51 -- CHANGE HISTORY:
  52 --      12 APR 94   SAIC   Initial version
  53 --      02 MAY 96   SAIC   Visibility fixed for 2.1
  54 --      13 FEB 97   PWB.CTA Corrected value of Events_Occurring at line 286
  55 --      01 DEC 97   EDS    Made correction wrt RM 7.6(21)
  56 --      16 MAR 01   RLB    Corrected Adjust cases to avoid problems with
  57 --                         RM 7.6.1(16/1) from Technical Corrigendum 1.
  58 --
  59 --!
  60
  61 ------------------------------------------------------------- C761006_Support
  62
  63 package C761006_Support is
  64
  65   type Events is ( Good_Initialize, Good_Adjust, Good_Finalize );
  66
  67   type Event_Array is array(Events) of Boolean;
  68
  69   Events_Occurring : Event_Array := (others => False);
  70
  71   Propagating_Exception : exception;
  72
  73   procedure Raise_Propagating_Exception(Do_It: Boolean);
  74
  75   function Unique_Value return Natural;
  76
  77 end C761006_Support;
  78
  79 ------------------------------------------------------------- C761006_Support
  80
  81 with Report;
  82 package body C761006_Support is
  83
  84   procedure Raise_Propagating_Exception(Do_It: Boolean) is
  85   begin
  86      if Report.Ident_Bool(Do_It) then
  87        raise Propagating_Exception;
  88      end if;
  89   end Raise_Propagating_Exception;
  90
  91   Seed : Natural := 0;
  92
  93   function Unique_Value return Natural is
  94   begin
  95     Seed := Seed +1;
  96     return Seed;
  97   end Unique_Value;
  98
  99 end C761006_Support;
 100
 101 ------------------------------------------------------------------- C761006_0
 102
 103 with Ada.Finalization;
 104 with C761006_Support;
 105 package C761006_0 is
 106
 107   type Good is new Ada.Finalization.Controlled
 108     with record
 109       Initialized : Boolean := False;
 110       Adjusted    : Boolean := False;
 111       Unique      : Natural := C761006_Support.Unique_Value;
 112     end record;
 113
 114   procedure Initialize( It: in out Good );
 115   procedure Adjust    ( It: in out Good );
 116   procedure Finalize  ( It: in out Good );
 117
 118   type Bad_Initialize is private;
 119
 120   type Bad_Adjust     is private;
 121
 122   type Bad_Finalize   is private;
 123
 124   Inits_Order  : String(1..255);
 125   Inits_Called : Natural := 0;
 126 private
 127   type Bad_Initialize is new Ada.Finalization.Controlled
 128                                              with null record;
 129   procedure Initialize( It: in out Bad_Initialize );
 130
 131   type Bad_Adjust is new Ada.Finalization.Controlled
 132                                          with null record;
 133   procedure Adjust    ( It: in out Bad_Adjust );
 134
 135   type Bad_Finalize is
 136        new Ada.Finalization.Controlled with null record;
 137   procedure Finalize  ( It: in out Bad_Finalize );
 138 end C761006_0;
 139
 140 ------------------------------------------------------------------- C761006_1
 141
 142 with Ada.Finalization;
 143 with C761006_0;
 144 package C761006_1 is
 145
 146   type Init_Check_Root is new Ada.Finalization.Controlled with record
 147     Good_Component : C761006_0.Good;
 148     Init_Fails     : C761006_0.Bad_Initialize;
 149   end record;
 150
 151   type Adj_Check_Root is new Ada.Finalization.Controlled with record
 152     Good_Component : C761006_0.Good;
 153     Adj_Fails      : C761006_0.Bad_Adjust;
 154   end record;
 155
 156   type Fin_Check_Root is new Ada.Finalization.Controlled with record
 157     Good_Component : C761006_0.Good;
 158     Fin_Fails      : C761006_0.Bad_Finalize;
 159   end record;
 160
 161 end C761006_1;
 162
 163 ------------------------------------------------------------------- C761006_2
 164
 165 with C761006_1;
 166 package C761006_2 is
 167
 168   type Init_Check is new C761006_1.Init_Check_Root with null record;
 169   type Adj_Check is  new C761006_1.Adj_Check_Root  with null record;
 170   type Fin_Check is  new C761006_1.Fin_Check_Root  with null record;
 171
 172 end C761006_2;
 173
 174 ------------------------------------------------------------------- C761006_0
 175
 176 with Report;
 177 with C761006_Support;
 178 package body C761006_0 is
 179
 180   package Sup renames C761006_Support;
 181
 182   procedure Initialize( It: in out Good ) is
 183   begin
 184     Sup.Events_Occurring( Sup.Good_Initialize ) := True;
 185     It.Initialized := True;
 186   end Initialize;
 187
 188   procedure Adjust    ( It: in out Good ) is
 189   begin
 190     Sup.Events_Occurring( Sup.Good_Adjust ) := True;
 191     It.Adjusted := True;
 192     It.Unique := C761006_Support.Unique_Value;
 193   end Adjust;
 194
 195   procedure Finalize  ( It: in out Good ) is
 196   begin
 197     Sup.Events_Occurring( Sup.Good_Finalize ) := True;
 198   end Finalize;
 199
 200   procedure Initialize( It: in out Bad_Initialize ) is
 201   begin
 202     Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
 203   end Initialize;
 204
 205   procedure Adjust( It: in out Bad_Adjust ) is
 206   begin
 207     Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
 208   end Adjust;
 209
 210   procedure Finalize( It: in out Bad_Finalize ) is
 211   begin
 212     Sup.Raise_Propagating_Exception(Report.Ident_Bool(True));
 213   end Finalize;
 214
 215 end C761006_0;
 216
 217 --------------------------------------------------------------------- C761006
 218
 219 with Report;
 220 with C761006_0;
 221 with C761006_2;
 222 with C761006_Support;
 223 with Ada.Exceptions;
 224 with Ada.Finalization;
 225 with Unchecked_Deallocation;
 226 procedure C761006 is
 227
 228   package Sup renames C761006_Support;
 229   use type Sup.Event_Array;
 230
 231   type Procedure_Handle is access procedure;
 232
 233   type Test_ID is ( Simple, Initialize, Adjust, Finalize );
 234
 235   Sub_Tests : array(Test_ID) of Procedure_Handle;
 236
 237   procedure Simple_Test is
 238     A_Good_Object : C761006_0.Good; -- should call Initialize
 239   begin
 240     if not A_Good_Object.Initialized then
 241       Report.Failed("Good object not initialized");
 242     end if;
 243
 244     -- should call Adjust
 245     A_Good_Object := ( Ada.Finalization.Controlled
 246                        with Unique => 0, others => False );
 247     if not A_Good_Object.Adjusted then
 248       Report.Failed("Good object not adjusted");
 249     end if;
 250
 251     -- should call Finalize before end of scope
 252   end Simple_Test;
 253
 254   procedure Initialize_Test is
 255   begin
 256     declare
 257       This_Object_Fails_In_Initialize : C761006_2.Init_Check;
 258     begin
 259       Report.Failed("Exception in Initialize did not occur");
 260     exception
 261       when others =>
 262         Report.Failed("Initialize caused exception at wrong lex");
 263     end;
 264
 265     Report.Failed("Error in execution sequence");
 266
 267   exception
 268     when Sup.Propagating_Exception => -- this is correct
 269       if not Sup.Events_Occurring(Sup.Good_Initialize) then
 270         Report.Failed("Initialization of Good Component did not occur");
 271       end if;
 272   end Initialize_Test;
 273
 274   procedure Adjust_Test is
 275     This_Object_OK     : C761006_2.Adj_Check;
 276     This_Object_Target : C761006_2.Adj_Check;
 277   begin
 278
 279     Check_Adjust_Due_To_Assignment: begin
 280       This_Object_Target := This_Object_OK;
 281       Report.Failed("Adjust did not propagate any exception");
 282     exception
 283       when Program_Error =>  -- expected case
 284              if not This_Object_Target.Good_Component.Adjusted then
 285                Report.Failed("other adjustment not performed");
 286              end if;
 287       when others =>
 288              Report.Failed("Adjust propagated wrong exception");
 289     end Check_Adjust_Due_To_Assignment;
 290
 291     C761006_Support.Events_Occurring := (True, False, False);
 292
 293     Check_Adjust_Due_To_Initial_Assignment: declare
 294       Another_Target : C761006_2.Adj_Check := This_Object_OK;
 295     begin
 296       Report.Failed("Adjust did not propagate any exception");
 297     exception
 298       when others => Report.Failed("Adjust caused exception at wrong lex");
 299     end Check_Adjust_Due_To_Initial_Assignment;
 300
 301   exception
 302     when Program_Error =>  -- expected case
 303            if Sup.Events_Occurring(Sup.Good_Finalize) /=
 304               Sup.Events_Occurring(Sup.Good_Adjust) then
 305               -- RM 7.6.1(16/1) says that the good Adjust may or may not
 306               -- be performed; but if it is, then the Finalize must be
 307               -- performed; and if it is not, then the Finalize must not
 308               -- performed.
 309               if Sup.Events_Occurring(Sup.Good_Finalize) then
 310                  Report.Failed("Good adjust not performed with bad adjust, " &
 311                                "but good finalize was");
 312               else
 313                  Report.Failed("Good adjust performed with bad adjust, " &
 314                                "but good finalize was not");
 315               end if;
 316            end if;
 317     when others =>
 318            Report.Failed("Adjust propagated wrong exception");
 319   end Adjust_Test;
 320
 321   procedure Finalize_Test is
 322
 323     Fin_Not_Perf : constant String := "other finalizations not performed";
 324
 325     procedure Finalize_15 is
 326       Item   : C761006_2.Fin_Check;
 327       Target : C761006_2.Fin_Check;
 328     begin
 329
 330       Item := Target;
 331       -- finalization of Item should cause PE
 332       -- ARM7.6:21 allows the implementation to omit the assignment of the
 333       -- value into an anonymous object, which is the point at which Adjust
 334       -- is normally called.  However, this would result in Program_Error's
 335       -- being raised before the call to Adjust, with the consequence that
 336       -- Adjust is never called.
 337
 338     exception
 339       when Program_Error => -- expected case
 340              if not Sup.Events_Occurring(Sup.Good_Finalize) then
 341                Report.Failed("Assignment: " & Fin_Not_Perf);
 342              end if;
 343       when others =>
 344              Report.Failed("Other exception in Finalize_15");
 345
 346     -- finalization of Item/Target should cause PE
 347     end Finalize_15;
 348
 349   -- check failure in finalize due to Unchecked_Deallocation
 350
 351   type Shark is access C761006_2.Fin_Check;
 352
 353   procedure Catch is
 354     new Unchecked_Deallocation( C761006_2.Fin_Check, Shark );
 355
 356   procedure Finalize_17 is
 357     White : Shark := new C761006_2.Fin_Check;
 358   begin
 359     Catch( White );
 360   exception
 361     when Program_Error =>
 362            if not Sup.Events_Occurring(Sup.Good_Finalize) then
 363              Report.Failed("Unchecked_Deallocation: " & Fin_Not_Perf);
 364            end if;
 365   end Finalize_17;
 366
 367   begin
 368
 369     Exception_In_Finalization: begin
 370       Finalize_15;
 371     exception
 372       when Program_Error => null; -- anticipated
 373     end Exception_In_Finalization;
 374
 375     Use_Of_Unchecked_Deallocation: begin
 376       Finalize_17;
 377     exception
 378       when others =>
 379         Report.Failed("Unchecked_Deallocation check, unwanted exception");
 380     end Use_Of_Unchecked_Deallocation;
 381
 382   end Finalize_Test;
 383
 384 begin  -- Main test procedure.
 385
 386   Report.Test ("C761006", "Check that exceptions raised in Initialize, " &
 387                           "Adjust and Finalize are processed correctly" );
 388
 389   Sub_Tests := (Simple_Test'Access, Initialize_Test'Access,
 390                 Adjust_Test'Access, Finalize_Test'Access);
 391
 392   for Test in Sub_Tests'Range loop
 393     begin
 394
 395       Sup.Events_Occurring := (others => False);
 396
 397       Sub_Tests(Test).all;
 398
 399       case Test is
 400         when Simple | Adjust =>
 401           if Sup.Events_Occurring /= Sup.Event_Array ' ( others => True ) then
 402             Report.Failed ( "Other operation missing in " &
 403                             Test_ID'Image ( Test ) );
 404           end if;
 405         when  Initialize =>
 406           null;
 407         when Finalize  =>
 408           -- Note that for Good_Adjust, we may get either True or False
 409           if Sup.Events_Occurring ( Sup.Good_Initialize ) = False or
 410              Sup.Events_Occurring ( Sup.Good_Finalize ) = False
 411           then
 412             Report.Failed ( "Other operation missing in " &
 413                             Test_ID'Image ( Test ) );
 414           end if;
 415       end case;
 416
 417     exception
 418        when How: others => Report.Failed( Ada.Exceptions.Exception_Name( How )
 419                                         & " from " & Test_ID'Image( Test ) );
 420     end;
 421   end loop;
 422
 423   Report.Result;
 424
 425 end C761006;