path: root/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a

-- 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;