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

   1 -- C760011.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 the anonymous objects of a controlled type associated with
  28 --      function results and aggregates are finalized no later than the
  29 --      end of the innermost enclosing declarative_item or statement.  Also
  30 --      check this for function calls and aggregates of a noncontrolled type
  31 --      with controlled components.
  32 --
  33 -- TEST DESCRIPTION:
  34 --      This test defines a controlled type with a discriminant, the
  35 --      discriminant is use as an index into a global table to indicate that
  36 --      the object has been finalized.  The controlled type is used as the
  37 --      component of a non-controlled type, and the non-controlled type is
  38 --      used for the same set of tests.  Following is a table of the tests
  39 --      performed and their associated tag character.
  40 --
  41 --      7.6(21) allows for the optimizations that remove these temporary
  42 --      objects from ever existing.  As such this test checks that in the
  43 --      case the object was initialized (the only access we have to
  44 --      determining if it ever existed) it must subsequently be finalized.
  45 --
  46 -- CASE TABLE:
  47 --      A - aggregate test, controlled
  48 --      B - aggregate test, controlled
  49 --      C - aggregate test, non_controlled
  50 --      D - function test, controlled
  51 --      E - function test, non_controlled
  52 --      F - formal parameter function test, controlled
  53 --      G - formal parameter aggregate test, controlled
  54 --      H - formal parameter function test, non_controlled
  55 --      I - formal parameter aggregate test, non_controlled
  56 --
  57 --      X - scratch object, not consequential to the objective
  58 --      Y - scratch object, not consequential to the objective
  59 --      Z - scratch object, not consequential to the objective
  60 --
  61 --
  62 -- CHANGE HISTORY:
  63 --      22 MAY 95   SAIC    Initial version
  64 --      24 APR 96   SAIC    Minor doc fixes, visibility patch
  65 --      14 NOV 96   SAIC    Revised for release 2.1
  66 --
  67 --!
  68
  69 ------------------------------------------------------------------- C760011_0
  70
  71 with Ada.Finalization;
  72 package C760011_0 is
  73   type Tracking_Array is array(Character range 'A'..'Z') of Boolean;
  74
  75   Initialized : Tracking_Array := (others => False);
  76   Finalized   : Tracking_Array := (others => False);
  77
  78   type Controlled_Type(Tag : Character) is
  79     new Ada.Finalization.Controlled with record
  80       TC_Component : String(1..4) := "ACVC";
  81     end record;
  82   procedure Initialize( It: in out Controlled_Type );
  83   procedure Finalize  ( It: in out Controlled_Type );
  84   function Create(With_Tag: Character) return Controlled_Type;
  85
  86   type Non_Controlled(Tag : Character := 'Y') is record
  87     Controlled_Component : Controlled_Type(Tag);
  88   end record;
  89   procedure Initialize( It: in out Non_Controlled );
  90   procedure Finalize  ( It: in out Non_Controlled );
  91   function Create(With_Tag: Character) return Non_Controlled;
  92
  93   Under_Debug : constant Boolean := False;  -- construction lines
  94
  95 end C760011_0;
  96
  97 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  98
  99 with Report;
 100 package body C760011_0 is
 101
 102   procedure Initialize( It: in out Controlled_Type ) is
 103   begin
 104     It.TC_Component := (others => It.Tag);
 105     if It.Tag in Tracking_Array'Range then
 106       Initialized(It.Tag) := True;
 107     end if;
 108     if Under_Debug then
 109       Report.Comment("Initializing Tag: " & It.Tag );
 110     end if;
 111   end Initialize;
 112
 113   procedure Finalize( It: in out Controlled_Type ) is
 114   begin
 115     if Under_Debug then
 116       Report.Comment("Finalizing for Tag: " & It.Tag );
 117     end if;
 118     if It.Tag in Finalized'Range then
 119       Finalized(It.Tag) := True;
 120     end if;
 121   end Finalize;
 122
 123   function Create(With_Tag: Character) return Controlled_Type is
 124   begin
 125     return Controlled_Type'(Ada.Finalization.Controlled
 126                             with Tag          => With_Tag,
 127                                  TC_Component => "*CON" );
 128   end Create;
 129
 130   procedure Initialize( It: in out Non_Controlled ) is
 131   begin
 132     Report.Failed("Called Initialize for Non_Controlled");
 133   end Initialize;
 134
 135   procedure Finalize( It: in out Non_Controlled ) is
 136   begin
 137     Report.Failed("Called Finalize for Non_Controlled");
 138   end Finalize;
 139
 140   function Create(With_Tag: Character) return Non_Controlled is
 141   begin
 142     return Non_Controlled'(Tag => With_Tag, Controlled_Component => (
 143                                   Ada.Finalization.Controlled
 144                                     with Tag          => With_Tag,
 145                                          TC_Component => "#NON" ) );
 146   end Create;
 147
 148 end C760011_0;
 149
 150 --------------------------------------------------------------------- C760011
 151
 152 with Report;
 153 with TCTouch;
 154 with C760011_0;
 155 with Ada.Finalization; -- needed to be able to create extension aggregates
 156 procedure C760011 is
 157
 158   use type C760011_0.Controlled_Type;
 159   use type C760011_0.Controlled_Type'Class;
 160   use type C760011_0.Non_Controlled;
 161
 162   subtype AFC is Ada.Finalization.Controlled;
 163
 164   procedure Check_Result( Tag : Character; Message : String ) is
 165   -- make allowance for 7.6(21) optimizations
 166   begin
 167     if C760011_0.Initialized(Tag) then
 168       TCTouch.Assert(C760011_0.Finalized(Tag),Message);
 169     elsif C760011_0.Under_Debug then
 170       Report.Comment("Optimized away: " & Tag );
 171     end if;
 172   end Check_Result;
 173
 174   procedure Subtest_1 is
 175
 176
 177     procedure Subtest_1_Local_1 is
 178       An_Object : C760011_0.Controlled_Type'Class
 179                 := C760011_0.Controlled_Type'(AFC with 'X', "ONE*");
 180                    -- initialize An_Object
 181     begin
 182       if C760011_0.Controlled_Type(An_Object)
 183          = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then
 184         Report.Failed("Comparison bad");  -- A = X !!!
 185       end if;
 186     end Subtest_1_Local_1;
 187     -- An_Object must be Finalized by this point.
 188
 189     procedure Subtest_1_Local_2 is
 190       An_Object : C760011_0.Controlled_Type('B');
 191     begin
 192       An_Object := (AFC with 'B',  "TWO!" );
 193       if Report.Ident_Char(An_Object.Tag) /= 'B' then
 194         Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!");
 195       end if;
 196     exception
 197       when others => Report.Failed("Bad controlled assignment");
 198     end Subtest_1_Local_2;
 199     -- An_Object must be Finalized by this point.
 200
 201     procedure Subtest_1_Local_3 is
 202       An_Object : C760011_0.Non_Controlled('C');
 203     begin
 204       TCTouch.Assert_Not(C760011_0.Finalized('C'),
 205                            "Non_Controlled declaration C");
 206       An_Object := C760011_0.Non_Controlled'('C', Controlled_Component
 207                                      => (AFC with 'C', "TEE!"));
 208       if Report.Ident_Char(An_Object.Tag) /= 'C' then
 209         Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!");
 210       end if;
 211     end Subtest_1_Local_3;
 212     -- Only controlled components of An_Object must be finalized; it is an
 213     -- error to call Finalize for An_Object
 214
 215   begin
 216     Subtest_1_Local_1;
 217     Check_Result( 'A', "Aggregate in subprogram 1" );
 218
 219     Subtest_1_Local_2;
 220     Check_Result( 'B', "Aggregate in subprogram 2" );
 221
 222     Subtest_1_Local_3;
 223     Check_Result( 'C', "Embedded aggregate in subprogram 3" );
 224   end Subtest_1;
 225
 226
 227   procedure Subtest_2 is
 228     -- using 'Z' for both evades order issues
 229     Con_Object : C760011_0.Controlled_Type('Z');
 230     Non_Object : C760011_0.Non_Controlled('Z');
 231   begin
 232     if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then
 233       Report.Failed("Con_Object catastrophe");
 234     end if;
 235      -- Controlled function result should be finalized by now
 236     Check_Result( 'D', "Function Result" );
 237
 238     if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then
 239       Report.Failed("Non_Object catastrophe");
 240     end if;
 241      -- Controlled component of function result should be finalized by now
 242     Check_Result( 'E', "Function Result" );
 243   end Subtest_2;
 244
 245
 246   procedure Subtest_3(Con : in C760011_0.Controlled_Type) is
 247   begin
 248     if Con.Tag not in 'F'..'G' then
 249       Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' '
 250                     & Report.Ident_Str(Con.TC_Component));
 251     end if;
 252   end Subtest_3;
 253
 254
 255   procedure Subtest_4(Non : in C760011_0.Non_Controlled) is
 256   begin
 257     if Non.Tag not in 'H'..'I' then
 258       Report.Failed("Bad value passed to subtest 4 "
 259                    & Non.Tag & ' '
 260                    & Report.Ident_Str(Non.Controlled_Component.TC_Component));
 261     end if;
 262   end Subtest_4;
 263
 264
 265 begin  -- Main test procedure.
 266
 267   Report.Test ("C760011", "Check that anonymous objects of controlled " &
 268                           "types or types containing controlled types " &
 269                           "are finalized no later than the end of the " &
 270                           "innermost enclosing declarative_item or " &
 271                           "statement" );
 272
 273   Subtest_1;
 274
 275   Subtest_2;
 276
 277   Subtest_3(C760011_0.Create('F'));
 278   Check_Result( 'F', "Function as formal F" );
 279
 280   Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI"));
 281   Check_Result( 'G', "Aggregate as formal G" );
 282
 283   Subtest_4(C760011_0.Create('H'));
 284   Check_Result( 'H', "Function as formal H" );
 285
 286   Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO")));
 287   Check_Result( 'I', "Aggregate as formal I" );
 288
 289   Report.Result;
 290
 291 end C760011;