diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c3a0015.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c3a0015.a | 267 |
1 files changed, 0 insertions, 267 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0015.a b/gcc/testsuite/ada/acats/tests/c3/c3a0015.a deleted file mode 100644 index 856c910f92d..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a0015.a +++ /dev/null @@ -1,267 +0,0 @@ --- 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; |