llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/c3/c3a0015.a

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