Subversion Repositories openrisc

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