gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a

   1 -- CDB0A02.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 several access types can share the same pool.
  28 --
  29 --      Check that any exception propagated by Allocate is
  30 --      propagated by the allocator.
  31 --
  32 --      Check that for an access type S, S'Max_Size_In_Storage_Elements
  33 --      denotes the maximum values for Size_In_Storage_Elements that will
  34 --      be requested via Allocate.
  35 --
  36 -- TEST DESCRIPTION:
  37 --      After checking correct operation of the tree packages, the limits of
  38 --      the storage pools (first the shared user defined storage pool, then
  39 --      the system storage pool) are intentionally exceeded.  The test checks
  40 --      that the correct exception is raised.
  41 --
  42 --
  43 -- TEST FILES:
  44 --      The following files comprise this test:
  45 --
  46 --         FDB0A00.A   (foundation code)
  47 --         CDB0A02.A
  48 --
  49 --
  50 -- CHANGE HISTORY:
  51 --      10 AUG 95   SAIC   Initial version
  52 --      07 MAY 96   SAIC   Disambiguated for 2.1
  53 --      13 FEB 97   PWB.CTA  Reduced minimum allowable
  54 --                           Max_Size_In_Storage_Units, for implementations
  55 --                           with larger storage units
  56 --      25 JAN 01   RLB    Removed dubious checks on Max_Size_In_Storage_Units;
  57 --                         tightened important one.
  58
  59 --!
  60
  61 ---------------------------------------------------------- FDB0A00.Pool2
  62
  63 package FDB0A00.Pool2 is
  64   Pond : Stack_Heap( 5_000 );
  65 end FDB0A00.Pool2;
  66
  67 ---------------------------------------------------------------- CDB0A02_2
  68
  69 with FDB0A00.Pool2;
  70 package CDB0A02_2 is
  71
  72   type Small_Cell;
  73   type Small_Tree is access Small_Cell;
  74
  75   for Small_Tree'Storage_Pool use FDB0A00.Pool2.Pond;  -- first usage
  76
  77   type Small_Cell is record
  78     Data: Character;
  79     Left,Right : Small_Tree;
  80   end record;
  81
  82   procedure Insert( Item: Character; On_Tree : in out Small_Tree );
  83
  84   procedure Traverse( The_Tree : Small_Tree );
  85
  86   procedure Defoliate( The_Tree : in out Small_Tree );
  87
  88   procedure TC_Exceed_Pool;
  89
  90   Pool_Max_Elements : constant := 6000;
  91                       -- to guarantee overflow in TC_Exceed_Pool
  92
  93 end CDB0A02_2;
  94
  95 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  96
  97 with TCTouch;
  98 with Report;
  99 with Unchecked_Deallocation;
 100 package body CDB0A02_2 is
 101   procedure Deallocate is new Unchecked_Deallocation(Small_Cell,Small_Tree);
 102
 103   -- Sort: zeros on the left, ones on the right...
 104   procedure Insert( Item: Character; On_Tree : in out Small_Tree ) is
 105   begin
 106     if On_Tree = null then
 107       On_Tree := new Small_Cell'(Item,null,null);
 108     elsif Item > On_Tree.Data then
 109       Insert(Item,On_Tree.Right);
 110     else
 111       Insert(Item,On_Tree.Left);
 112     end if;
 113   end Insert;
 114
 115   procedure Traverse( The_Tree : Small_Tree ) is
 116   begin
 117     if The_Tree = null then
 118       null;  -- how very symmetrical
 119     else
 120       Traverse(The_Tree.Left);
 121       TCTouch.Touch(The_Tree.Data);
 122       Traverse(The_Tree.Right);
 123     end if;
 124   end Traverse;
 125
 126   procedure Defoliate( The_Tree : in out Small_Tree ) is
 127   begin
 128
 129     if The_Tree.Left /= null then
 130       Defoliate(The_Tree.Left);
 131     end if;
 132
 133     if The_Tree.Right /= null then
 134       Defoliate(The_Tree.Right);
 135     end if;
 136
 137     Deallocate(The_Tree);
 138
 139   end Defoliate;
 140
 141   procedure TC_Exceed_Pool is
 142     Wild_Branch : Small_Tree;
 143   begin
 144     for Ever in 1..Pool_Max_Elements loop
 145        Wild_Branch := new Small_Cell'('a', Wild_Branch, Wild_Branch);
 146        TCTouch.Validate("A","Allocating element for overflow");
 147     end loop;
 148     Report.Failed(" Pool_Overflow not raised on exceeding user pool size");
 149   exception
 150     when FDB0A00.Pool_Overflow => null; -- anticipated case
 151     when others =>
 152       Report.Failed("wrong exception raised in user Exceed_Pool");
 153   end TC_Exceed_Pool;
 154
 155 end CDB0A02_2;
 156
 157 ---------------------------------------------------------------- CDB0A02_3
 158
 159 -- This package is essentially identical to CDB0A02_2, except that the size
 160 -- of a cell is significantly larger.  This is used to check that different
 161 -- access types may share a single pool
 162
 163 with FDB0A00.Pool2;
 164 package CDB0A02_3 is
 165
 166   type Large_Cell;
 167   type Large_Tree is access Large_Cell;
 168
 169   for Large_Tree'Storage_Pool use FDB0A00.Pool2.Pond;  -- second usage
 170
 171   type Large_Cell is record
 172     Data: Character;
 173     Extra_Data : String(1..2);
 174     Left,Right : Large_Tree;
 175   end record;
 176
 177   procedure Insert( Item: Character; On_Tree : in out Large_Tree );
 178
 179   procedure Traverse( The_Tree : Large_Tree );
 180
 181   procedure Defoliate( The_Tree : in out Large_Tree );
 182
 183 end CDB0A02_3;
 184
 185 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 186
 187 with TCTouch;
 188 with Unchecked_Deallocation;
 189 package body CDB0A02_3 is
 190   procedure Deallocate is new Unchecked_Deallocation(Large_Cell,Large_Tree);
 191
 192   -- Sort: zeros on the left, ones on the right...
 193   procedure Insert( Item: Character; On_Tree : in out Large_Tree ) is
 194   begin
 195     if On_Tree = null then
 196       On_Tree := new Large_Cell'(Item,(Item,Item),null,null);
 197     elsif Item > On_Tree.Data then
 198       Insert(Item,On_Tree.Right);
 199     else
 200       Insert(Item,On_Tree.Left);
 201     end if;
 202   end Insert;
 203
 204   procedure Traverse( The_Tree : Large_Tree ) is
 205   begin
 206     if The_Tree = null then
 207       null;  -- how very symmetrical
 208     else
 209       Traverse(The_Tree.Left);
 210       TCTouch.Touch(The_Tree.Data);
 211       Traverse(The_Tree.Right);
 212     end if;
 213   end Traverse;
 214
 215   procedure Defoliate( The_Tree : in out Large_Tree ) is
 216   begin
 217
 218     if The_Tree.Left /= null then
 219       Defoliate(The_Tree.Left);
 220     end if;
 221
 222     if The_Tree.Right /= null then
 223       Defoliate(The_Tree.Right);
 224     end if;
 225
 226     Deallocate(The_Tree);
 227
 228  end Defoliate;
 229
 230 end CDB0A02_3;
 231
 232 ------------------------------------------------------------------ CDB0A02
 233
 234 with Report;
 235 with TCTouch;
 236 with System.Storage_Elements;
 237 with CDB0A02_2;
 238 with CDB0A02_3;
 239 with FDB0A00;
 240
 241 procedure CDB0A02 is
 242
 243   Banyan : CDB0A02_2.Small_Tree;
 244   Torrey : CDB0A02_3.Large_Tree;
 245
 246   use type CDB0A02_2.Small_Tree;
 247   use type CDB0A02_3.Large_Tree;
 248
 249   Countess1    : constant String := "Ada ";
 250   Countess2    : constant String := "Augusta ";
 251   Countess3    : constant String := "Lovelace";
 252   Cenosstu     : constant String := "  AALaaacdeeglostuuv";
 253   Insertion    : constant String := "AAAAAAAAAAAAAAAAAAAA"
 254                                   & "AAAAAAAAAAAAAAAAAAAA";
 255   Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD";
 256
 257 begin  -- Main test procedure.
 258
 259    Report.Test ("CDB0A02", "Check that several access types can share " &
 260                            "the same pool.  Check that any exception " &
 261                            "propagated by Allocate is propagated by the " &
 262                            "allocator.  Check that for an access type S, " &
 263                            "S'Max_Size_In_Storage_Elements denotes the " &
 264                            "maximum values for Size_In_Storage_Elements " &
 265                            "that will be requested via Allocate" );
 266
 267   -- Check that access types can share the same pool.
 268
 269   for Count in Countess1'Range loop
 270     CDB0A02_2.Insert( Countess1(Count), Banyan );
 271   end loop;
 272
 273   for Count in Countess1'Range loop
 274     CDB0A02_3.Insert( Countess1(Count), Torrey );
 275   end loop;
 276
 277   for Count in Countess2'Range loop
 278     CDB0A02_2.Insert( Countess2(Count), Banyan );
 279   end loop;
 280
 281   for Count in Countess2'Range loop
 282     CDB0A02_3.Insert( Countess2(Count), Torrey );
 283   end loop;
 284
 285   for Count in Countess3'Range loop
 286     CDB0A02_2.Insert( Countess3(Count), Banyan );
 287   end loop;
 288
 289   for Count in Countess3'Range loop
 290     CDB0A02_3.Insert( Countess3(Count), Torrey );
 291   end loop;
 292
 293   TCTouch.Validate(Insertion, "Allocate calls via CDB0A02_2" );
 294
 295
 296   CDB0A02_2.Traverse(Banyan);
 297   TCTouch.Validate(Cenosstu, "Traversal of Banyan" );
 298
 299   CDB0A02_3.Traverse(Torrey);
 300   TCTouch.Validate(Cenosstu, "Traversal of Torrey" );
 301
 302   CDB0A02_2.Defoliate(Banyan);
 303   TCTouch.Validate(Deallocation, "Deforestation of Banyan" );
 304   TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null");
 305
 306   CDB0A02_3.Defoliate(Torrey);
 307   TCTouch.Validate(Deallocation, "Deforestation of Torrey" );
 308   TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null");
 309
 310   -- Check that for an access type S, S'Max_Size_In_Storage_Elements
 311   -- denotes the maximum values for Size_In_Storage_Elements that will
 312   -- be requested via Allocate. (Of course, all we can do is check that
 313   -- whatever was requested of Allocate did not exceed the values of the
 314   -- attributes.)
 315
 316   TCTouch.Assert( FDB0A00.TC_Largest_Request in 1 ..
 317                   System.Storage_Elements.Storage_Count'Max (
 318                     CDB0A02_2.Small_Cell'Max_Size_In_Storage_Elements,
 319                     CDB0A02_3.Large_Cell'Max_Size_In_Storage_Elements),
 320                   "An object of excessive size was allocated.  Size: "
 321    & System.Storage_Elements.Storage_Count'Image(FDB0A00.TC_Largest_Request));
 322
 323   -- Check that an exception raised in Allocate is propagated by the allocator.
 324
 325   CDB0A02_2.TC_Exceed_Pool;
 326
 327   Report.Result;
 328
 329 end CDB0A02;