1-- C3A0015.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- The Ada Conformity Assessment Authority (ACAA) holds unlimited 6-- rights in the software and documentation contained herein. Unlimited 7-- rights are the same as those granted by the U.S. Government for older 8-- parts of the Ada Conformity Assessment Test Suite, and are defined 9-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA 10-- intends to confer upon all recipients unlimited rights equal to those 11-- held by the ACAA. These rights include rights to use, duplicate, 12-- release or disclose the released technical data and computer software 13-- in whole or in part, in any manner and for any purpose whatsoever, and 14-- to have or permit others to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- 26-- OBJECTIVE: 27-- Check that a derived access type has the same storage pool as its 28-- parent. (Defect Report 8652/0012, Technical Corrigendum 3.10(7/1)). 29-- 30-- CHANGE HISTORY: 31-- 24 JAN 2001 PHL Initial version. 32-- 29 JUN 2001 RLB Reformatted for ACATS. 33-- 34--! 35with System.Storage_Elements; 36use System.Storage_Elements; 37with System.Storage_Pools; 38use System.Storage_Pools; 39package C3A0015_0 is 40 41 type Pool (Storage_Size : Storage_Count) is new Root_Storage_Pool with 42 record 43 First_Free : Storage_Count := 1; 44 Contents : Storage_Array (1 .. Storage_Size); 45 end record; 46 47 procedure Allocate (Pool : in out C3A0015_0.Pool; 48 Storage_Address : out System.Address; 49 Size_In_Storage_Elements : in Storage_Count; 50 Alignment : in Storage_Count); 51 52 procedure Deallocate (Pool : in out C3A0015_0.Pool; 53 Storage_Address : in System.Address; 54 Size_In_Storage_Elements : in Storage_Count; 55 Alignment : in Storage_Count); 56 57 function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count; 58 59end C3A0015_0; 60 61package body C3A0015_0 is 62 63 use System; 64 65 procedure Allocate (Pool : in out C3A0015_0.Pool; 66 Storage_Address : out System.Address; 67 Size_In_Storage_Elements : in Storage_Count; 68 Alignment : in Storage_Count) is 69 Unaligned_Address : constant System.Address := 70 Pool.Contents (Pool.First_Free)'Address; 71 Unalignment : Storage_Count; 72 begin 73 Unalignment := Unaligned_Address mod Alignment; 74 if Unalignment = 0 then 75 Storage_Address := Unaligned_Address; 76 Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements; 77 else 78 Storage_Address := 79 Pool.Contents (Pool.First_Free + Alignment - Unalignment)' 80 Address; 81 Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements + 82 Alignment - Unalignment; 83 end if; 84 end Allocate; 85 86 procedure Deallocate (Pool : in out C3A0015_0.Pool; 87 Storage_Address : in System.Address; 88 Size_In_Storage_Elements : in Storage_Count; 89 Alignment : in Storage_Count) is 90 begin 91 if Storage_Address + Size_In_Storage_Elements = 92 Pool.Contents (Pool.First_Free)'Address then 93 -- Only deallocate if the block is at the end. 94 Pool.First_Free := Pool.First_Free - Size_In_Storage_Elements; 95 end if; 96 end Deallocate; 97 98 function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count is 99 begin 100 return Pool.Storage_Size; 101 end Storage_Size; 102 103end C3A0015_0; 104 105with Ada.Exceptions; 106use Ada.Exceptions; 107with Ada.Unchecked_Deallocation; 108with Report; 109use Report; 110with System.Storage_Elements; 111use System.Storage_Elements; 112with C3A0015_0; 113procedure C3A0015 is 114 115 type Standard_Pool is access Float; 116 type Derived_Standard_Pool is new Standard_Pool; 117 type Derived_Derived_Standard_Pool is new Derived_Standard_Pool; 118 119 type User_Defined_Pool is access Integer; 120 type Derived_User_Defined_Pool is new User_Defined_Pool; 121 type Derived_Derived_User_Defined_Pool is new Derived_User_Defined_Pool; 122 123 My_Pool : C3A0015_0.Pool (1024); 124 for User_Defined_Pool'Storage_Pool use My_Pool; 125 126 generic 127 type Designated is private; 128 Value : Designated; 129 type Acc is access Designated; 130 type Derived_Acc is new Acc; 131 procedure Check (Subtest : String; User_Defined_Pool : Boolean); 132 133 procedure Check (Subtest : String; User_Defined_Pool : Boolean) is 134 135 procedure Deallocate is 136 new Ada.Unchecked_Deallocation (Object => Designated, 137 Name => Acc); 138 procedure Deallocate is 139 new Ada.Unchecked_Deallocation (Object => Designated, 140 Name => Derived_Acc); 141 142 First_Free : Storage_Count; 143 X : Acc; 144 Y : Derived_Acc; 145 begin 146 if User_Defined_Pool then 147 First_Free := My_Pool.First_Free; 148 end if; 149 X := new Designated'(Value); 150 if User_Defined_Pool and then First_Free >= My_Pool.First_Free then 151 Failed (Subtest & 152 " - Allocation didn't consume storage in the pool - 1"); 153 else 154 First_Free := My_Pool.First_Free; 155 end if; 156 157 Y := Derived_Acc (X); 158 if User_Defined_Pool and then First_Free /= My_Pool.First_Free then 159 Failed (Subtest & 160 " - Conversion did consume storage in the pool - 1"); 161 end if; 162 if Y.all /= Value then 163 Failed (Subtest & 164 " - Incorrect allocation/conversion of access values - 1"); 165 end if; 166 167 Deallocate (Y); 168 if User_Defined_Pool and then First_Free <= My_Pool.First_Free then 169 Failed (Subtest & 170 " - Deallocation didn't release storage from the pool - 1"); 171 else 172 First_Free := My_Pool.First_Free; 173 end if; 174 175 Y := new Designated'(Value); 176 if User_Defined_Pool and then First_Free >= My_Pool.First_Free then 177 Failed (Subtest & 178 " - Allocation didn't consume storage in the pool - 2"); 179 else 180 First_Free := My_Pool.First_Free; 181 end if; 182 183 X := Acc (Y); 184 if User_Defined_Pool and then First_Free /= My_Pool.First_Free then 185 Failed (Subtest & 186 " - Conversion did consume storage in the pool - 2"); 187 end if; 188 if X.all /= Value then 189 Failed (Subtest & 190 " - Incorrect allocation/conversion of access values - 2"); 191 end if; 192 193 Deallocate (X); 194 if User_Defined_Pool and then First_Free <= My_Pool.First_Free then 195 Failed (Subtest & 196 " - Deallocation didn't release storage from the pool - 2"); 197 end if; 198 exception 199 when E: others => 200 Failed (Subtest & " - Exception " & Exception_Name (E) & 201 " raised - " & Exception_Message (E)); 202 end Check; 203 204 205begin 206 Test ("C3A0015", "Check that a dervied access type has the same " & 207 "storage pool as its parent"); 208 209 Comment ("Access types using the standard storage pool"); 210 211 Std: 212 declare 213 procedure Check1 is 214 new Check (Designated => Float, 215 Value => 3.0, 216 Acc => Standard_Pool, 217 Derived_Acc => Derived_Standard_Pool); 218 procedure Check2 is 219 new Check (Designated => Float, 220 Value => 4.0, 221 Acc => Standard_Pool, 222 Derived_Acc => Derived_Derived_Standard_Pool); 223 procedure Check3 is 224 new Check (Designated => Float, 225 Value => 5.0, 226 Acc => Derived_Standard_Pool, 227 Derived_Acc => Derived_Derived_Standard_Pool); 228 begin 229 Check1 ("Standard_Pool/Derived_Standard_Pool", 230 User_Defined_Pool => False); 231 Check2 ("Standard_Pool/Derived_Derived_Standard_Pool", 232 User_Defined_Pool => False); 233 Check3 ("Derived_Standard_Pool/Derived_Derived_Standard_Pool", 234 User_Defined_Pool => False); 235 end Std; 236 237 Comment ("Access types using a user-defined storage pool"); 238 239 User: 240 declare 241 procedure Check1 is 242 new Check (Designated => Integer, 243 Value => 17, 244 Acc => User_Defined_Pool, 245 Derived_Acc => Derived_User_Defined_Pool); 246 procedure Check2 is 247 new Check (Designated => Integer, 248 Value => 18, 249 Acc => User_Defined_Pool, 250 Derived_Acc => Derived_Derived_User_Defined_Pool); 251 procedure Check3 is 252 new Check (Designated => Integer, 253 Value => 19, 254 Acc => Derived_User_Defined_Pool, 255 Derived_Acc => Derived_Derived_User_Defined_Pool); 256 begin 257 Check1 ("User_Defined_Pool/Derived_User_Defined_Pool", 258 User_Defined_Pool => True); 259 Check2 ("User_Defined_Pool/Derived_Derived_User_Defined_Pool", 260 User_Defined_Pool => True); 261 Check3 262 ("Derived_User_Defined_Pool/Derived_Derived_User_Defined_Pool", 263 User_Defined_Pool => True); 264 end User; 265 266 Result; 267end C3A0015; 268