summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c3a2a02.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c3a2a02.a396
1 files changed, 396 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a b/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a
new file mode 100644
index 000000000..23b2c1c5d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a
@@ -0,0 +1,396 @@
+-- C3A2A02.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 a type either declared inside the instance, or declared outside
+-- the instance but not 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 packages:
+--
+-- (1) One in which X is of a formal tagged derived type and declared
+-- in the body, A is a type declared outside the instance, and
+-- X'Access occurs in the declarative part of a nested subprogram.
+--
+-- (2) One in which X is a formal object of a tagged type, A is a
+-- type declared outside the instance, and X'Access occurs in the
+-- declarative part of the body.
+--
+-- (3) One in which there are two X's and two A's. In the first pair,
+-- X is a formal in object of a tagged type, A is declared in the
+-- specification, and X'Access occurs in the declarative part of
+-- the body. In the second pair, X is of a formal derived type,
+-- X and A are declared in the specification, and X'Access occurs
+-- in the sequence of statements of the body.
+--
+-- The test verifies the following:
+--
+-- For (1), Program_Error is raised when the nested subprogram is
+-- called, if the generic package is instantiated at a deeper level
+-- than that of A. The exception is propagated to the innermost
+-- enclosing master. Also, check that Program_Error is not raised
+-- if the instantiation is at the same level as that of A.
+--
+-- For (2), Program_Error is raised upon instantiation if the object
+-- passed as an actual during instantiation has an accessibility level
+-- deeper than that of A. The exception is propagated to the innermost
+-- enclosing master. Also, check that Program_Error is not raised if
+-- the level of the actual object is not deeper than that of A.
+--
+-- For (3), Program_Error is not raised, for actual objects at
+-- various accessibility levels (since A will have at least the same
+-- accessibility level as X in all cases, no exception should ever
+-- be raised).
+--
+-- TEST FILES:
+-- The following files comprise this test:
+--
+-- F3A2A00.A
+-- -> C3A2A02.A
+--
+--
+-- CHANGE HISTORY:
+-- 12 May 95 SAIC Initial prerelease version.
+-- 10 Jul 95 SAIC Modified code to avoid dead variable optimization.
+-- 26 Jun 98 EDS Added pragma Elaborate (C3A2A02_0) to package
+-- package C3A2A02_3, in order to avoid possible
+-- instantiation error.
+--!
+
+with F3A2A00;
+generic
+ type FD is new F3A2A00.Tagged_Type with private;
+package C3A2A02_0 is
+ procedure Proc;
+end C3A2A02_0;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C3A2A02_0 is
+ X : aliased FD;
+
+ procedure Proc is
+ Ptr : F3A2A00.AccTagClass_L0 := X'Access;
+ begin
+ -- Avoid optimization (dead variable removal of Ptr):
+
+ if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
+ Report.Failed ("Unexpected error in Proc");
+ end if;
+ end Proc;
+end C3A2A02_0;
+
+
+ --==================================================================--
+
+
+with F3A2A00;
+generic
+ FObj : in out F3A2A00.Tagged_Type;
+package C3A2A02_1 is
+ procedure Dummy; -- Needed to allow package body.
+end C3A2A02_1;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C3A2A02_1 is
+ Ptr : F3A2A00.AccTag_L0 := FObj'Access;
+
+ 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 C3A2A02_1 instance");
+ end if;
+end C3A2A02_1;
+
+
+ --==================================================================--
+
+
+with F3A2A00;
+generic
+ type FD is new F3A2A00.Array_Type;
+ FObj : in F3A2A00.Tagged_Type;
+package C3A2A02_2 is
+ type GAF is access all FD;
+ type GAO is access constant F3A2A00.Tagged_Type;
+ XG : aliased FD;
+ PtrF : GAF;
+ Index : Integer := FD'First;
+
+ procedure Dummy; -- Needed to allow package body.
+end C3A2A02_2;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C3A2A02_2 is
+ PtrO : GAO := FObj'Access;
+
+ procedure Dummy is
+ begin
+ null;
+ end Dummy;
+begin
+ PtrF := XG'Access;
+
+ -- Avoid optimization (dead variable removal of PtrO and/or PtrF):
+
+ if not Report.Equal (PtrO.C, PtrO.C) then -- Always false.
+ Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrO");
+ end if;
+
+ if not Report.Equal (PtrF(Index).C, PtrF(Index).C) then -- Always false.
+ Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrF");
+ end if;
+end C3A2A02_2;
+
+
+ --==================================================================--
+
+
+-- The instantiation of C3A2A02_0 should NOT result in any exceptions.
+
+with F3A2A00;
+with C3A2A02_0;
+pragma Elaborate (C3A2A02_0);
+package C3A2A02_3 is new C3A2A02_0 (F3A2A00.Tagged_Type);
+
+
+ --==================================================================--
+
+
+with F3A2A00;
+with C3A2A02_0;
+with C3A2A02_1;
+with C3A2A02_2;
+with C3A2A02_3;
+
+with Report;
+procedure C3A2A02 is
+begin -- C3A2A02. -- [ Level = 1 ]
+
+ Report.Test ("C3A2A02", "Run-time accessibility checks: instance " &
+ "bodies. Type of X'Access is local or global to instance");
+
+
+ SUBTEST1:
+ declare -- [ Level = 2 ]
+ Result1 : F3A2A00.TC_Result_Kind;
+ Result2 : F3A2A00.TC_Result_Kind;
+ begin -- SUBTEST1.
+
+ declare -- [ Level = 3 ]
+ package Pack_Same_Level renames C3A2A02_3;
+ begin
+ -- The accessibility level of Pack_Same_Level.X is that of the
+ -- instance (0), not that of the renaming declaration. The level of
+ -- the type of Pack_Same_Level.X'Access (F3A2A00.AccTagClass_L0) is
+ -- 0. Therefore, the X'Access in Pack_Same_Level.Proc does not raise
+ -- an exception when the subprogram is called. The level of execution
+ -- of the subprogram is irrelevant:
+
+ Pack_Same_Level.Proc;
+ Result1 := F3A2A00.OK; -- Expected result.
+ exception
+ when Program_Error => Result1 := F3A2A00.P_E;
+ when others => Result1 := F3A2A00.O_E;
+ end;
+
+ F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
+ "SUBTEST #1 (same level)");
+
+
+ declare -- [ Level = 3 ]
+ -- The instantiation of C3A2A02_0 should NOT result in any
+ -- exceptions.
+
+ package Pack_Deeper_Level is new C3A2A02_0 (F3A2A00.Tagged_Type);
+ begin
+ -- The accessibility level of Pack_Deeper_Level.X is that of the
+ -- instance (3). The level of the type of Pack_Deeper_Level.X'Access
+ -- (F3A2A00.AccTagClass_L0) is 0. Therefore, the X'Access in
+ -- Pack_Deeper_Level.Proc propagates Program_Error when the
+ -- subprogram is called:
+
+ Pack_Deeper_Level.Proc;
+ Result2 := F3A2A00.OK;
+ exception
+ when Program_Error => Result2 := F3A2A00.P_E; -- Expected result.
+ when others => Result2 := F3A2A00.O_E;
+ end;
+
+ F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E,
+ "SUBTEST #1: deeper level");
+
+ exception
+ when Program_Error =>
+ Report.Failed ("SUBTEST #1: Program_Error incorrectly raised " &
+ "during instantiation of generic");
+ when others =>
+ Report.Failed ("SUBTEST #1: Unexpected exception raised " &
+ "during instantiation of generic");
+ end SUBTEST1;
+
+
+
+ SUBTEST2:
+ declare -- [ Level = 2 ]
+ Result1 : F3A2A00.TC_Result_Kind;
+ Result2 : F3A2A00.TC_Result_Kind;
+ begin -- SUBTEST2.
+
+ declare -- [ Level = 3 ]
+ X_L3 : F3A2A00.Tagged_Type;
+ begin
+ declare -- [ Level = 4 ]
+ -- The accessibility level of the actual object corresponding to
+ -- FObj in Pack_PE is 3. The level of the type of FObj'Access
+ -- (F3A2A00.AccTag_L0) is 0. Therefore, the FObj'Access in Pack_PE
+ -- propagates Program_Error when the instance body is elaborated:
+
+ package Pack_PE is new C3A2A02_1 (X_L3);
+ begin
+ Result1 := F3A2A00.OK;
+ end;
+ exception
+ when Program_Error => Result1 := F3A2A00.P_E; -- Expected result.
+ when others => Result1 := F3A2A00.O_E;
+ end;
+
+ F3A2A00.TC_Display_Results (Result1, F3A2A00.P_E,
+ "SUBTEST #2: deeper level");
+
+
+ begin -- [ Level = 3 ]
+ declare -- [ Level = 4 ]
+ -- The accessibility level of the actual object corresponding to
+ -- FObj in Pack_OK is 0. The level of the type of FObj'Access
+ -- (F3A2A00.AccTag_L0) is also 0. Therefore, the FObj'Access in
+ -- Pack_OK does not raise an exception when the instance body is
+ -- elaborated:
+
+ package Pack_OK is new C3A2A02_1 (F3A2A00.X_L0);
+ begin
+ Result2 := F3A2A00.OK; -- Expected result.
+ end;
+ exception
+ when Program_Error => Result2 := F3A2A00.P_E;
+ when others => Result2 := F3A2A00.O_E;
+ end;
+
+ F3A2A00.TC_Display_Results (Result2, F3A2A00.OK,
+ "SUBTEST #2: same level");
+
+ end SUBTEST2;
+
+
+
+ SUBTEST3:
+ declare -- [ Level = 2 ]
+ Result1 : F3A2A00.TC_Result_Kind;
+ Result2 : F3A2A00.TC_Result_Kind;
+ begin -- SUBTEST3.
+
+ declare -- [ Level = 3 ]
+ X_L3 : F3A2A00.Tagged_Type;
+ begin
+ declare -- [ Level = 4 ]
+ -- Since the accessibility level of the type of X'Access in
+ -- both cases within Pack_OK1 is that of the instance, and since
+ -- X is either passed as an actual (in which case its level will
+ -- not be deeper than that of the instance) or is declared within
+ -- the instance (in which case its level is the same as that of
+ -- the instance), no exception should be raised when the instance
+ -- body is elaborated:
+
+ package Pack_OK1 is new C3A2A02_2 (F3A2A00.Array_Type, X_L3);
+ begin
+ Result1 := F3A2A00.OK; -- Expected result.
+ end;
+ exception
+ when Program_Error => Result1 := F3A2A00.P_E;
+ when others => Result1 := F3A2A00.O_E;
+ end;
+
+ F3A2A00.TC_Display_Results (Result1, F3A2A00.OK,
+ "SUBTEST #3: 1st okay case");
+
+
+ declare -- [ Level = 3 ]
+ type My_Array is new F3A2A00.Array_Type;
+ begin
+ declare -- [ Level = 4 ]
+ -- Since the accessibility level of the type of X'Access in
+ -- both cases within Pack_OK2 is that of the instance, and since
+ -- X is either passed as an actual (in which case its level will
+ -- not be deeper than that of the instance) or is declared within
+ -- the instance (in which case its level is the same as that of
+ -- the instance), no exception should be raised when the instance
+ -- body is elaborated:
+
+ package Pack_OK2 is new C3A2A02_2 (My_Array, F3A2A00.X_L0);
+ begin
+ Result2 := F3A2A00.OK; -- Expected result.
+ end;
+ exception
+ when Program_Error => Result2 := F3A2A00.P_E;
+ when others => Result2 := F3A2A00.O_E;
+ end;
+
+ F3A2A00.TC_Display_Results (Result2, F3A2A00.OK,
+ "SUBTEST #3: 2nd okay case");
+
+
+ end SUBTEST3;
+
+
+
+ Report.Result;
+
+end C3A2A02;
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-25 23:27:58 +0000