aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cd/cdb0a01.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/cd/cdb0a01.a305
1 files changed, 0 insertions, 305 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a b/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a
deleted file mode 100644
index 566fad13883..00000000000
--- a/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a
+++ /dev/null
@@ -1,305 +0,0 @@
--- CDB0A01.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 a storage pool may be user_determined, and that storage
--- is allocated by calling Allocate.
---
--- Check that a storage.pool may be specified using 'Storage_Pool
--- and that S'Storage_Pool denotes the storage pool of the type S.
---
--- TEST DESCRIPTION:
--- The package System.Storage_Pools is exercised by two very similar
--- packages which define a tree type and exercise it in a simple manner.
--- One package uses a user defined pool. The other package uses a
--- storage pool assigned by the implementation; Storage_Size is
--- specified for this pool.
--- The dispatching procedures Allocate and Deallocate are tested as an
--- intentional side effect of the tree packages.
---
--- For completeness, the actions of the tree packages are checked for
--- correct operation.
---
--- TEST FILES:
--- The following files comprise this test:
---
--- FDB0A00.A (foundation code)
--- CDB0A01.A
---
---
--- CHANGE HISTORY:
--- 02 JUN 95 SAIC Initial version
--- 07 MAY 96 SAIC Removed ambiguity with CDB0A02
--- 13 FEB 97 PWB.CTA Corrected lexically ordered string literal
---!
-
----------------------------------------------------------------- CDB0A01_1
-
----------------------------------------------------------- FDB0A00.Pool1
-
-package FDB0A00.Pool1 is
- User_Pool : Stack_Heap( 5_000 );
-end FDB0A00.Pool1;
-
----------------------------------------------------------- FDB0A00.Comparator
-
-with System.Storage_Pools;
-package FDB0A00.Comparator is
-
- function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
- return Boolean;
-
-end FDB0A00.Comparator;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-package body FDB0A00.Comparator is
-
- function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class )
- return Boolean is
- use type System.Address;
- begin
- return A'Address = B'Address;
- end "=";
-
-end FDB0A00.Comparator;
-
----------------------------------------------------------------- CDB0A01_2
-
-with FDB0A00.Pool1;
-package CDB0A01_2 is
-
- type Cell;
- type User_Pool_Tree is access Cell;
-
- for User_Pool_Tree'Storage_Pool use FDB0A00.Pool1.User_Pool;
-
- type Cell is record
- Data : Character;
- Left,Right : User_Pool_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree );
-
- procedure Traverse( The_Tree : User_Pool_Tree );
-
- procedure Defoliate( The_Tree : in out User_Pool_Tree );
-
-end CDB0A01_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Unchecked_Deallocation;
-package body CDB0A01_2 is
- procedure Deallocate is new Unchecked_Deallocation(Cell,User_Pool_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new 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 : User_Pool_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 User_Pool_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 CDB0A01_2;
-
----------------------------------------------------------------- CDB0A01_3
-
-with FDB0A00.Pool1;
-package CDB0A01_3 is
-
- type Cell;
- type System_Pool_Tree is access Cell;
-
- for System_Pool_Tree'Storage_Size use 2000;
-
- -- assumptions: Cell is <= 20 storage_units
- -- Tree building exercise requires O(15) cells
- -- 2000 > 20 * 15 by a generous margin
-
- type Cell is record
- Data: Character;
- Left,Right : System_Pool_Tree;
- end record;
-
- procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree );
-
- procedure Traverse( The_Tree : System_Pool_Tree );
-
- procedure Defoliate( The_Tree : in out System_Pool_Tree );
-
-end CDB0A01_3;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-with TCTouch;
-with Unchecked_Deallocation;
-package body CDB0A01_3 is
- procedure Deallocate is new Unchecked_Deallocation(Cell,System_Pool_Tree);
-
- -- Sort: zeros on the left, ones on the right...
- procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree ) is
- begin
- if On_Tree = null then
- On_Tree := new 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 : System_Pool_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 System_Pool_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 CDB0A01_3;
-
------------------------------------------------------------------- CDB0A01
-
-with Report;
-with TCTouch;
-with FDB0A00.Comparator;
-with FDB0A00.Pool1;
-with CDB0A01_2;
-with CDB0A01_3;
-
-procedure CDB0A01 is
-
- Banyan : CDB0A01_2.User_Pool_Tree;
- Torrey : CDB0A01_3.System_Pool_Tree;
-
- use type CDB0A01_2.User_Pool_Tree;
- use type CDB0A01_3.System_Pool_Tree;
-
- Countess : constant String := "Ada Augusta Lovelace";
- Cenosstu : constant String := " AALaaacdeeglostuuv";
- Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA";
- Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD";
-
-begin -- Main test procedure.
-
- Report.Test ("CDB0A01", "Check that a storage pool may be " &
- "user_determined, and that storage is " &
- "allocated by calling Allocate. Check that " &
- "a storage.pool may be specified using " &
- "'Storage_Pool and that S'Storage_Pool denotes " &
- "the storage pool of the type S" );
-
--- Check that S'Storage_Pool denotes the storage pool for the type S.
-
- TCTouch.Assert(
- FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
- CDB0A01_2.User_Pool_Tree'Storage_Pool ),
- "'Storage_Pool not correct for CDB0A01_2.User_Pool_Tree");
-
- TCTouch.Assert_Not(
- FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool,
- CDB0A01_3.System_Pool_Tree'Storage_Pool ),
- "'Storage_Pool not correct for CDB0A01_3.System_Pool_Tree");
-
--- Check that storage is allocated by calling Allocate.
-
- for Count in Countess'Range loop
- CDB0A01_2.Insert( Countess(Count), Banyan );
- end loop;
- TCTouch.Validate(Insertion, "Allocate calls via CDB0A01_2" );
-
- for Count in Countess'Range loop
- CDB0A01_3.Insert( Countess(Count), Torrey );
- end loop;
- TCTouch.Validate("", "Allocate calls via CDB0A01_3" );
-
- CDB0A01_2.Traverse(Banyan);
- TCTouch.Validate(Cenosstu, "Traversal of Banyan" );
-
- CDB0A01_3.Traverse(Torrey);
- TCTouch.Validate(Cenosstu, "Traversal of Torrey" );
-
- CDB0A01_2.Defoliate(Banyan);
- TCTouch.Validate(Deallocation, "Deforestation of Banyan" );
- TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null");
-
- CDB0A01_3.Defoliate(Torrey);
- TCTouch.Validate("", "Deforestation of Torrey" );
- TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null");
-
- Report.Result;
-
-end CDB0A01;
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-27 11:26:47 +0000