diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c3a2a01.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c3a2a01.a | 367 |
1 files changed, 0 insertions, 367 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a b/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a deleted file mode 100644 index 8271d486904..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a +++ /dev/null @@ -1,367 +0,0 @@ --- 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; |