old-autovect-branch/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a

   1 -- CDB0A01.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 a storage pool may be user_determined, and that storage
  28 --      is allocated by calling Allocate.
  29 --
  30 --      Check that a storage.pool may be specified using 'Storage_Pool
  31 --      and that S'Storage_Pool denotes the storage pool of the type S.
  32 --
  33 -- TEST DESCRIPTION:
  34 --      The package System.Storage_Pools is exercised by two very similar
  35 --      packages which define a tree type and exercise it in a simple manner.
  36 --      One package uses a user defined pool.  The other package uses a
  37 --      storage pool assigned by the implementation; Storage_Size is
  38 --      specified for this pool.
  39 --      The dispatching procedures Allocate and Deallocate are tested as an
  40 --      intentional side effect of the tree packages.
  41 --
  42 --      For completeness, the actions of the tree packages are checked for
  43 --      correct operation.
  44 --
  45 -- TEST FILES:
  46 --      The following files comprise this test:
  47 --
  48 --         FDB0A00.A   (foundation code)
  49 --         CDB0A01.A
  50 --
  51 --
  52 -- CHANGE HISTORY:
  53 --      02 JUN 95   SAIC   Initial version
  54 --      07 MAY 96   SAIC   Removed ambiguity with CDB0A02
  55 --      13 FEB 97   PWB.CTA Corrected lexically ordered string literal
  56 --!
  57
  58 ---------------------------------------------------------------- CDB0A01_1
  59
  60 ---------------------------------------------------------- FDB0A00.Pool1
  61
  62 package FDB0A00.Pool1 is
  63   User_Pool : Stack_Heap( 5_000 );
  64 end FDB0A00.Pool1;
  65
  66 ---------------------------------------------------------- FDB0A00.Comparator
  67
  68 with System.Storage_Pools;
  69 package FDB0A00.Comparator is
  70
  71   function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
  72            return Boolean;
  73
  74 end FDB0A00.Comparator;
  75
  76 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  77
  78 with TCTouch;
  79 package body FDB0A00.Comparator is
  80
  81   function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
  82            return Boolean is
  83     use type System.Address;
  84   begin
  85     return A'Address = B'Address;
  86   end "=";
  87
  88 end FDB0A00.Comparator;
  89
  90 ---------------------------------------------------------------- CDB0A01_2
  91
  92 with FDB0A00.Pool1;
  93 package CDB0A01_2 is
  94
  95   type Cell;
  96   type User_Pool_Tree is access Cell;
  97
  98   for User_Pool_Tree'Storage_Pool use FDB0A00.Pool1.User_Pool;
  99
 100   type Cell is record
 101     Data : Character;
 102     Left,Right : User_Pool_Tree;
 103   end record;
 104
 105   procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree );
 106
 107   procedure Traverse( The_Tree : User_Pool_Tree );
 108
 109   procedure Defoliate( The_Tree : in out User_Pool_Tree );
 110
 111 end CDB0A01_2;
 112
 113 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 114
 115 with TCTouch;
 116 with Unchecked_Deallocation;
 117 package body CDB0A01_2 is
 118   procedure Deallocate is new Unchecked_Deallocation(Cell,User_Pool_Tree);
 119
 120   -- Sort: zeros on the left, ones on the right...
 121   procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree ) is
 122   begin
 123     if On_Tree = null then
 124       On_Tree := new Cell'(Item,null,null);
 125     elsif Item > On_Tree.Data then
 126       Insert(Item,On_Tree.Right);
 127     else
 128       Insert(Item,On_Tree.Left);
 129     end if;
 130   end Insert;
 131
 132   procedure Traverse( The_Tree : User_Pool_Tree ) is
 133   begin
 134     if The_Tree = null then
 135       null;  -- how very symmetrical
 136     else
 137       Traverse(The_Tree.Left);
 138       TCTouch.Touch(The_Tree.Data);
 139       Traverse(The_Tree.Right);
 140     end if;
 141   end Traverse;
 142
 143   procedure Defoliate( The_Tree : in out User_Pool_Tree ) is
 144   begin
 145
 146     if The_Tree.Left /= null then
 147       Defoliate(The_Tree.Left);
 148     end if;
 149
 150     if The_Tree.Right /= null then
 151       Defoliate(The_Tree.Right);
 152     end if;
 153
 154     Deallocate(The_Tree);
 155
 156   end Defoliate;
 157
 158 end CDB0A01_2;
 159
 160 ---------------------------------------------------------------- CDB0A01_3
 161
 162 with FDB0A00.Pool1;
 163 package CDB0A01_3 is
 164
 165   type Cell;
 166   type System_Pool_Tree is access Cell;
 167
 168   for System_Pool_Tree'Storage_Size use 2000;
 169
 170   -- assumptions: Cell is <= 20 storage_units
 171   --              Tree building exercise requires O(15) cells
 172   --              2000 > 20 * 15 by a generous margin
 173
 174   type Cell is record
 175     Data: Character;
 176     Left,Right : System_Pool_Tree;
 177   end record;
 178
 179   procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree );
 180
 181   procedure Traverse( The_Tree : System_Pool_Tree );
 182
 183   procedure Defoliate( The_Tree : in out System_Pool_Tree );
 184
 185 end CDB0A01_3;
 186
 187 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
 188
 189 with TCTouch;
 190 with Unchecked_Deallocation;
 191 package body CDB0A01_3 is
 192   procedure Deallocate is new Unchecked_Deallocation(Cell,System_Pool_Tree);
 193
 194   -- Sort: zeros on the left, ones on the right...
 195   procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree ) is
 196   begin
 197     if On_Tree = null then
 198       On_Tree := new Cell'(Item,null,null);
 199     elsif Item > On_Tree.Data then
 200       Insert(Item,On_Tree.Right);
 201     else
 202       Insert(Item,On_Tree.Left);
 203     end if;
 204   end Insert;
 205
 206   procedure Traverse( The_Tree : System_Pool_Tree ) is
 207   begin
 208     if The_Tree = null then
 209       null;  -- how very symmetrical
 210     else
 211       Traverse(The_Tree.Left);
 212       TCTouch.Touch(The_Tree.Data);
 213       Traverse(The_Tree.Right);
 214     end if;
 215   end Traverse;
 216
 217   procedure Defoliate( The_Tree : in out System_Pool_Tree ) is
 218   begin
 219
 220     if The_Tree.Left /= null then
 221       Defoliate(The_Tree.Left);
 222     end if;
 223
 224     if The_Tree.Right /= null then
 225       Defoliate(The_Tree.Right);
 226     end if;
 227
 228     Deallocate(The_Tree);
 229
 230   end Defoliate;
 231
 232 end CDB0A01_3;
 233
 234 ------------------------------------------------------------------ CDB0A01
 235
 236 with Report;
 237 with TCTouch;
 238 with FDB0A00.Comparator;
 239 with FDB0A00.Pool1;
 240 with CDB0A01_2;
 241 with CDB0A01_3;
 242
 243 procedure CDB0A01 is
 244
 245   Banyan : CDB0A01_2.User_Pool_Tree;
 246   Torrey : CDB0A01_3.System_Pool_Tree;
 247
 248   use type CDB0A01_2.User_Pool_Tree;
 249   use type CDB0A01_3.System_Pool_Tree;
 250
 251   Countess     : constant String := "Ada Augusta Lovelace";
 252   Cenosstu     : constant String := "  AALaaacdeeglostuuv";
 253   Insertion    : constant String := "AAAAAAAAAAAAAAAAAAAA";
 254   Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD";
 255
 256 begin  -- Main test procedure.
 257
 258    Report.Test ("CDB0A01", "Check that a storage pool may be " &
 259                            "user_determined, and that storage is " &
 260                            "allocated by calling Allocate.  Check that " &
 261                            "a storage.pool may be specified using " &
 262                            "'Storage_Pool and that S'Storage_Pool denotes " &
 263                            "the storage pool of the type S" );
 264
 265 --      Check that S'Storage_Pool denotes the storage pool for the type S.
 266
 267   TCTouch.Assert(
 268      FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
 269                             CDB0A01_2.User_Pool_Tree'Storage_Pool ),
 270      "'Storage_Pool not correct for CDB0A01_2.User_Pool_Tree");
 271
 272   TCTouch.Assert_Not(
 273      FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
 274                             CDB0A01_3.System_Pool_Tree'Storage_Pool ),
 275      "'Storage_Pool not correct for CDB0A01_3.System_Pool_Tree");
 276
 277 --      Check that storage is allocated by calling Allocate.
 278
 279   for Count in Countess'Range loop
 280     CDB0A01_2.Insert( Countess(Count), Banyan );
 281   end loop;
 282   TCTouch.Validate(Insertion, "Allocate calls via CDB0A01_2" );
 283
 284   for Count in Countess'Range loop
 285     CDB0A01_3.Insert( Countess(Count), Torrey );
 286   end loop;
 287   TCTouch.Validate("", "Allocate calls via CDB0A01_3" );
 288
 289   CDB0A01_2.Traverse(Banyan);
 290   TCTouch.Validate(Cenosstu, "Traversal of Banyan" );
 291
 292   CDB0A01_3.Traverse(Torrey);
 293   TCTouch.Validate(Cenosstu, "Traversal of Torrey" );
 294
 295   CDB0A01_2.Defoliate(Banyan);
 296   TCTouch.Validate(Deallocation, "Deforestation of Banyan" );
 297   TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null");
 298
 299   CDB0A01_3.Defoliate(Torrey);
 300   TCTouch.Validate("", "Deforestation of Torrey" );
 301   TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null");
 302
 303   Report.Result;
 304
 305 end CDB0A01;