diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460a02.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460a02.a | 413 |
1 files changed, 413 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460a02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460a02.a new file mode 100644 index 000000000..1d79d3a61 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c460a02.a @@ -0,0 +1,413 @@ +-- C460A02.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- 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 if the target type of a type conversion is a general +-- access type, Program_Error is raised if the accessibility level of +-- the operand type is deeper than that of the target type. Check for +-- cases where the type conversion occurs in an instance body, and +-- the operand type is declared inside the instance or is the anonymous +-- access type of an access parameter or access discriminant. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the operand type must +-- be at the same or a less deep nesting level than the target type -- the +-- operand type must "live" as long as the target type. Nesting levels +-- are the run-time nestings of masters: block statements; subprogram, +-- task, and entry bodies; and accept statements. Packages are invisible +-- to accessibility rules. +-- +-- This test checks for cases where the operand is a component of a +-- generic formal object, a stand-alone object, and an access parameter. +-- +-- The test declares three generic units, each containing an access +-- type conversion in which the target type is a formal type: +-- +-- (1) A generic package in which the operand type is the anonymous +-- access type of an access discriminant, and the conversion +-- occurs within the declarative part of the body. +-- +-- (2) A generic package in which the operand type is declared within +-- the specification, and the conversion occurs within the +-- sequence of statements of the body. +-- +-- (3) A generic procedure in which the operand type is the anonymous +-- access type of an access parameter, and the conversion occurs +-- within the sequence of statements. +-- +-- The test verifies the following: +-- +-- For (1), Program_Error is raised when the package is instantiated +-- if the actual passed through the formal object has an accessibility +-- level deeper than that of the target type passed as an actual, and +-- that no exception is raised otherwise. The exception is propagated +-- to the innermost enclosing master. +-- +-- For (2), Program_Error is raised when the package is instantiated +-- if the package is instantiated at a level deeper than that of the +-- target type passed as an actual, and that no exception is raised +-- otherwise. The exception is handled within the package body. +-- +-- For (3), Program_Error is raised when the instance procedure is +-- called if the actual passed through the access parameter has an +-- accessibility level deeper than that of the target type passed as +-- an actual, and that no exception is raised otherwise. The exception +-- is handled within the instance procedure. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F460A00.A +-- => C460A02.A +-- +-- +-- CHANGE HISTORY: +-- 10 May 95 SAIC Initial prerelease version. +-- 24 Apr 96 SAIC Changed the target type formal to be +-- access-to-constant; Modified code to avoid dead +-- variable optimization. +-- +--! + +with F460A00; +generic + type Target_Type is access all F460A00.Tagged_Type; + FObj: in out F460A00.Composite_Type; +package C460A02_0 is + procedure Dummy; -- Needed to allow package body. +end C460A02_0; + + + --==================================================================-- + +with Report; +package body C460A02_0 is + Ptr: Target_Type := Target_Type(FObj.D); + + procedure Dummy is + begin + null; + end Dummy; + +begin + -- Avoid optimization (dead variable removal of Ptr): + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C460A02_0 instance"); + end if; + +end C460A02_0; + + + --==================================================================-- + + +with F460A00; +generic + type Designated_Type is private; + type Target_Type is access all Designated_Type; + FObj : in out Target_Type; + FRes : in out F460A00.TC_Result_Kind; +package C460A02_1 is + type Operand_Type is access Designated_Type; + Ptr : Operand_Type := new Designated_Type; + + procedure Dummy; -- Needed to allow package body. +end C460A02_1; + + + --==================================================================-- + + +package body C460A02_1 is + procedure Dummy is + begin + null; + end Dummy; +begin + FRes := F460A00.UN_Init; + FObj := Target_Type(Ptr); + FRes := F460A00.OK; +exception + when Program_Error => FRes := F460A00.PE_Exception; + when others => FRes := F460A00.Others_Exception; +end C460A02_1; + + + --==================================================================-- + + +with F460A00; +generic + type Designated_Type is new F460A00.Tagged_Type with private; + type Target_Type is access constant Designated_Type; +procedure C460A02_2 (P : access Designated_Type'Class; + Res : out F460A00.TC_Result_Kind); + + + --==================================================================-- + + +with Report; +procedure C460A02_2 (P : access Designated_Type'Class; + Res : out F460A00.TC_Result_Kind) is + Ptr : Target_Type; +begin + Res := F460A00.UN_Init; + Ptr := Target_Type(P); + + -- Avoid optimization (dead variable removal of Ptr): + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C460A02_2 instance"); + end if; + Res := F460A00.OK; +exception + when Program_Error => Res := F460A00.PE_Exception; + when others => Res := F460A00.Others_Exception; +end C460A02_2; + + + --==================================================================-- + + +with F460A00; +with C460A02_0; +with C460A02_1; +with C460A02_2; + +with Report; +procedure C460A02 is +begin -- C460A02. -- [ Level = 1 ] + + Report.Test ("C460A02", "Run-time accessibility checks: instance " & + "bodies. Operand type of access type conversion is " & + "declared inside instance or is anonymous"); + + + SUBTEST1: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type; + Operand_L2 : F460A00.Composite_Type(PTag_L2); + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST1. + + begin -- [ Level = 3 ] + declare -- [ Level = 4 ] + -- The accessibility level of the actual passed as the target type + -- in Pack_OK is 2. The accessibility level of the composite actual + -- (and thus, the level of the anonymous type of the access + -- discriminant, which is the same as that of the containing + -- object) is also 2. Therefore, the access type conversion in + -- Pack_OK does not raise an exception upon instantiation: + + package Pack_OK is new C460A02_0 + (Target_Type => AccTag_L2, FObj => Operand_L2); + begin + Result := F460A00.OK; -- Expected result. + end; + exception + when Program_Error => Result := F460A00.PE_Exception; + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); + + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + Operand_L3 : F460A00.Composite_Type(PTag_L2); + begin + declare -- [ Level = 4 ] + -- The accessibility level of the actual passed as the target type + -- in Pack_PE is 2. The accessibility level of the composite actual + -- (and thus, the level of the anonymous type of the access + -- discriminant, which is the same as that of the containing + -- object) is 3. Therefore, the access type conversion in Pack_PE + -- propagates Program_Error upon instantiation: + + package Pack_PE is new C460A02_0 (AccTag_L2, Operand_L3); + begin + Result := F460A00.OK; + end; + exception + when Program_Error => Result := F460A00.PE_Exception; + -- Expected result. + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #2"); + + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + type AccArr_L3 is access all F460A00.Array_Type; + Target: AccArr_L3; + + -- The accessibility level of the actual passed as the target type + -- in Pack_OK is 3. The accessibility level of the operand type is + -- that of the instance, which is also 3. Therefore, the access type + -- conversion in Pack_OK does not raise an exception upon + -- instantiation. If an exception is (incorrectly) raised, it is + -- handled within the instance: + + package Pack_OK is new C460A02_1 + (Designated_Type => F460A00.Array_Type, + Target_Type => AccArr_L3, + FObj => Target, + FRes => Result); + begin + null; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #3"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly propagated"); + when others => + Report.Failed ("SUBTEST #3: Unexpected exception propagated"); + end SUBTEST3; + + + + SUBTEST4: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST4. + + declare -- [ Level = 3 ] + Target: F460A00.AccArr_L0; + + -- The accessibility level of the actual passed as the target type + -- in Pack_PE is 0. The accessibility level of the operand type is + -- that of the instance, which is 3. Therefore, the access type + -- conversion in Pack_PE raises Program_Error upon instantiation. + -- The exception is handled within the instance: + + package Pack_PE is new C460A02_1 + (Designated_Type => F460A00.Array_Type, + Target_Type => F460A00.AccArr_L0, + FObj => Target, + FRes => Result); + begin + null; + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #4"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #4: Unexpected exception raised"); + end SUBTEST4; + + + + SUBTEST5: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST5. + + declare -- [ Level = 3 ] + -- The instantiation of C460A02_2 should NOT result in any + -- exceptions. + + procedure Proc is new C460A02_2 (F460A00.Tagged_Type, + F460A00.AccTag_L0); + begin + -- The accessibility level of the actual passed to Proc is 0. The + -- accessibility level of the actual passed as the target type is + -- also 0. Therefore, the access type conversion in Proc does not + -- raise an exception when the subprogram is called. If an exception + -- is (incorrectly) raised, it is handled within the subprogram: + + Proc (F460A00.PTagClass_L0, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #5"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #5: Unexpected exception raised"); + end SUBTEST5; + + + + SUBTEST6: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST6. + + declare -- [ Level = 3 ] + -- The instantiation of C460A02_2 should NOT result in any + -- exceptions. + + procedure Proc is new C460A02_2 (F460A00.Tagged_Type, + F460A00.AccTag_L0); + begin + -- In the call to (instantiated) procedure Proc, the first actual + -- parameter is an allocator. Its accessibility level is that of + -- the level of execution of Proc, which is 3. The accessibility + -- level of the actual passed as the target type is 0. Therefore, + -- the access type conversion in Proc raises Program_Error when the + -- subprogram is called. The exception is handled within the + -- subprogram: + + Proc (new F460A00.Tagged_Type, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #6"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #6: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #6: Unexpected exception raised"); + end SUBTEST6; + + Report.Result; + +end C460A02; |