--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,329 @@
+-- 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;