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