diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a | 367 |
1 files changed, 367 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a new file mode 100644 index 000000000..8271d4869 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a @@ -0,0 +1,367 @@ +-- C3A2A01.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, for X'Access of a general access type A, Program_Error is +-- raised if the accessibility level of X is deeper than that of A. +-- Check for cases where X'Access occurs in an instance body, and A +-- is passed as an actual during instantiation. +-- +-- TEST DESCRIPTION: +-- In order to satisfy accessibility requirements, the designated +-- object X must be at the same or a less deep nesting level than the +-- general access type A -- X must "live" as long as A. 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 declares three generic units, each of which has a formal +-- general access type: +-- +-- (1) A generic package, in which X is declared in the specification, +-- and X'Access occurs within the declarative part of the body. +-- +-- (2) A generic package, in which X is a formal in out object of a +-- tagged formal derived type, and X'Access occurs in the sequence +-- of statements of a nested subprogram. +-- +-- (3) A generic procedure, in which X is a dereference of an access +-- parameter, and X'Access occurs in the sequence of statements. +-- +-- The test verifies the following: +-- +-- For (1), Program_Error is raised upon instantiation if the generic +-- package is instantiated at a deeper level than that of the general +-- access type passed as an actual. The exception is propagated to the +-- innermost enclosing master. +-- +-- For (2), Program_Error is raised when the nested subprogram is +-- called if the object passed as an actual during instantiation of +-- the generic package has an accessibility level deeper than that of +-- the general access type passed as an actual. The exception is +-- handled within the nested subprogram. Also, check that +-- Program_Error is not raised if the level of the actual access type +-- is deeper than that of the actual object. +-- +-- For (3), Program_Error is raised when the instance subprogram is +-- called if the object pointed to by the actual corresponding to +-- the access parameter has an accessibility level deeper than that of +-- the general access type passed as an actual during instantiation. +-- The exception is handled within the instance subprogram. Also, +-- check that Program_Error is not raised if the level of the actual +-- access type is deeper than that of the actual corresponding to the +-- access parameter. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F3A2A00.A +-- -> C3A2A01.A +-- +-- +-- CHANGE HISTORY: +-- 12 May 95 SAIC Initial prerelease version. +-- 10 Jul 95 SAIC Modified code to avoid dead variable optimization. +-- +--! + +with F3A2A00; +generic + type FD is new F3A2A00.Array_Type; + type FAF is access all FD; +package C3A2A01_0 is + X : aliased FD; + + procedure Dummy; -- Needed to allow package body. +end C3A2A01_0; + + + --==================================================================-- + + +with Report; +package body C3A2A01_0 is + Ptr : FAF := X'Access; + Index : Integer := F3A2A00.Array_Type'First; + + procedure Dummy is + begin + null; + end Dummy; +begin + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A01_0 instance"); + end if; +end C3A2A01_0; + + + --==================================================================-- + + +with F3A2A00; +generic + type FD is new F3A2A00.Tagged_Type with private; + type FAF is access all FD; + FObj : in out FD; +package C3A2A01_1 is + procedure Handle (R: out F3A2A00.TC_Result_Kind); +end C3A2A01_1; + + + --==================================================================-- + + +with Report; +package body C3A2A01_1 is + + procedure Handle (R: out F3A2A00.TC_Result_Kind) is + Ptr : FAF; + begin + Ptr := FObj'Access; + R := F3A2A00.OK; + + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in Handle"); + end if; + exception + when Program_Error => R := F3A2A00.P_E; + when others => R := F3A2A00.O_E; + end Handle; + +end C3A2A01_1; + + + --==================================================================-- + + +with F3A2A00; +generic + type FD is new F3A2A00.Array_Type; + type FAF is access all FD; +procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind); + + + --==================================================================-- + + +with Report; +procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind) is + Ptr : FAF; + Index : Integer := F3A2A00.Array_Type'First; +begin + Ptr := P.all'Access; + R := F3A2A00.OK; + + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A01_2 instance"); + end if; +exception + when Program_Error => R := F3A2A00.P_E; + when others => R := F3A2A00.O_E; +end C3A2A01_2; + + + --==================================================================-- + + +with F3A2A00; +with C3A2A01_0; +with C3A2A01_1; +with C3A2A01_2; + +with Report; +procedure C3A2A01 is +begin -- C3A2A01. -- [ Level = 1 ] + + Report.Test ("C3A2A01", "Run-time accessibility checks: instance " & + "bodies. Type of X'Access is passed as actual to instance"); + + + SUBTEST1: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST1. + + declare -- [ Level = 3 ] + type AccArr_L3 is access all F3A2A00.Array_Type; + begin + declare -- [ Level = 4 ] + -- The accessibility level of Pack.X is that of the instantiation + -- (4). The accessibility level of the actual access type used to + -- instantiate Pack is 3. Therefore, the X'Access in Pack + -- propagates Program_Error when the instance body is elaborated: + + package Pack is new C3A2A01_0 (F3A2A00.Array_Type, AccArr_L3); + begin + Result := F3A2A00.OK; + end; + exception + when Program_Error => Result := F3A2A00.P_E; -- Expected result. + when others => Result := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #1"); + + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_1 should NOT result in any + -- exceptions. + + type AccTag_L3 is access all F3A2A00.Tagged_Type; + + package Pack_OK is new C3A2A01_1 (F3A2A00.Tagged_Type, + AccTag_L3, + F3A2A00.X_L0); + begin + -- The accessibility level of the actual object used to instantiate + -- Pack_OK is 0. The accessibility level of the actual access type + -- used to instantiate Pack_OK is 3. Therefore, the FObj'Access in + -- Pack_OK.Handle does not raise an exception when the subprogram is + -- called. If an exception is (incorrectly) raised, however, it is + -- handled within the subprogram: + + Pack_OK.Handle (Result); + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.OK, "SUBTEST #2"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #2: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #2: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_1 should NOT result in any + -- exceptions. + + X_L3: F3A2A00.Tagged_Type; + + package Pack_PE is new C3A2A01_1 (F3A2A00.Tagged_Type, + F3A2A00.AccTag_L0, + X_L3); + begin + -- The accessibility level of the actual object used to instantiate + -- Pack_PE is 3. The accessibility level of the actual access type + -- used to instantiate Pack_PE is 0. Therefore, the FObj'Access in + -- Pack_OK.Handle raises Program_Error when the subprogram is + -- called. The exception is handled within the subprogram: + + Pack_PE.Handle (Result); + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #3"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #3: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST3; + + + + SUBTEST4: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST4. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_2 should NOT result in any + -- exceptions. + + X_L3: aliased F3A2A00.Array_Type; + type AccArr_L3 is access all F3A2A00.Array_Type; + + procedure Proc is new C3A2A01_2 (F3A2A00.Array_Type, AccArr_L3); + begin + -- The accessibility level of Proc.P.all is that of the corresponding + -- actual during the call (in this case 3). The accessibility level of + -- the access type used to instantiate Proc is also 3. Therefore, the + -- P.all'Access in Proc does not raise an exception when the + -- subprogram is called. If an exception is (incorrectly) raised, + -- however, it is handled within the subprogram: + + Proc (X_L3'Access, Result1); + + F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, + "SUBTEST #4: same levels"); + + declare -- [ Level = 4 ] + X_L4: aliased F3A2A00.Array_Type; + begin + -- Within this block, the accessibility level of the actual + -- corresponding to Proc.P.all is 4. Therefore, the P.all'Access + -- in Proc raises Program_Error when the subprogram is called. The + -- exception is handled within the subprogram: + + Proc (X_L4'Access, Result2); + + F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E, + "SUBTEST #4: object at deeper level"); + end; + + end; + + exception + when Program_Error => + Report.Failed ("SUBTEST #4: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #4: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST4; + + + Report.Result; + +end C3A2A01; |