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

   1 -- C761005.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 deriving abstract types from the types in Ada.Finalization
  28 --      does not negatively impact the implicit operations.
  29 --      Check that an object of a controlled type is finalized when the
  30 --      enclosing master is complete.
  31 --      Check that finalization occurs in the case where the master is
  32 --      left by a transfer of control.
  33 --      Check this for controlled types where the derived type has a
  34 --      discriminant.
  35 --      Check this for cases where the type is defined as private,
  36 --      and the full type is derived from the types in Ada.Finalization.
  37 --
  38 --      Check that finalization of controlled objects is
  39 --      performed in the correct order.  In particular, check that if
  40 --      multiple objects of controlled types are declared immediately
  41 --      within the same declarative part then type are finalized in the
  42 --      reverse order of their creation.
  43 --
  44 -- TEST DESCRIPTION:
  45 --      This test checks these conditions for subprograms and
  46 --      block statements; both variables and constants of controlled
  47 --      types; cases of a controlled component of a record type, as
  48 --      well as an array with controlled components.
  49 --
  50 --      The base controlled types used for the test are defined
  51 --      with a character discriminant.  The initialize procedure for
  52 --      the types will record the order of creation in a globally
  53 --      accessible array, the finalize procedure for the types will call
  54 --      TCTouch with that tag character.  The test can then check that
  55 --      the order of finalization is indeed the reverse of the order of
  56 --      creation (assuming that the implementation calls Initialize in
  57 --      the order that the objects are created).
  58 --
  59 --
  60 -- CHANGE HISTORY:
  61 --      06 Dec 94   SAIC    ACVC 2.0
  62 --      10 Oct 95   SAIC    Fixed bugs for ACVC 2.0.1
  63 --
  64 --!
  65
  66 package C761005_Support is
  67
  68   function Pick_Char return Character;
  69   procedure Validate(Initcount: Natural; Testnumber:Natural);
  70
  71   Inits_Order  : String(1..255);
  72   Inits_Called : Natural := 0;
  73
  74 end C761005_Support;
  75
  76 with Report;
  77 with TCTouch;
  78 package body C761005_Support is
  79   type Pick_Rotation is mod 52;
  80   type Pick_String is array(Pick_Rotation) of Character;
  81
  82   From : constant Pick_String  := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  83                                 & "abcdefghijklmnopqrstuvwxyz";
  84   Recent_Pick : Pick_Rotation := Pick_Rotation'Last;
  85
  86   function Pick_Char return Character is
  87   begin
  88     Recent_Pick := Recent_Pick +1;
  89     return From(Recent_Pick);
  90   end Pick_Char;
  91
  92   function Invert(S:String) return String is
  93     T: String(1..S'Length);
  94     TI: Positive := 1;
  95   begin
  96     for SI in reverse S'Range loop
  97       T(TI) := S(SI);
  98       TI := TI +1;
  99     end loop;
 100     return T;
 101   end Invert;
 102
 103   procedure Validate(Initcount: Natural; Testnumber:Natural) is
 104     Number : constant String := Natural'Image(Testnumber);
 105   begin
 106     if Inits_Called /= Initcount then
 107       Report.Failed("Wrong number of inits, Subtest " & Number);
 108     else
 109       TCTouch.Validate(
 110         Invert(Inits_Order(1..Inits_Called)),
 111                "Subtest " & Number, True);
 112     end if;
 113     Inits_Called := 0;
 114   end Validate;
 115
 116 end C761005_Support;
 117
 118 -----------------------------------------------------------------------------
 119 with Ada.Finalization;
 120 package C761005_0 is
 121   type Final_Root(Tag: Character) is private;
 122
 123   type Ltd_Final_Root(Tag: Character) is limited private;
 124
 125   Inits_Order  : String(1..255);
 126   Inits_Called : Natural := 0;
 127 private
 128   type Final_Root(Tag: Character) is new Ada.Finalization.Controlled
 129     with null record;
 130   procedure Initialize( It: in out Final_Root );
 131   procedure Finalize  ( It: in out Final_Root );
 132
 133   type Ltd_Final_Root(Tag: Character) is new
 134 Ada.Finalization.Limited_Controlled
 135     with null record;
 136   procedure Initialize( It: in out Ltd_Final_Root );
 137   procedure Finalize  ( It: in out Ltd_Final_Root );
 138 end C761005_0;
 139
 140 -----------------------------------------------------------------------------
 141 with Ada.Finalization;
 142 package C761005_1 is
 143   type Final_Abstract is abstract tagged private;
 144
 145   type Ltd_Final_Abstract_Child is abstract tagged limited private;
 146
 147   Inits_Order  : String(1..255);
 148   Inits_Called : Natural := 0;
 149
 150 private
 151   type Final_Abstract is abstract new Ada.Finalization.Controlled with record
 152     Tag: Character;
 153   end record;
 154   procedure Initialize( It: in out Final_Abstract );
 155   procedure Finalize  ( It: in out Final_Abstract );
 156
 157   type Ltd_Final_Abstract_Child is
 158        abstract new Ada.Finalization.Limited_Controlled with record
 159     Tag: Character;
 160   end record;
 161   procedure Initialize( It: in out Ltd_Final_Abstract_Child );
 162   procedure Finalize  ( It: in out Ltd_Final_Abstract_Child );
 163
 164 end C761005_1;
 165
 166 -----------------------------------------------------------------------------
 167 with C761005_1;
 168 package C761005_2 is
 169
 170   type Final_Child is new C761005_1.Final_Abstract with null record;
 171   type Ltd_Final_Child is
 172        new C761005_1.Ltd_Final_Abstract_Child with null record;
 173
 174 end C761005_2;
 175
 176 -----------------------------------------------------------------------------
 177 with Report;
 178 with TCTouch;
 179 with C761005_Support;
 180 package body C761005_0 is
 181
 182   package Sup renames C761005_Support;
 183
 184   procedure Initialize( It: in out Final_Root ) is
 185   begin
 186     Sup.Inits_Called := Sup.Inits_Called +1;
 187     Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
 188   end Initialize;
 189
 190   procedure Finalize( It: in out Final_Root ) is
 191   begin
 192     TCTouch.Touch(It.Tag);
 193   end Finalize;
 194
 195   procedure Initialize( It: in out Ltd_Final_Root ) is
 196   begin
 197     Sup.Inits_Called := Sup.Inits_Called +1;
 198     Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
 199   end Initialize;
 200
 201   procedure Finalize( It: in out Ltd_Final_Root ) is
 202   begin
 203     TCTouch.Touch(It.Tag);
 204   end Finalize;
 205 end C761005_0;
 206
 207 -----------------------------------------------------------------------------
 208 with Report;
 209 with TCTouch;
 210 with C761005_Support;
 211 package body C761005_1 is
 212
 213   package Sup renames C761005_Support;
 214
 215   procedure Initialize( It: in out Final_Abstract ) is
 216   begin
 217     Sup.Inits_Called := Sup.Inits_Called +1;
 218     It.Tag := Sup.Pick_Char;
 219     Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
 220   end Initialize;
 221
 222   procedure Finalize( It: in out Final_Abstract ) is
 223   begin
 224     TCTouch.Touch(It.Tag);
 225   end Finalize;
 226
 227   procedure Initialize( It: in out Ltd_Final_Abstract_Child ) is
 228   begin
 229     Sup.Inits_Called := Sup.Inits_Called +1;
 230     It.Tag := Sup.Pick_Char;
 231     Sup.Inits_Order(Sup.Inits_Called) := It.Tag;
 232   end Initialize;
 233
 234   procedure Finalize( It: in out Ltd_Final_Abstract_Child ) is
 235   begin
 236     TCTouch.Touch(It.Tag);
 237   end Finalize;
 238 end C761005_1;
 239
 240 -----------------------------------------------------------------------------
 241 with Report;
 242 with TCTouch;
 243 with C761005_0;
 244 with C761005_2;
 245 with C761005_Support;
 246 procedure C761005 is
 247
 248   package Sup renames C761005_Support;
 249
 250   Subtest_1_Inits_Expected : constant := 4;
 251   procedure Subtest_1 is
 252     Item_1 : C761005_0.Final_Root(Sup.Pick_Char);
 253     Item_2, Item_3 : C761005_0.Final_Root(Sup.Pick_Char);
 254     Item_4 : C761005_0.Ltd_Final_Root(Sup.Pick_Char);
 255   begin
 256     -- check that nothing has happened yet!
 257     TCTouch.Validate("","Subtest 1 body");
 258   end Subtest_1;
 259
 260   -- These declarations should cause calls to initialize and
 261   -- finalize.  The expected operations are the subprograms associated
 262   -- with the abstract types.
 263   Subtest_2_Inits_Expected : constant := 4;
 264   procedure Subtest_2 is
 265     Item_1 : C761005_2.Final_Child;
 266     Item_2, Item_3 : C761005_2.Final_Child;
 267     Item_4 : C761005_2.Ltd_Final_Child;
 268   begin
 269     -- check that nothing has happened yet!
 270     TCTouch.Validate("","Subtest 2 body");
 271   end Subtest_2;
 272
 273 begin  -- Main test procedure.
 274
 275   Report.Test ("C761005", "Check that an object of a controlled type "
 276                         & "is finalized when the enclosing master is "
 277                         & "complete, left by a transfer of control, "
 278                         & "and performed in the correct order" );
 279
 280   Subtest_1;
 281   Sup.Validate(Subtest_1_Inits_Expected,1);
 282
 283   Subtest_2;
 284   Sup.Validate(Subtest_2_Inits_Expected,2);
 285
 286   Report.Result;
 287
 288 end C761005;