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