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
63package FDB0A00.Pool2 is
64  Pond : Stack_Heap( 5_000 );
65end FDB0A00.Pool2;
66
67---------------------------------------------------------------- CDB0A02_2
68
69with FDB0A00.Pool2;
70package 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
93end CDB0A02_2;
94
95-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
96
97with TCTouch;
98with Report;
99with Unchecked_Deallocation;
100package 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
155end 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
163with FDB0A00.Pool2;
164package 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
183end CDB0A02_3;
184
185-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
186
187with TCTouch;
188with Unchecked_Deallocation;
189package 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
230end CDB0A02_3;
231
232------------------------------------------------------------------ CDB0A02
233
234with Report;
235with TCTouch;
236with System.Storage_Elements;
237with CDB0A02_2;
238with CDB0A02_3;
239with FDB0A00;
240
241procedure 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
257begin  -- 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
329end CDB0A02;
330