1-- C3A2A02.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- 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, for X'Access of a general access type A, Program_Error is 28-- raised if the accessibility level of X is deeper than that of A. 29-- Check for cases where X'Access occurs in an instance body, and A 30-- is a type either declared inside the instance, or declared outside 31-- the instance but not passed as an actual during instantiation. 32-- 33-- TEST DESCRIPTION: 34-- In order to satisfy accessibility requirements, the designated 35-- object X must be at the same or a less deep nesting level than the 36-- general access type A -- X must "live" as long as A. Nesting 37-- levels are the run-time nestings of masters: block statements; 38-- subprogram, task, and entry bodies; and accept statements. Packages 39-- are invisible to accessibility rules. 40-- 41-- This test declares three generic packages: 42-- 43-- (1) One in which X is of a formal tagged derived type and declared 44-- in the body, A is a type declared outside the instance, and 45-- X'Access occurs in the declarative part of a nested subprogram. 46-- 47-- (2) One in which X is a formal object of a tagged type, A is a 48-- type declared outside the instance, and X'Access occurs in the 49-- declarative part of the body. 50-- 51-- (3) One in which there are two X's and two A's. In the first pair, 52-- X is a formal in object of a tagged type, A is declared in the 53-- specification, and X'Access occurs in the declarative part of 54-- the body. In the second pair, X is of a formal derived type, 55-- X and A are declared in the specification, and X'Access occurs 56-- in the sequence of statements of the body. 57-- 58-- The test verifies the following: 59-- 60-- For (1), Program_Error is raised when the nested subprogram is 61-- called, if the generic package is instantiated at a deeper level 62-- than that of A. The exception is propagated to the innermost 63-- enclosing master. Also, check that Program_Error is not raised 64-- if the instantiation is at the same level as that of A. 65-- 66-- For (2), Program_Error is raised upon instantiation if the object 67-- passed as an actual during instantiation has an accessibility level 68-- deeper than that of A. The exception is propagated to the innermost 69-- enclosing master. Also, check that Program_Error is not raised if 70-- the level of the actual object is not deeper than that of A. 71-- 72-- For (3), Program_Error is not raised, for actual objects at 73-- various accessibility levels (since A will have at least the same 74-- accessibility level as X in all cases, no exception should ever 75-- be raised). 76-- 77-- TEST FILES: 78-- The following files comprise this test: 79-- 80-- F3A2A00.A 81-- -> C3A2A02.A 82-- 83-- 84-- CHANGE HISTORY: 85-- 12 May 95 SAIC Initial prerelease version. 86-- 10 Jul 95 SAIC Modified code to avoid dead variable optimization. 87-- 26 Jun 98 EDS Added pragma Elaborate (C3A2A02_0) to package 88-- package C3A2A02_3, in order to avoid possible 89-- instantiation error. 90--! 91 92with F3A2A00; 93generic 94 type FD is new F3A2A00.Tagged_Type with private; 95package C3A2A02_0 is 96 procedure Proc; 97end C3A2A02_0; 98 99 100 --==================================================================-- 101 102 103with Report; 104package body C3A2A02_0 is 105 X : aliased FD; 106 107 procedure Proc is 108 Ptr : F3A2A00.AccTagClass_L0 := X'Access; 109 begin 110 -- Avoid optimization (dead variable removal of Ptr): 111 112 if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. 113 Report.Failed ("Unexpected error in Proc"); 114 end if; 115 end Proc; 116end C3A2A02_0; 117 118 119 --==================================================================-- 120 121 122with F3A2A00; 123generic 124 FObj : in out F3A2A00.Tagged_Type; 125package C3A2A02_1 is 126 procedure Dummy; -- Needed to allow package body. 127end C3A2A02_1; 128 129 130 --==================================================================-- 131 132 133with Report; 134package body C3A2A02_1 is 135 Ptr : F3A2A00.AccTag_L0 := FObj'Access; 136 137 procedure Dummy is 138 begin 139 null; 140 end Dummy; 141begin 142 -- Avoid optimization (dead variable removal of Ptr): 143 144 if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. 145 Report.Failed ("Unexpected error in C3A2A02_1 instance"); 146 end if; 147end C3A2A02_1; 148 149 150 --==================================================================-- 151 152 153with F3A2A00; 154generic 155 type FD is new F3A2A00.Array_Type; 156 FObj : in F3A2A00.Tagged_Type; 157package C3A2A02_2 is 158 type GAF is access all FD; 159 type GAO is access constant F3A2A00.Tagged_Type; 160 XG : aliased FD; 161 PtrF : GAF; 162 Index : Integer := FD'First; 163 164 procedure Dummy; -- Needed to allow package body. 165end C3A2A02_2; 166 167 168 --==================================================================-- 169 170 171with Report; 172package body C3A2A02_2 is 173 PtrO : GAO := FObj'Access; 174 175 procedure Dummy is 176 begin 177 null; 178 end Dummy; 179begin 180 PtrF := XG'Access; 181 182 -- Avoid optimization (dead variable removal of PtrO and/or PtrF): 183 184 if not Report.Equal (PtrO.C, PtrO.C) then -- Always false. 185 Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrO"); 186 end if; 187 188 if not Report.Equal (PtrF(Index).C, PtrF(Index).C) then -- Always false. 189 Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrF"); 190 end if; 191end C3A2A02_2; 192 193 194 --==================================================================-- 195 196 197-- The instantiation of C3A2A02_0 should NOT result in any exceptions. 198 199with F3A2A00; 200with C3A2A02_0; 201pragma Elaborate (C3A2A02_0); 202package C3A2A02_3 is new C3A2A02_0 (F3A2A00.Tagged_Type); 203 204 205 --==================================================================-- 206 207 208with F3A2A00; 209with C3A2A02_0; 210with C3A2A02_1; 211with C3A2A02_2; 212with C3A2A02_3; 213 214with Report; 215procedure C3A2A02 is 216begin -- C3A2A02. -- [ Level = 1 ] 217 218 Report.Test ("C3A2A02", "Run-time accessibility checks: instance " & 219 "bodies. Type of X'Access is local or global to instance"); 220 221 222 SUBTEST1: 223 declare -- [ Level = 2 ] 224 Result1 : F3A2A00.TC_Result_Kind; 225 Result2 : F3A2A00.TC_Result_Kind; 226 begin -- SUBTEST1. 227 228 declare -- [ Level = 3 ] 229 package Pack_Same_Level renames C3A2A02_3; 230 begin 231 -- The accessibility level of Pack_Same_Level.X is that of the 232 -- instance (0), not that of the renaming declaration. The level of 233 -- the type of Pack_Same_Level.X'Access (F3A2A00.AccTagClass_L0) is 234 -- 0. Therefore, the X'Access in Pack_Same_Level.Proc does not raise 235 -- an exception when the subprogram is called. The level of execution 236 -- of the subprogram is irrelevant: 237 238 Pack_Same_Level.Proc; 239 Result1 := F3A2A00.OK; -- Expected result. 240 exception 241 when Program_Error => Result1 := F3A2A00.P_E; 242 when others => Result1 := F3A2A00.O_E; 243 end; 244 245 F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, 246 "SUBTEST #1 (same level)"); 247 248 249 declare -- [ Level = 3 ] 250 -- The instantiation of C3A2A02_0 should NOT result in any 251 -- exceptions. 252 253 package Pack_Deeper_Level is new C3A2A02_0 (F3A2A00.Tagged_Type); 254 begin 255 -- The accessibility level of Pack_Deeper_Level.X is that of the 256 -- instance (3). The level of the type of Pack_Deeper_Level.X'Access 257 -- (F3A2A00.AccTagClass_L0) is 0. Therefore, the X'Access in 258 -- Pack_Deeper_Level.Proc propagates Program_Error when the 259 -- subprogram is called: 260 261 Pack_Deeper_Level.Proc; 262 Result2 := F3A2A00.OK; 263 exception 264 when Program_Error => Result2 := F3A2A00.P_E; -- Expected result. 265 when others => Result2 := F3A2A00.O_E; 266 end; 267 268 F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E, 269 "SUBTEST #1: deeper level"); 270 271 exception 272 when Program_Error => 273 Report.Failed ("SUBTEST #1: Program_Error incorrectly raised " & 274 "during instantiation of generic"); 275 when others => 276 Report.Failed ("SUBTEST #1: Unexpected exception raised " & 277 "during instantiation of generic"); 278 end SUBTEST1; 279 280 281 282 SUBTEST2: 283 declare -- [ Level = 2 ] 284 Result1 : F3A2A00.TC_Result_Kind; 285 Result2 : F3A2A00.TC_Result_Kind; 286 begin -- SUBTEST2. 287 288 declare -- [ Level = 3 ] 289 X_L3 : F3A2A00.Tagged_Type; 290 begin 291 declare -- [ Level = 4 ] 292 -- The accessibility level of the actual object corresponding to 293 -- FObj in Pack_PE is 3. The level of the type of FObj'Access 294 -- (F3A2A00.AccTag_L0) is 0. Therefore, the FObj'Access in Pack_PE 295 -- propagates Program_Error when the instance body is elaborated: 296 297 package Pack_PE is new C3A2A02_1 (X_L3); 298 begin 299 Result1 := F3A2A00.OK; 300 end; 301 exception 302 when Program_Error => Result1 := F3A2A00.P_E; -- Expected result. 303 when others => Result1 := F3A2A00.O_E; 304 end; 305 306 F3A2A00.TC_Display_Results (Result1, F3A2A00.P_E, 307 "SUBTEST #2: deeper level"); 308 309 310 begin -- [ Level = 3 ] 311 declare -- [ Level = 4 ] 312 -- The accessibility level of the actual object corresponding to 313 -- FObj in Pack_OK is 0. The level of the type of FObj'Access 314 -- (F3A2A00.AccTag_L0) is also 0. Therefore, the FObj'Access in 315 -- Pack_OK does not raise an exception when the instance body is 316 -- elaborated: 317 318 package Pack_OK is new C3A2A02_1 (F3A2A00.X_L0); 319 begin 320 Result2 := F3A2A00.OK; -- Expected result. 321 end; 322 exception 323 when Program_Error => Result2 := F3A2A00.P_E; 324 when others => Result2 := F3A2A00.O_E; 325 end; 326 327 F3A2A00.TC_Display_Results (Result2, F3A2A00.OK, 328 "SUBTEST #2: same level"); 329 330 end SUBTEST2; 331 332 333 334 SUBTEST3: 335 declare -- [ Level = 2 ] 336 Result1 : F3A2A00.TC_Result_Kind; 337 Result2 : F3A2A00.TC_Result_Kind; 338 begin -- SUBTEST3. 339 340 declare -- [ Level = 3 ] 341 X_L3 : F3A2A00.Tagged_Type; 342 begin 343 declare -- [ Level = 4 ] 344 -- Since the accessibility level of the type of X'Access in 345 -- both cases within Pack_OK1 is that of the instance, and since 346 -- X is either passed as an actual (in which case its level will 347 -- not be deeper than that of the instance) or is declared within 348 -- the instance (in which case its level is the same as that of 349 -- the instance), no exception should be raised when the instance 350 -- body is elaborated: 351 352 package Pack_OK1 is new C3A2A02_2 (F3A2A00.Array_Type, X_L3); 353 begin 354 Result1 := F3A2A00.OK; -- Expected result. 355 end; 356 exception 357 when Program_Error => Result1 := F3A2A00.P_E; 358 when others => Result1 := F3A2A00.O_E; 359 end; 360 361 F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, 362 "SUBTEST #3: 1st okay case"); 363 364 365 declare -- [ Level = 3 ] 366 type My_Array is new F3A2A00.Array_Type; 367 begin 368 declare -- [ Level = 4 ] 369 -- Since the accessibility level of the type of X'Access in 370 -- both cases within Pack_OK2 is that of the instance, and since 371 -- X is either passed as an actual (in which case its level will 372 -- not be deeper than that of the instance) or is declared within 373 -- the instance (in which case its level is the same as that of 374 -- the instance), no exception should be raised when the instance 375 -- body is elaborated: 376 377 package Pack_OK2 is new C3A2A02_2 (My_Array, F3A2A00.X_L0); 378 begin 379 Result2 := F3A2A00.OK; -- Expected result. 380 end; 381 exception 382 when Program_Error => Result2 := F3A2A00.P_E; 383 when others => Result2 := F3A2A00.O_E; 384 end; 385 386 F3A2A00.TC_Display_Results (Result2, F3A2A00.OK, 387 "SUBTEST #3: 2nd okay case"); 388 389 390 end SUBTEST3; 391 392 393 394 Report.Result; 395 396end C3A2A02; 397