diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cd/cdb0a02.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cd/cdb0a02.a | 329 |
1 files changed, 0 insertions, 329 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a b/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a deleted file mode 100644 index 6a7fca54a2c..00000000000 --- a/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a +++ /dev/null @@ -1,329 +0,0 @@ --- CDB0A02.A --- --- Grant of Unlimited Rights --- --- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, --- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained --- unlimited rights in the software and documentation contained herein. --- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making --- this public release, the Government intends to confer upon all --- recipients unlimited rights equal to those held by the Government. --- These rights include rights to use, duplicate, release or disclose the --- released technical data and computer software in whole or in part, in --- any manner and for any purpose whatsoever, and to have or permit others --- to do so. --- --- DISCLAIMER --- --- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR --- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED --- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE --- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE --- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A --- PARTICULAR PURPOSE OF SAID MATERIAL. ---* --- --- OBJECTIVE: --- Check that several access types can share the same pool. --- --- Check that any exception propagated by Allocate is --- propagated by the allocator. --- --- Check that for an access type S, S'Max_Size_In_Storage_Elements --- denotes the maximum values for Size_In_Storage_Elements that will --- be requested via Allocate. --- --- TEST DESCRIPTION: --- After checking correct operation of the tree packages, the limits of --- the storage pools (first the shared user defined storage pool, then --- the system storage pool) are intentionally exceeded. The test checks --- that the correct exception is raised. --- --- --- TEST FILES: --- The following files comprise this test: --- --- FDB0A00.A (foundation code) --- CDB0A02.A --- --- --- CHANGE HISTORY: --- 10 AUG 95 SAIC Initial version --- 07 MAY 96 SAIC Disambiguated for 2.1 --- 13 FEB 97 PWB.CTA Reduced minimum allowable --- Max_Size_In_Storage_Units, for implementations --- with larger storage units --- 25 JAN 01 RLB Removed dubious checks on Max_Size_In_Storage_Units; --- tightened important one. - ---! - ----------------------------------------------------------- FDB0A00.Pool2 - -package FDB0A00.Pool2 is - Pond : Stack_Heap( 5_000 ); -end FDB0A00.Pool2; - ----------------------------------------------------------------- CDB0A02_2 - -with FDB0A00.Pool2; -package CDB0A02_2 is - - type Small_Cell; - type Small_Tree is access Small_Cell; - - for Small_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- first usage - - type Small_Cell is record - Data: Character; - Left,Right : Small_Tree; - end record; - - procedure Insert( Item: Character; On_Tree : in out Small_Tree ); - - procedure Traverse( The_Tree : Small_Tree ); - - procedure Defoliate( The_Tree : in out Small_Tree ); - - procedure TC_Exceed_Pool; - - Pool_Max_Elements : constant := 6000; - -- to guarantee overflow in TC_Exceed_Pool - -end CDB0A02_2; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -with Report; -with Unchecked_Deallocation; -package body CDB0A02_2 is - procedure Deallocate is new Unchecked_Deallocation(Small_Cell,Small_Tree); - - -- Sort: zeros on the left, ones on the right... - procedure Insert( Item: Character; On_Tree : in out Small_Tree ) is - begin - if On_Tree = null then - On_Tree := new Small_Cell'(Item,null,null); - elsif Item > On_Tree.Data then - Insert(Item,On_Tree.Right); - else - Insert(Item,On_Tree.Left); - end if; - end Insert; - - procedure Traverse( The_Tree : Small_Tree ) is - begin - if The_Tree = null then - null; -- how very symmetrical - else - Traverse(The_Tree.Left); - TCTouch.Touch(The_Tree.Data); - Traverse(The_Tree.Right); - end if; - end Traverse; - - procedure Defoliate( The_Tree : in out Small_Tree ) is - begin - - if The_Tree.Left /= null then - Defoliate(The_Tree.Left); - end if; - - if The_Tree.Right /= null then - Defoliate(The_Tree.Right); - end if; - - Deallocate(The_Tree); - - end Defoliate; - - procedure TC_Exceed_Pool is - Wild_Branch : Small_Tree; - begin - for Ever in 1..Pool_Max_Elements loop - Wild_Branch := new Small_Cell'('a', Wild_Branch, Wild_Branch); - TCTouch.Validate("A","Allocating element for overflow"); - end loop; - Report.Failed(" Pool_Overflow not raised on exceeding user pool size"); - exception - when FDB0A00.Pool_Overflow => null; -- anticipated case - when others => - Report.Failed("wrong exception raised in user Exceed_Pool"); - end TC_Exceed_Pool; - -end CDB0A02_2; - ----------------------------------------------------------------- CDB0A02_3 - --- This package is essentially identical to CDB0A02_2, except that the size --- of a cell is significantly larger. This is used to check that different --- access types may share a single pool - -with FDB0A00.Pool2; -package CDB0A02_3 is - - type Large_Cell; - type Large_Tree is access Large_Cell; - - for Large_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- second usage - - type Large_Cell is record - Data: Character; - Extra_Data : String(1..2); - Left,Right : Large_Tree; - end record; - - procedure Insert( Item: Character; On_Tree : in out Large_Tree ); - - procedure Traverse( The_Tree : Large_Tree ); - - procedure Defoliate( The_Tree : in out Large_Tree ); - -end CDB0A02_3; - --- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- - -with TCTouch; -with Unchecked_Deallocation; -package body CDB0A02_3 is - procedure Deallocate is new Unchecked_Deallocation(Large_Cell,Large_Tree); - - -- Sort: zeros on the left, ones on the right... - procedure Insert( Item: Character; On_Tree : in out Large_Tree ) is - begin - if On_Tree = null then - On_Tree := new Large_Cell'(Item,(Item,Item),null,null); - elsif Item > On_Tree.Data then - Insert(Item,On_Tree.Right); - else - Insert(Item,On_Tree.Left); - end if; - end Insert; - - procedure Traverse( The_Tree : Large_Tree ) is - begin - if The_Tree = null then - null; -- how very symmetrical - else - Traverse(The_Tree.Left); - TCTouch.Touch(The_Tree.Data); - Traverse(The_Tree.Right); - end if; - end Traverse; - - procedure Defoliate( The_Tree : in out Large_Tree ) is - begin - - if The_Tree.Left /= null then - Defoliate(The_Tree.Left); - end if; - - if The_Tree.Right /= null then - Defoliate(The_Tree.Right); - end if; - - Deallocate(The_Tree); - - end Defoliate; - -end CDB0A02_3; - ------------------------------------------------------------------- CDB0A02 - -with Report; -with TCTouch; -with System.Storage_Elements; -with CDB0A02_2; -with CDB0A02_3; -with FDB0A00; - -procedure CDB0A02 is - - Banyan : CDB0A02_2.Small_Tree; - Torrey : CDB0A02_3.Large_Tree; - - use type CDB0A02_2.Small_Tree; - use type CDB0A02_3.Large_Tree; - - Countess1 : constant String := "Ada "; - Countess2 : constant String := "Augusta "; - Countess3 : constant String := "Lovelace"; - Cenosstu : constant String := " AALaaacdeeglostuuv"; - Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA" - & "AAAAAAAAAAAAAAAAAAAA"; - Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD"; - -begin -- Main test procedure. - - Report.Test ("CDB0A02", "Check that several access types can share " & - "the same pool. Check that any exception " & - "propagated by Allocate is propagated by the " & - "allocator. Check that for an access type S, " & - "S'Max_Size_In_Storage_Elements denotes the " & - "maximum values for Size_In_Storage_Elements " & - "that will be requested via Allocate" ); - - -- Check that access types can share the same pool. - - for Count in Countess1'Range loop - CDB0A02_2.Insert( Countess1(Count), Banyan ); - end loop; - - for Count in Countess1'Range loop - CDB0A02_3.Insert( Countess1(Count), Torrey ); - end loop; - - for Count in Countess2'Range loop - CDB0A02_2.Insert( Countess2(Count), Banyan ); - end loop; - - for Count in Countess2'Range loop - CDB0A02_3.Insert( Countess2(Count), Torrey ); - end loop; - - for Count in Countess3'Range loop - CDB0A02_2.Insert( Countess3(Count), Banyan ); - end loop; - - for Count in Countess3'Range loop - CDB0A02_3.Insert( Countess3(Count), Torrey ); - end loop; - - TCTouch.Validate(Insertion, "Allocate calls via CDB0A02_2" ); - - - CDB0A02_2.Traverse(Banyan); - TCTouch.Validate(Cenosstu, "Traversal of Banyan" ); - - CDB0A02_3.Traverse(Torrey); - TCTouch.Validate(Cenosstu, "Traversal of Torrey" ); - - CDB0A02_2.Defoliate(Banyan); - TCTouch.Validate(Deallocation, "Deforestation of Banyan" ); - TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null"); - - CDB0A02_3.Defoliate(Torrey); - TCTouch.Validate(Deallocation, "Deforestation of Torrey" ); - TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null"); - - -- Check that for an access type S, S'Max_Size_In_Storage_Elements - -- denotes the maximum values for Size_In_Storage_Elements that will - -- be requested via Allocate. (Of course, all we can do is check that - -- whatever was requested of Allocate did not exceed the values of the - -- attributes.) - - TCTouch.Assert( FDB0A00.TC_Largest_Request in 1 .. - System.Storage_Elements.Storage_Count'Max ( - CDB0A02_2.Small_Cell'Max_Size_In_Storage_Elements, - CDB0A02_3.Large_Cell'Max_Size_In_Storage_Elements), - "An object of excessive size was allocated. Size: " - & System.Storage_Elements.Storage_Count'Image(FDB0A00.TC_Largest_Request)); - - -- Check that an exception raised in Allocate is propagated by the allocator. - - CDB0A02_2.TC_Exceed_Pool; - - Report.Result; - -end CDB0A02; |