Subversion Repositories openrisc_me

-- C3A0015.A

--

--                             Grant of Unlimited Rights

--

--     The Ada Conformity Assessment Authority (ACAA) holds unlimited

--     rights in the software and documentation contained herein. Unlimited

--     rights are the same as those granted by the U.S. Government for older

--     parts of the Ada Conformity Assessment Test Suite, and are defined

--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA

--     intends to confer upon all recipients unlimited rights equal to those

--     held by the ACAA. 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 derived access type has the same storage pool as its

--    parent.  (Defect Report 8652/0012, Technical Corrigendum 3.10(7/1)).

--

-- CHANGE HISTORY:

--    24 JAN 2001   PHL   Initial version.

--    29 JUN 2001   RLB   Reformatted for ACATS.

--

--!

with System.Storage_Elements;

use System.Storage_Elements;

with System.Storage_Pools;

use System.Storage_Pools;

package C3A0015_0 is

    type Pool (Storage_Size : Storage_Count) is new Root_Storage_Pool with

        record

            First_Free : Storage_Count := 1;

            Contents : Storage_Array (1 .. Storage_Size);

        end record;

    procedure Allocate (Pool : in out C3A0015_0.Pool;

                        Storage_Address : out System.Address;

                        Size_In_Storage_Elements : in Storage_Count;

                        Alignment : in Storage_Count);

    procedure Deallocate (Pool : in out C3A0015_0.Pool;

                          Storage_Address : in System.Address;

                          Size_In_Storage_Elements : in Storage_Count;

                          Alignment : in Storage_Count);

    function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count;

end C3A0015_0;

package body C3A0015_0 is

    use System;

    procedure Allocate (Pool : in out C3A0015_0.Pool;

                        Storage_Address : out System.Address;

                        Size_In_Storage_Elements : in Storage_Count;

                        Alignment : in Storage_Count) is

        Unaligned_Address : constant System.Address :=

           Pool.Contents (Pool.First_Free)'Address;

        Unalignment : Storage_Count;

    begin

        Unalignment := Unaligned_Address mod Alignment;

        if Unalignment = 0 then

            Storage_Address := Unaligned_Address;

            Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements;

        else

            Storage_Address :=

               Pool.Contents (Pool.First_Free + Alignment - Unalignment)'

                  Address;

            Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements +

                                  Alignment - Unalignment;

        end if;

    end Allocate;

    procedure Deallocate (Pool : in out C3A0015_0.Pool;

                          Storage_Address : in System.Address;

                          Size_In_Storage_Elements : in Storage_Count;

                          Alignment : in Storage_Count) is

    begin

        if Storage_Address + Size_In_Storage_Elements =

           Pool.Contents (Pool.First_Free)'Address then

            -- Only deallocate if the block is at the end.

            Pool.First_Free := Pool.First_Free - Size_In_Storage_Elements;

        end if;

    end Deallocate;

    function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count is

    begin

        return Pool.Storage_Size;

    end Storage_Size;

end C3A0015_0;

with Ada.Exceptions;

use Ada.Exceptions;

with Ada.Unchecked_Deallocation;

with Report;

use Report;

with System.Storage_Elements;

use System.Storage_Elements;

with C3A0015_0;

procedure C3A0015 is

    type Standard_Pool is access Float;

    type Derived_Standard_Pool is new Standard_Pool;

    type Derived_Derived_Standard_Pool is new Derived_Standard_Pool;

    type User_Defined_Pool is access Integer;

    type Derived_User_Defined_Pool is new User_Defined_Pool;

    type Derived_Derived_User_Defined_Pool is new Derived_User_Defined_Pool;

    My_Pool : C3A0015_0.Pool (1024);

    for User_Defined_Pool'Storage_Pool use My_Pool;

    generic

        type Designated is private;

        Value : Designated;

        type Acc is access Designated;

        type Derived_Acc is new Acc;

    procedure Check (Subtest : String; User_Defined_Pool : Boolean);

    procedure Check (Subtest : String; User_Defined_Pool : Boolean) is

        procedure Deallocate is

           new Ada.Unchecked_Deallocation (Object => Designated,

                                           Name => Acc);

        procedure Deallocate is

           new Ada.Unchecked_Deallocation (Object => Designated,

                                           Name => Derived_Acc);

        First_Free : Storage_Count;

        X : Acc;

        Y : Derived_Acc;

    begin

        if User_Defined_Pool then

            First_Free := My_Pool.First_Free;

        end if;

        X := new Designated'(Value);

        if User_Defined_Pool and then First_Free >= My_Pool.First_Free then

            Failed (Subtest &

                    " - Allocation didn't consume storage in the pool - 1");

        else

            First_Free := My_Pool.First_Free;

        end if;

        Y := Derived_Acc (X);

        if User_Defined_Pool and then First_Free /= My_Pool.First_Free then

            Failed (Subtest &

                    " - Conversion did consume storage in the pool - 1");

        end if;

        if Y.all /= Value then

            Failed (Subtest &

                    " - Incorrect allocation/conversion of access values - 1");

        end if;

        Deallocate (Y);

        if User_Defined_Pool and then First_Free <= My_Pool.First_Free then

            Failed (Subtest &

                    " - Deallocation didn't release storage from the pool - 1");

        else

            First_Free := My_Pool.First_Free;

        end if;

        Y := new Designated'(Value);

        if User_Defined_Pool and then First_Free >= My_Pool.First_Free then

            Failed (Subtest &

                    " - Allocation didn't consume storage in the pool - 2");

        else

            First_Free := My_Pool.First_Free;

        end if;

        X := Acc (Y);

        if User_Defined_Pool and then First_Free /= My_Pool.First_Free then

            Failed (Subtest &

                    " - Conversion did consume storage in the pool - 2");

        end if;

        if X.all /= Value then

            Failed (Subtest &

                    " - Incorrect allocation/conversion of access values - 2");

        end if;

        Deallocate (X);

        if User_Defined_Pool and then First_Free <= My_Pool.First_Free then

            Failed (Subtest &

                    " - Deallocation didn't release storage from the pool - 2");

        end if;

    exception

        when E: others =>

            Failed (Subtest & " - Exception " & Exception_Name (E) &

                    " raised - " & Exception_Message (E));

    end Check;

begin

    Test ("C3A0015", "Check that a dervied access type has the same " &

                        "storage pool as its parent");

    Comment ("Access types using the standard storage pool");

    Std:

        declare

            procedure Check1 is

               new Check (Designated => Float,

                          Value => 3.0,

                          Acc => Standard_Pool,

                          Derived_Acc => Derived_Standard_Pool);

            procedure Check2 is

               new Check (Designated => Float,

                          Value => 4.0,

                          Acc => Standard_Pool,

                          Derived_Acc => Derived_Derived_Standard_Pool);

            procedure Check3 is

               new Check (Designated => Float,

                          Value => 5.0,

                          Acc => Derived_Standard_Pool,

                          Derived_Acc => Derived_Derived_Standard_Pool);

        begin

            Check1 ("Standard_Pool/Derived_Standard_Pool",

                    User_Defined_Pool => False);

            Check2 ("Standard_Pool/Derived_Derived_Standard_Pool",

                    User_Defined_Pool => False);

            Check3 ("Derived_Standard_Pool/Derived_Derived_Standard_Pool",

                    User_Defined_Pool => False);

        end Std;

    Comment ("Access types using a user-defined storage pool");

    User:

        declare

            procedure Check1 is

               new Check (Designated => Integer,

                          Value => 17,

                          Acc => User_Defined_Pool,

                          Derived_Acc => Derived_User_Defined_Pool);

            procedure Check2 is

               new Check (Designated => Integer,

                          Value => 18,

                          Acc => User_Defined_Pool,

                          Derived_Acc => Derived_Derived_User_Defined_Pool);

            procedure Check3 is

               new Check (Designated => Integer,

                          Value => 19,

                          Acc => Derived_User_Defined_Pool,

                          Derived_Acc => Derived_Derived_User_Defined_Pool);

        begin

            Check1 ("User_Defined_Pool/Derived_User_Defined_Pool",

                    User_Defined_Pool => True);

            Check2 ("User_Defined_Pool/Derived_Derived_User_Defined_Pool",

                    User_Defined_Pool => True);

            Check3

               ("Derived_User_Defined_Pool/Derived_Derived_User_Defined_Pool",

                User_Defined_Pool => True);

        end User;

    Result;

end C3A0015;