1-- C460A01.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 if the target type of a type conversion is a general 28-- access type, Program_Error is raised if the accessibility level of 29-- the operand type is deeper than that of the target type. Check for 30-- cases where the type conversion occurs in an instance body, and 31-- the operand type is passed as an actual during instantiation. 32-- 33-- TEST DESCRIPTION: 34-- In order to satisfy accessibility requirements, the operand type must 35-- be at the same or a less deep nesting level than the target type -- the 36-- operand type must "live" as long as the target type. Nesting levels 37-- are the run-time nestings of masters: block statements; subprogram, 38-- task, and entry bodies; and accept statements. Packages are invisible 39-- to accessibility rules. 40-- 41-- This test checks for cases where the operand is a subprogram formal 42-- parameter. 43-- 44-- The test declares three generic packages, each containing an access 45-- type conversion in which the operand type is a formal type: 46-- 47-- (1) One in which the target type is declared within the 48-- specification, and the conversion occurs within a nested 49-- function. 50-- 51-- (2) One in which the target type is also a formal type, and 52-- the conversion occurs within a nested function. 53-- 54-- (3) One in which the target type is declared outside the 55-- generic, and the conversion occurs within a nested 56-- procedure. 57-- 58-- The test verifies the following: 59-- 60-- For (1), Program_Error is not raised when the nested function is 61-- called. Since the actual corresponding to the formal operand type 62-- must always have the same or a less deep level than the target 63-- type declared within the instance, the access type conversion is 64-- always safe. 65-- 66-- For (2), Program_Error is raised when the nested function is 67-- called if the operand type passed as an actual during instantiation 68-- has an accessibility level deeper than that of the target type 69-- passed as an actual, and that no exception is raised otherwise. 70-- The exception is propagated to the innermost enclosing master. 71-- 72-- For (3), Program_Error is raised when the nested procedure is 73-- called if the operand type passed as an actual during instantiation 74-- has an accessibility level deeper than that of the target type. 75-- The exception is handled within the nested procedure. 76-- 77-- TEST FILES: 78-- The following files comprise this test: 79-- 80-- F460A00.A 81-- => C460A01.A 82-- 83-- 84-- CHANGE HISTORY: 85-- 09 May 95 SAIC Initial prerelease version. 86-- 24 Apr 96 SAIC Added code to avoid dead variable optimization. 87-- 13 Feb 97 PWB.CTA Removed 'Class from qual expression at line 342. 88--! 89 90generic 91 type Designated_Type is tagged private; 92 type Operand_Type is access Designated_Type; 93package C460A01_0 is 94 type Target_Type is access all Designated_Type; 95 function Convert (P : Operand_Type) return Target_Type; 96end C460A01_0; 97 98 99 --==================================================================-- 100 101 102package body C460A01_0 is 103 function Convert (P : Operand_Type) return Target_Type is 104 begin 105 return Target_Type(P); -- Never fails. 106 end Convert; 107end C460A01_0; 108 109 110 --==================================================================-- 111 112 113generic 114 type Designated_Type is tagged private; 115 type Operand_Type is access all Designated_Type; 116 type Target_Type is access all Designated_Type; 117package C460A01_1 is 118 function Convert (P : Operand_Type) return Target_Type; 119end C460A01_1; 120 121 122 --==================================================================-- 123 124 125package body C460A01_1 is 126 function Convert (P : Operand_Type) return Target_Type is 127 begin 128 return Target_Type(P); 129 end Convert; 130end C460A01_1; 131 132 133 --==================================================================-- 134 135 136with F460A00; 137generic 138 type Designated_Type (<>) is new F460A00.Tagged_Type with private; 139 type Operand_Type is access Designated_Type; 140package C460A01_2 is 141 procedure Proc (P : Operand_Type; 142 Res : out F460A00.TC_Result_Kind); 143end C460A01_2; 144 145 146 --==================================================================-- 147 148with Report; 149package body C460A01_2 is 150 procedure Proc (P : Operand_Type; 151 Res : out F460A00.TC_Result_Kind) is 152 Ptr : F460A00.AccTag_L0; 153 begin 154 Ptr := F460A00.AccTag_L0(P); 155 156 -- Avoid optimization (dead variable removal of Ptr): 157 if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. 158 Report.Failed ("Unexpected error in C460A01_2 instance"); 159 end if; 160 161 Res := F460A00.OK; 162 exception 163 when Program_Error => Res := F460A00.PE_Exception; 164 when others => Res := F460A00.Others_Exception; 165 end Proc; 166end C460A01_2; 167 168 169 --==================================================================-- 170 171 172with F460A00; 173with C460A01_0; 174with C460A01_1; 175with C460A01_2; 176 177with Report; 178procedure C460A01 is 179begin -- C460A01. -- [ Level = 1 ] 180 181 Report.Test ("C460A01", "Run-time accessibility checks: instance " & 182 "bodies. Operand type of access type conversion is " & 183 "passed as actual to instance"); 184 185 186 SUBTEST1: 187 declare -- [ Level = 2 ] 188 type AccTag_L2 is access all F460A00.Tagged_Type; 189 Operand: AccTag_L2 := new F460A00.Tagged_Type; 190 191 Result : F460A00.TC_Result_Kind := F460A00.UN_Init; 192 begin -- SUBTEST1. 193 194 declare -- [ Level = 3 ] 195 -- The instantiation of C460A01_0 should NOT result in any 196 -- exceptions. 197 198 package Pack_OK is new C460A01_0 (F460A00.Tagged_Type, AccTag_L2); 199 Target : Pack_OK.Target_Type; 200 begin 201 -- The accessibility level of Pack_OK.Target_Type will always be at 202 -- least as deep as the operand type passed as an actual. Thus, 203 -- a call to Pack_OK.Convert does not propagate an exception: 204 205 Target := Pack_OK.Convert(Operand); 206 207 -- Avoid optimization (dead variable removal of Target): 208 if not Report.Equal (Target.C, Target.C) then -- Always false. 209 Report.Failed ("Unexpected error in SUBTEST #1"); 210 end if; 211 212 Result := F460A00.OK; -- Expected result. 213 exception 214 when Program_Error => Result := F460A00.PE_Exception; 215 when others => Result := F460A00.Others_Exception; 216 end; 217 218 F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); 219 220 exception 221 when Program_Error => 222 Report.Failed ("SUBTEST #1: Program_Error incorrectly raised"); 223 when others => 224 Report.Failed ("SUBTEST #1: Unexpected exception raised"); 225 end SUBTEST1; 226 227 228 229 SUBTEST2: 230 declare -- [ Level = 2 ] 231 type AccTag_L2 is access all F460A00.Tagged_Type; 232 Operand : AccTag_L2 := new F460A00.Tagged_Type; 233 234 Result : F460A00.TC_Result_Kind := F460A00.UN_Init; 235 begin -- SUBTEST2. 236 237 declare -- [ Level = 3 ] 238 239 type AccTag_L3 is access all F460A00.Tagged_Type; 240 Target : AccTag_L3; 241 242 -- The instantiation of C460A01_1 should NOT result in any 243 -- exceptions. 244 245 package Pack_OK is new C460A01_1 246 (Designated_Type => F460A00.Tagged_Type, 247 Operand_Type => AccTag_L2, 248 Target_Type => AccTag_L3); 249 begin 250 -- The accessibility level of the actual passed as the operand type 251 -- in Pack_OK is 2. The accessibility level of the actual passed as 252 -- the target type is 3. Therefore, the access type conversion in 253 -- Pack_OK.Convert does not raise an exception when the subprogram is 254 -- called. If an exception is (incorrectly) raised, it is propagated 255 -- to the innermost enclosing master: 256 257 Target := Pack_OK.Convert(Operand); 258 259 -- Avoid optimization (dead variable removal of Target): 260 if not Report.Equal (Target.C, Target.C) then -- Always false. 261 Report.Failed ("Unexpected error in SUBTEST #2"); 262 end if; 263 264 Result := F460A00.OK; -- Expected result. 265 exception 266 when Program_Error => Result := F460A00.PE_Exception; 267 when others => Result := F460A00.Others_Exception; 268 end; 269 270 F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #2"); 271 272 exception 273 when Program_Error => 274 Report.Failed ("SUBTEST #2: Program_Error incorrectly raised"); 275 when others => 276 Report.Failed ("SUBTEST #2: Unexpected exception raised"); 277 end SUBTEST2; 278 279 280 281 SUBTEST3: 282 declare -- [ Level = 2 ] 283 type AccTag_L2 is access all F460A00.Tagged_Type; 284 Target : AccTag_L2; 285 286 Result : F460A00.TC_Result_Kind := F460A00.UN_Init; 287 begin -- SUBTEST3. 288 289 declare -- [ Level = 3 ] 290 291 type AccTag_L3 is access all F460A00.Tagged_Type; 292 Operand : AccTag_L3 := new F460A00.Tagged_Type; 293 294 -- The instantiation of C460A01_1 should NOT result in any 295 -- exceptions. 296 297 package Pack_PE is new C460A01_1 298 (Designated_Type => F460A00.Tagged_Type, 299 Operand_Type => AccTag_L3, 300 Target_Type => AccTag_L2); 301 begin 302 -- The accessibility level of the actual passed as the operand type 303 -- in Pack_PE is 3. The accessibility level of the actual passed as 304 -- the target type is 2. Therefore, the access type conversion in 305 -- Pack_PE.Convert raises Program_Error when the subprogram is 306 -- called. The exception is propagated to the innermost enclosing 307 -- master: 308 309 Target := Pack_PE.Convert(Operand); 310 311 -- Avoid optimization (dead variable removal of Target): 312 if not Report.Equal (Target.C, Target.C) then -- Always false. 313 Report.Failed ("Unexpected error in SUBTEST #3"); 314 end if; 315 316 Result := F460A00.OK; 317 exception 318 when Program_Error => Result := F460A00.PE_Exception; 319 -- Expected result. 320 when others => Result := F460A00.Others_Exception; 321 end; 322 323 F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #3"); 324 325 exception 326 when Program_Error => 327 Report.Failed ("SUBTEST #3: Program_Error incorrectly raised"); 328 when others => 329 Report.Failed ("SUBTEST #3: Unexpected exception raised"); 330 end SUBTEST3; 331 332 333 334 SUBTEST4: 335 declare -- [ Level = 2 ] 336 Result : F460A00.TC_Result_Kind := F460A00.UN_Init; 337 begin -- SUBTEST4. 338 339 declare -- [ Level = 3 ] 340 341 TType : F460A00.Tagged_Type; 342 Operand : F460A00.AccTagClass_L0 343 := new F460A00.Tagged_Type'(TType); 344 345 -- The instantiation of C460A01_2 should NOT result in any 346 -- exceptions. 347 348 package Pack_OK is new C460A01_2 (F460A00.Tagged_Type'Class, 349 F460A00.AccTagClass_L0); 350 begin 351 -- The accessibility level of the actual passed as the operand type 352 -- in Pack_OK is 0. The accessibility level of the target type 353 -- (F460A00.AccTag_L0) is also 0. Therefore, the access type 354 -- conversion in Pack_OK.Proc does not raise an exception when the 355 -- subprogram is called. If an exception is (incorrectly) raised, 356 -- it is handled within the subprogram: 357 358 Pack_OK.Proc(Operand, Result); 359 end; 360 361 F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #4"); 362 363 exception 364 when Program_Error => 365 Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); 366 when others => 367 Report.Failed ("SUBTEST #4: Unexpected exception raised"); 368 end SUBTEST4; 369 370 371 372 SUBTEST5: 373 declare -- [ Level = 2 ] 374 Result : F460A00.TC_Result_Kind := F460A00.UN_Init; 375 begin -- SUBTEST5. 376 377 declare -- [ Level = 3 ] 378 379 type AccDerTag_L3 is access all F460A00.Derived_Tagged_Type; 380 Operand : AccDerTag_L3 := new F460A00.Derived_Tagged_Type; 381 382 -- The instantiation of C460A01_2 should NOT result in any 383 -- exceptions. 384 385 package Pack_PE is new C460A01_2 (F460A00.Derived_Tagged_Type, 386 AccDerTag_L3); 387 begin 388 -- The accessibility level of the actual passed as the operand type 389 -- in Pack_PE is 3. The accessibility level of the target type 390 -- (F460A00.AccTag_L0) is 0. Therefore, the access type conversion 391 -- in Pack_PE.Proc raises Program_Error when the subprogram is 392 -- called. The exception is handled within the subprogram: 393 394 Pack_PE.Proc(Operand, Result); 395 end; 396 397 F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #5"); 398 399 exception 400 when Program_Error => 401 Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); 402 when others => 403 Report.Failed ("SUBTEST #5: Unexpected exception raised"); 404 end SUBTEST5; 405 406 Report.Result; 407 408end C460A01; 409