summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c6
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c6')
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c61008a.ada266
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c61009a.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c61010a.ada246
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62002a.ada190
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62003a.ada234
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62003b.ada301
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62004a.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c62006a.ada70
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c631001.a134
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c640001.a334
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64002b.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64004g.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005a.ada64
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005b.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005c.ada330
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005d0.ada219
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005da.ada65
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005db.ada67
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64005dc.ada74
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c641001.a281
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103b.ada379
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103c.ada230
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103d.ada187
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103e.ada219
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64103f.ada144
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104a.ada215
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104b.ada136
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104c.ada200
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104d.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104e.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104f.ada79
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104g.ada93
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104h.ada111
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104i.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104j.ada88
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104k.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104l.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104m.ada95
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104n.ada116
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64104o.ada112
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64105a.ada84
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64105b.ada184
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64105c.ada230
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64105d.ada134
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64106a.ada351
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64106b.ada237
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64106c.ada309
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64106d.ada280
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64107a.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64108a.ada148
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109a.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109b.ada155
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109c.ada127
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109d.ada128
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109e.ada156
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109f.ada126
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109g.ada125
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109h.ada160
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109i.ada163
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109j.ada164
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109k.ada191
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64109l.ada158
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64201b.ada101
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64201c.ada196
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c64202a.ada72
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c650001.a412
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c65003a.ada100
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c65003b.ada73
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002a.ada104
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002c.ada102
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002d.ada85
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002e.ada91
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002f.ada92
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c66002g.ada82
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002a.ada426
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002b.ada176
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002c.ada548
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002d.ada354
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67002e.ada348
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67003f.ada319
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67005a.ada96
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67005b.ada124
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67005c.ada109
-rw-r--r--gcc/testsuite/ada/acats/tests/c6/c67005d.ada78
84 files changed, 14158 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c6/c61008a.ada b/gcc/testsuite/ada/acats/tests/c6/c61008a.ada
new file mode 100644
index 000000000..eb60e89dc
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c61008a.ada
@@ -0,0 +1,266 @@
+-- C61008A.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF THE DEFAULT VALUE
+-- FOR A FORMAL PARAMETER DOES NOT SATISFY THE CONSTRAINTS OF THE
+-- SUBTYPE_INDICATION WHEN THE DECLARATION IS ELABORATED, ONLY WHEN
+-- THE DEFAULT IS USED.
+
+-- SUBTESTS ARE:
+-- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND
+-- INITIALIZED WITH A STATIC AGGREGATE.
+-- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS
+-- INITIALIZED WITH A STATIC VALUE.
+-- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC
+-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE.
+-- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB-
+-- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED
+-- WITH A STATIC AGGREGATE.
+-- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT
+-- INITIALIZED WITH A STATIC AGGREGATE.
+
+-- DAS 1/20/81
+-- SPS 10/26/82
+-- VKG 1/13/83
+-- SPS 2/9/83
+-- BHS 7/9/84
+
+WITH REPORT;
+PROCEDURE C61008A IS
+
+ USE REPORT;
+
+BEGIN
+
+ TEST ("C61008A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " &
+ "AN INITIALIZATION VALUE DOES NOT SATISFY " &
+ "CONSTRAINTS ON A FORMAL PARAMETER");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PROCEDURE PA (I1, I2 : INTEGER) IS
+
+ TYPE A1 IS ARRAY (1..I1,1..I2) OF INTEGER;
+
+ PROCEDURE PA1 (A : A1 := ((1,0),(0,1))) IS
+ BEGIN
+ FAILED ("BODY OF PA1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PA1");
+ END PA1;
+
+ BEGIN
+ PA1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - PA1");
+ END PA;
+
+ BEGIN -- (A)
+ PA (IDENT_INT(1), IDENT_INT(10));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN CALL TO PA");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ PROCEDURE PB (I1, I2 : INTEGER) IS
+
+ SUBTYPE INT IS INTEGER RANGE I1..I2;
+
+ PROCEDURE PB1 (I : INT := -1) IS
+ BEGIN
+ FAILED ("BODY OF PB1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PB1");
+ END PB1;
+
+ BEGIN
+ PB1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - PB1");
+ END PB;
+
+ BEGIN -- (B)
+ PB (IDENT_INT(0), IDENT_INT(63));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN CALL TO PB");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PROCEDURE PC (I1, I2 : INTEGER) IS
+ TYPE AR1 IS ARRAY (1..3) OF INTEGER RANGE I1..I2;
+ TYPE REC IS
+ RECORD
+ I : INTEGER RANGE I1..I2;
+ A : AR1 ;
+ END RECORD;
+
+ PROCEDURE PC1 (R : REC := (-3,(0,2,3))) IS
+ BEGIN
+ FAILED ("BODY OF PC1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PC1");
+ END PC1;
+
+ BEGIN
+ PC1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - PC1");
+ END PC;
+
+ BEGIN -- (C)
+ PC (IDENT_INT(1), IDENT_INT(3));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN CALL TO PC");
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D1)
+
+ PROCEDURE P1D (I1, I2 : INTEGER) IS
+
+ TYPE A1 IS ARRAY (1..2,1..2) OF INTEGER RANGE I1..I2;
+
+ PROCEDURE P1D1 (A : A1 := ((1,-1),(1,2))) IS
+ BEGIN
+ FAILED ("BODY OF P1D1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN P1D1");
+ END P1D1;
+
+ BEGIN
+ P1D1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - P1D1");
+ END P1D;
+
+ BEGIN -- (D1)
+ P1D (IDENT_INT(1), IDENT_INT(2));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN CALL TO P1D");
+ END; -- (D1)
+
+ --------------------------------------------------
+
+ DECLARE -- (D2)
+
+ PROCEDURE P2D (I1, I2 : INTEGER) IS
+
+ TYPE A1 IS ARRAY (1..2,1..2) OF INTEGER RANGE I1..I2;
+
+ PROCEDURE P2D1 (A : A1 := (3..4 => (1,2))) IS
+ BEGIN
+ FAILED ("BODY OF P2D1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN P2D1");
+ END P2D1;
+
+ BEGIN
+ P2D1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - P2D1");
+ END P2D;
+
+ BEGIN -- (D2)
+ P2D (IDENT_INT(1), IDENT_INT(2));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN CALL TO P2D");
+ END; -- (D2)
+
+ --------------------------------------------------
+
+ DECLARE -- (E)
+
+ PROCEDURE PE (I1, I2 : INTEGER) IS
+ SUBTYPE INT IS INTEGER RANGE 0..10;
+ TYPE ARR IS ARRAY (1..3) OF INT;
+ TYPE REC (I : INT) IS
+ RECORD
+ A : ARR;
+ END RECORD;
+
+ SUBTYPE REC4 IS REC(I1);
+
+ PROCEDURE PE1 (R : REC4 := (3,(1,2,3))) IS
+ BEGIN
+ FAILED ("BODY OF PE1 EXECUTED");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PE1");
+ END PE1;
+
+ BEGIN
+ PE1;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - PE1");
+ END PE;
+
+ BEGIN -- (E)
+ PE (IDENT_INT(4), IDENT_INT(10));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN CALL TO PE");
+ END; -- (E)
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C61008A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c61009a.ada b/gcc/testsuite/ada/acats/tests/c6/c61009a.ada
new file mode 100644
index 000000000..d98674d29
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c61009a.ada
@@ -0,0 +1,160 @@
+-- C61009A.ADA
+
+-- 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.
+--*
+-- CHECK THAT A STATIC EXPRESSION, CONSTANT NAME, ATTRIBUTE NAME,
+-- VARIABLE, DEREFERENCED ACCESS, USER-DEFINED OPERATOR, USER-
+-- DEFINED FUNCTION, OR ALLOCATOR CAN BE USED IN THE INITIALIZATION
+-- EXPRESSION OF A FORMAL PARAMETER, AND THAT THE APPROPRIATE
+-- VALUE IS USED AS A DEFAULT PARAMETER VALUE WHEN THE SUBPROGRAM
+-- IS CALLED.
+
+-- DAS 1/21/81
+-- ABW 7/20/82
+-- SPS 12/10/82
+
+WITH REPORT;
+PROCEDURE C61009A IS
+
+ USE REPORT;
+
+ TYPE INT IS RANGE 1 .. 10;
+
+ TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
+
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS
+ RECORD
+ A : ARR (0..CONSTRAINT);
+ END RECORD;
+
+ C7 : CONSTANT INTEGER := 7;
+ V7 : INTEGER := 7;
+
+ TYPE A_INT IS ACCESS INTEGER;
+ C_A : CONSTANT A_INT := NEW INTEGER'(7);
+
+ SUBTYPE RECTYPE1 IS RECTYPE (2 + 5);
+ SUBTYPE RECTYPE2 IS RECTYPE (C7);
+ SUBTYPE RECTYPE3 IS RECTYPE (V7);
+
+ FUNCTION "&" (X,Y : INTEGER) RETURN INTEGER IS
+ BEGIN
+ RETURN 10;
+ END "&";
+
+ FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS
+ BEGIN
+ RETURN X;
+ END FUNC;
+
+ -- STATIC EXPRESSION
+
+ PROCEDURE PROC1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))) IS
+ BEGIN
+ IF (REC /= (7,(0,1,2,3,4,5,6,7))) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR PROC1 PARAMETER");
+ END IF;
+ END PROC1;
+
+ -- CONSTANT NAME
+
+ PROCEDURE PROC2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))) IS
+ BEGIN
+ IF (REC /= (C7,(0,1,2,3,4,5,6,7))) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR PROC2 PARAMETER");
+ END IF;
+ END PROC2;
+
+ -- ATTRIBUTE NAME
+
+ PROCEDURE PROC3 (P1 : INT := INT'LAST) IS
+ BEGIN
+ IF (P1 /= INT (10)) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR PROC3 PARAMETER");
+ END IF;
+ END PROC3;
+
+ -- VARIABLE
+
+ PROCEDURE PROC4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))) IS
+ BEGIN
+ IF (P4 /= (V7,(0,1,2,3,4,5,6,7))) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR PROC4 PARAMETER");
+ END IF;
+ END PROC4;
+
+ --DEREFERENCED ACCESS
+
+ PROCEDURE PROC5 (P5 : INTEGER := C_A.ALL) IS
+ BEGIN
+ IF(P5 /= C_A.ALL) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR PROC5 PARAMETER");
+ END IF;
+ END PROC5;
+
+ --USER-DEFINED OPERATOR
+
+ PROCEDURE PROC6 (P6 : INTEGER := 6&4) IS
+ BEGIN
+ IF (P6 /= IDENT_INT(10)) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR PROC6 PARAMETER");
+ END IF;
+ END PROC6;
+
+ --USER-DEFINED FUNCTION
+
+ PROCEDURE PROC7 (P7 : INTEGER := FUNC(10)) IS
+ BEGIN
+ IF (P7 /= IDENT_INT(10)) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR PROC7 PARAMETER");
+ END IF;
+ END PROC7;
+
+ -- ALLOCATOR
+
+ PROCEDURE PROC8 (P8 : A_INT := NEW INTEGER'(7)) IS
+ BEGIN
+ IF (P8.ALL /= IDENT_INT(7)) THEN
+ FAILED ("INCORRECT DEFAULT VALUE FOR PROC8 PARAMETER");
+ END IF;
+ END PROC8;
+
+BEGIN
+ TEST ("C61009A", "CHECK USE OF STATIC EXPRESSIONS, CONSTANT " &
+ "NAMES, ATTRIBUTE NAMES, VARIABLES, USER- " &
+ "DEFINED OPERATORS, USER-DEFINED FUNCTIONS " &
+ "DEREFERENCED ACCESSES, AND ALLOCATORS IN " &
+ "THE FORMAL PART OF A SUBPROGRAM SPECIFICATION");
+
+ PROC1;
+ PROC2;
+ PROC3;
+ PROC4;
+ PROC5;
+ PROC6;
+ PROC7;
+ PROC8;
+
+ RESULT;
+
+END C61009A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c61010a.ada b/gcc/testsuite/ada/acats/tests/c6/c61010a.ada
new file mode 100644
index 000000000..ab35f4d46
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c61010a.ada
@@ -0,0 +1,246 @@
+-- C61010A.ADA
+
+-- 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.
+--*
+-- CHECK THAT AN IN OR IN OUT FORMAL PARAMETER CAN BE DECLARED WITH A
+-- LIMITED PRIVATE TYPE OR A LIMITED COMPOSITE TYPE.
+
+-- DAS 1/22/81
+-- JRK 1/20/84 TOTALLY REVISED.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C61010A IS
+
+ PACKAGE PKG IS
+
+ TYPE ITYPE IS LIMITED PRIVATE;
+
+ PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING);
+
+ PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
+ M : STRING);
+
+ PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER);
+
+ SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20;
+ TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE;
+
+ PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
+ S : STRING; M : STRING);
+
+ PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
+ I : INTEGER; S : STRING;
+ M : STRING);
+
+ PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
+ S : STRING);
+
+ PRIVATE
+
+ TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99;
+
+ TYPE VRTYPE (C : INT_0_20 := 20) IS
+ RECORD
+ I : INTEGER;
+ S : STRING (1 .. C);
+ END RECORD;
+
+ END PKG;
+
+ USE PKG;
+
+ I1 : ITYPE;
+
+ TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE;
+
+ A1 : ATYPE;
+
+ VR1 : VRTYPE;
+
+ D : CONSTANT INT_0_20 := 10;
+
+ TYPE RTYPE IS
+ RECORD
+ J : ITYPE;
+ R : VRTYPE (D);
+ END RECORD;
+
+ R1 : RTYPE;
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
+ BEGIN
+ IF INTEGER (X) /= V THEN
+ FAILED ("WRONG SCALAR VALUE - " & M);
+ END IF;
+ END LOOK_IN_I;
+
+ PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER;
+ M : STRING) IS
+ BEGIN
+ IF INTEGER (X) /= V THEN
+ FAILED ("WRONG SCALAR VALUE - " & M);
+ END IF;
+ END LOOK_INOUT_I;
+
+ PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER) IS
+ BEGIN
+ X := ITYPE (IDENT_INT (V));
+ END SET_I;
+
+ PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
+ S : STRING; M : STRING) IS
+ BEGIN
+ IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN
+ FAILED ("WRONG COMPOSITE VALUE - " & M);
+ END IF;
+ END LOOK_IN_VR;
+
+ PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER;
+ I : INTEGER; S : STRING;
+ M : STRING) IS
+ BEGIN
+ IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN
+ FAILED ("WRONG COMPOSITE VALUE - " & M);
+ END IF;
+ END LOOK_INOUT_VR;
+
+ PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER;
+ S : STRING) IS
+ BEGIN
+ X := (IDENT_INT(C), IDENT_INT(I), IDENT_STR(S));
+ END SET_VR;
+
+ BEGIN
+ I1 := ITYPE (IDENT_INT(2));
+
+ FOR I IN A1'RANGE LOOP
+ A1 (I) := ITYPE (3 + IDENT_INT(I));
+ END LOOP;
+
+ VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234"));
+
+ R1.J := ITYPE (IDENT_INT(6));
+ R1.R := (IDENT_INT(D), IDENT_INT(19),
+ IDENT_STR("ABCDEFGHIJ"));
+ END PKG;
+
+ PROCEDURE CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS
+ BEGIN
+ LOOK_IN_I (X, V, M);
+ END CHECK_IN_I;
+
+ PROCEDURE CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER;
+ NV : INTEGER; M : STRING) IS
+ BEGIN
+ LOOK_INOUT_I (X, OV, M & " - A");
+ SET_I (X, NV);
+ LOOK_INOUT_I (X, NV, M & " - B");
+ LOOK_IN_I (X, NV, M & " - C");
+ END CHECK_INOUT_I;
+
+ PROCEDURE CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) IS
+ BEGIN
+ FOR I IN X'RANGE LOOP
+ LOOK_IN_I (X(I), V+I, M & " -" & INTEGER'IMAGE (I));
+ END LOOP;
+ END CHECK_IN_A;
+
+ PROCEDURE CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER;
+ NV : INTEGER; M : STRING) IS
+ BEGIN
+ FOR I IN X'RANGE LOOP
+ LOOK_INOUT_I (X(I), OV+I, M & " - A" &
+ INTEGER'IMAGE (I));
+ SET_I (X(I), NV+I);
+ LOOK_INOUT_I (X(I), NV+I, M & " - B" &
+ INTEGER'IMAGE (I));
+ LOOK_IN_I (X(I), NV+I, M & " - C" & INTEGER'IMAGE (I));
+ END LOOP;
+ END CHECK_INOUT_A;
+
+ PROCEDURE CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER;
+ S : STRING; M : STRING) IS
+ BEGIN
+ LOOK_IN_VR (X, C, I, S, M);
+ END CHECK_IN_VR;
+
+ PROCEDURE CHECK_INOUT_VR (X : IN OUT VRTYPE;
+ OC : INTEGER; OI : INTEGER; OS : STRING;
+ NC : INTEGER; NI : INTEGER; NS : STRING;
+ M : STRING) IS
+ BEGIN
+ LOOK_INOUT_VR (X, OC, OI, OS, M & " - A");
+ SET_VR (X, NC, NI, NS);
+ LOOK_INOUT_VR (X, NC, NI, NS, M & " - B");
+ LOOK_IN_VR (X, NC, NI, NS, M & " - C");
+ END CHECK_INOUT_VR;
+
+ PROCEDURE CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER;
+ I : INTEGER; S : STRING; M : STRING) IS
+ BEGIN
+ LOOK_IN_I (X.J, J, M & " - A");
+ LOOK_IN_VR (X.R, C, I, S, M & " - B");
+ END CHECK_IN_R;
+
+ PROCEDURE CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER;
+ OC : INTEGER; OI : INTEGER; OS : STRING;
+ NJ : INTEGER;
+ NC : INTEGER; NI : INTEGER; NS : STRING;
+ M : STRING) IS
+ BEGIN
+ LOOK_INOUT_I (X.J, OJ, M & " - A");
+ LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B");
+ SET_I (X.J, NJ);
+ SET_VR (X.R, NC, NI, NS);
+ LOOK_INOUT_I (X.J, NJ, M & " - C");
+ LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D");
+ LOOK_IN_I (X.J, NJ, M & " - E");
+ LOOK_IN_VR (X.R, NC, NI, NS, M & " - F");
+ END CHECK_INOUT_R;
+
+BEGIN
+ TEST ("C61010A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " &
+ "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS");
+
+ CHECK_IN_I (I1, 2, "IN I");
+
+ CHECK_INOUT_I (I1, 2, 5, "INOUT I");
+
+ CHECK_IN_A (A1, 3, "IN A");
+
+ CHECK_INOUT_A (A1, 3, 17, "INOUT A");
+
+ CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR");
+
+ CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210",
+ "INOUT VR");
+
+ CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R");
+
+ CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, "ZYXWVUTSRQ",
+ "INOUT R");
+
+ RESULT;
+END C61010A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62002a.ada b/gcc/testsuite/ada/acats/tests/c6/c62002a.ada
new file mode 100644
index 000000000..f15bca7d2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c62002a.ada
@@ -0,0 +1,190 @@
+-- C62002A.ADA
+
+-- 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.
+--*
+-- CHECK THAT THE COMPONENTS OF ACCESS IN PARAMETERS CAN BE USED AS THE
+-- TARGET OF AN ASSIGNMENT STATEMENT OR AS AN ACTUAL PARAMETER OF
+-- ANY MODE. SUBTESTS ARE:
+-- (A) INTEGER ACCESS TYPE.
+-- (B) ARRAY ACCESS TYPE.
+-- (C) RECORD ACCESS TYPE.
+
+-- DAS 1/23/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C62002A IS
+
+ USE REPORT;
+
+BEGIN
+
+ TEST ("C62002A", "CHECK THAT COMPONENTS OF ACCESS IN PARAMETERS" &
+ " MAY BE USED IN ASSIGNMENT CONTEXTS");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE PTRINT IS ACCESS INTEGER;
+ PI : PTRINT;
+
+ PROCEDURE PROCA (PI : IN PTRINT) IS
+
+ PROCEDURE PROCA1 (I : OUT INTEGER) IS
+ BEGIN
+ I := 7;
+ END PROCA1;
+
+ PROCEDURE PROCA2 (I : IN OUT INTEGER) IS
+ BEGIN
+ I := I + 1;
+ END PROCA2;
+ BEGIN
+
+ PROCA1 (PI.ALL);
+ PROCA2 (PI.ALL);
+ PI.ALL := PI.ALL + 1;
+ IF (PI.ALL /= 9) THEN
+ FAILED ("ASSIGNMENT TO COMPONENT OF INTEGER" &
+ " ACCESS PARAMETER FAILED");
+ END IF;
+ END PROCA;
+
+ BEGIN -- (A)
+
+ PI := NEW INTEGER '(0);
+ PROCA (PI);
+
+ END; -- (A)
+
+ ---------------------------------------------
+
+ DECLARE -- (B)
+
+ TYPE TBL IS ARRAY (1..3) OF INTEGER;
+ TYPE PTRTBL IS ACCESS TBL;
+ PT : PTRTBL;
+
+ PROCEDURE PROCB (PT : IN PTRTBL) IS
+
+ PROCEDURE PROCB1 (I : OUT INTEGER) IS
+ BEGIN
+ I := 7;
+ END PROCB1;
+
+ PROCEDURE PROCB2 (I : IN OUT INTEGER) IS
+ BEGIN
+ I := I + 1;
+ END PROCB2;
+
+ PROCEDURE PROCB3 (T : OUT TBL) IS
+ BEGIN
+ T := (1,2,3);
+ END PROCB3;
+
+ PROCEDURE PROCB4 (T : IN OUT TBL) IS
+ BEGIN
+ T(3) := T(3) - 1;
+ END PROCB4;
+
+ BEGIN
+
+ PROCB3 (PT.ALL); -- (1,2,3)
+ PROCB4 (PT.ALL); -- (1,2,2)
+ PROCB1 (PT(2)); -- (1,7,2)
+ PROCB2 (PT(1)); -- (2,7,2)
+ PT(3) := PT(3) + 7; -- (2,7,9)
+ IF (PT.ALL /= (2,7,9)) THEN
+ FAILED ("ASSIGNMENT TO COMPONENT OF ARRAY" &
+ " ACCESS PARAMETER FAILED");
+ END IF;
+ END PROCB;
+
+ BEGIN -- (B)
+
+ PT := NEW TBL '(0,0,0);
+ PROCB (PT);
+
+ END; -- (B)
+
+ ---------------------------------------------
+
+ DECLARE -- (C)
+
+ TYPE REC IS
+ RECORD
+ I1 : INTEGER;
+ I2 : INTEGER;
+ I3 : INTEGER;
+ END RECORD;
+ TYPE PTRREC IS ACCESS REC;
+ PR : PTRREC;
+
+ PROCEDURE PROCC (PR : IN PTRREC) IS
+
+ PROCEDURE PROCC1 (I : OUT INTEGER) IS
+ BEGIN
+ I := 7;
+ END PROCC1;
+
+ PROCEDURE PROCC2 (I : IN OUT INTEGER) IS
+ BEGIN
+ I := I + 1;
+ END PROCC2;
+
+ PROCEDURE PROCC3 (R : OUT REC) IS
+ BEGIN
+ R := (1,2,3);
+ END PROCC3;
+
+ PROCEDURE PROCC4 (R : IN OUT REC) IS
+ BEGIN
+ R.I3 := R.I3 - 1;
+ END PROCC4;
+
+ BEGIN
+
+ PROCC3 (PR.ALL); -- (1,2,3)
+ PROCC4 (PR.ALL); -- (1,2,2)
+ PROCC1 (PR.I2); -- (1,7,2)
+ PROCC2 (PR.I1); -- (2,7,2)
+ PR.I3 := PR.I3 + 7; -- (2,7,9)
+ IF (PR.ALL /= (2,7,9)) THEN
+ FAILED ("ASSIGNMENT TO COMPONENT OF RECORD" &
+ " ACCESS PARAMETER FAILED");
+ END IF;
+ END PROCC;
+
+ BEGIN -- (C)
+
+ PR := NEW REC '(0,0,0);
+ PROCC (PR);
+
+ END; -- (C)
+
+ ---------------------------------------------
+
+ RESULT;
+
+END C62002A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62003a.ada b/gcc/testsuite/ada/acats/tests/c6/c62003a.ada
new file mode 100644
index 000000000..e5ab95a19
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c62003a.ada
@@ -0,0 +1,234 @@
+-- C62003A.ADA
+
+-- 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.
+--*
+-- CHECK THAT SCALAR AND ACCESS PARAMETERS ARE COPIED.
+-- SUBTESTS ARE:
+-- (A) SCALAR PARAMETERS TO PROCEDURES.
+-- (B) SCALAR PARAMETERS TO FUNCTIONS.
+-- (C) ACCESS PARAMETERS TO PROCEDURES.
+-- (D) ACCESS PARAMETERS TO FUNCTIONS.
+
+-- DAS 01/14/80
+-- SPS 10/26/82
+-- CPP 05/25/84
+-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+
+WITH REPORT;
+PROCEDURE C62003A IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C62003A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " &
+ "COPIED");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ I : INTEGER;
+ E : EXCEPTION;
+
+ PROCEDURE P (PI : IN INTEGER; PO : OUT INTEGER;
+ PIO : IN OUT INTEGER) IS
+
+ TMP : INTEGER;
+
+ BEGIN
+
+ TMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
+
+ PO := 10;
+ IF (PI /= TMP) THEN
+ FAILED ("ASSIGNMENT TO SCALAR OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TMP := PI; -- RESET TMP FOR NEXT CASE.
+ END IF;
+
+ PIO := PIO + 100;
+ IF (PI /= TMP) THEN
+ FAILED ("ASSIGNMENT TO SCALAR IN OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TMP := PI; -- RESET TMP FOR NEXT CASE.
+ END IF;
+
+ I := I + 1;
+ IF (PI /= TMP) THEN
+ FAILED ("ASSIGNMENT TO SCALAR ACTUAL " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ END IF;
+
+ RAISE E; -- CHECK EXCEPTION HANDLING.
+ END P;
+
+ BEGIN -- (A)
+ I := 0; -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED.
+ P (I, I, I);
+ FAILED ("EXCEPTION NOT RAISED - A");
+ EXCEPTION
+ WHEN E =>
+ IF (I /= 1) THEN
+ CASE I IS
+ WHEN 11 =>
+ FAILED ("OUT ACTUAL SCALAR PARAMETER " &
+ "CHANGED GLOBAL VALUE");
+ WHEN 101 =>
+ FAILED ("IN OUT ACTUAL SCALAR " &
+ "PARAMETER CHANGED GLOBAL VALUE");
+ WHEN 111 =>
+ FAILED ("OUT AND IN OUT ACTUAL SCALAR " &
+ "PARAMETERS CHANGED GLOBAL " &
+ "VALUE");
+ WHEN OTHERS =>
+ FAILED ("UNDETERMINED CHANGE TO GLOBAL " &
+ "VALUE");
+ END CASE;
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - A");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ I,J : INTEGER;
+
+ FUNCTION F (FI : IN INTEGER) RETURN INTEGER IS
+
+ TMP : INTEGER := FI;
+
+ BEGIN
+
+ I := I + 1;
+ IF (FI /= TMP) THEN
+ FAILED ("ASSIGNMENT TO SCALAR ACTUAL FUNCTION " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ END IF;
+
+ RETURN (100);
+ END F;
+
+ BEGIN -- (B)
+ I := 100;
+ J := F(I);
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ TYPE ACCTYPE IS ACCESS INTEGER;
+
+ I : ACCTYPE;
+ E : EXCEPTION;
+
+ PROCEDURE P (PI : IN ACCTYPE; PO : OUT ACCTYPE;
+ PIO : IN OUT ACCTYPE) IS
+
+ TMP : ACCTYPE;
+
+ BEGIN
+
+ TMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
+
+ I := NEW INTEGER'(101);
+ IF (PI /= TMP) THEN
+ FAILED ("ASSIGNMENT TO ACCESS ACTUAL " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TMP := PI; -- RESET TMP FOR NEXT CASE.
+ END IF;
+
+ PO := NEW INTEGER'(1);
+ IF (PI /= TMP) THEN
+ FAILED ("ASSIGNMENT TO ACCESS OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TMP := PI; -- RESET TMP FOR NEXT CASE.
+ END IF;
+
+ PIO := NEW INTEGER'(10);
+ IF (PI /= TMP) THEN
+ FAILED ("ASSIGNMENT TO ACCESS IN OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ END IF;
+
+ RAISE E; -- CHECK EXCEPTION HANDLING.
+ END P;
+
+ BEGIN -- (C)
+ I := NEW INTEGER'(100);
+ P (I, I, I);
+ FAILED ("EXCEPTION NOT RAISED - C");
+ EXCEPTION
+ WHEN E =>
+ IF (I.ALL /= 101) THEN
+ FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
+ "PARAMETER VALUE CHANGED DESPITE " &
+ "RAISED EXCEPTION");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - C");
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ TYPE ACCTYPE IS ACCESS INTEGER;
+
+ I,J : ACCTYPE;
+
+ FUNCTION F (FI : IN ACCTYPE) RETURN ACCTYPE IS
+
+ TMP : ACCTYPE := FI;
+
+ BEGIN
+
+ I := NEW INTEGER;
+ IF (FI /= TMP) THEN
+ FAILED ("ASSIGNMENT TO ACCESS ACTUAL FUNCTION " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ END IF;
+
+ RETURN (NULL);
+ END F;
+
+ BEGIN -- (D)
+ I := NULL;
+ J := F(I);
+ END; -- (D)
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C62003A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62003b.ada b/gcc/testsuite/ada/acats/tests/c6/c62003b.ada
new file mode 100644
index 000000000..f03c774de
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c62003b.ada
@@ -0,0 +1,301 @@
+-- C62003B.ADA
+
+-- 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.
+--*
+-- CHECK THAT PRIVATE TYPES IMPLEMENTED AS SCALAR OR ACCESS TYPES ARE
+-- PASSED BY COPY.
+-- SUBTESTS ARE:
+-- (A) PRIVATE SCALAR PARAMETERS TO PROCEDURES.
+-- (B) PRIVATE SCALAR PARAMETERS TO FUNCTIONS.
+-- (C) PRIVATE ACCESS PARAMETERS TO PROCEDURES.
+-- (D) PRIVATE ACCESS PARAMETERS TO FUNCTIONS.
+
+-- CPP 05/25/84
+-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C62003B IS
+
+BEGIN
+ TEST("C62003B", "CHECK THAT PRIVATE SCALAR AND ACCESS " &
+ "PARAMETERS ARE COPIED");
+
+ ---------------------------------------------------
+
+A_B: DECLARE
+
+ PACKAGE SCALAR_PKG IS
+
+ TYPE T IS PRIVATE;
+ C0 : CONSTANT T;
+ C1 : CONSTANT T;
+ C10 : CONSTANT T;
+ C100 : CONSTANT T;
+
+ FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T;
+ FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER;
+
+ PRIVATE
+ TYPE T IS NEW INTEGER;
+ C0 : CONSTANT T := 0;
+ C1 : CONSTANT T := 1;
+ C10 : CONSTANT T := 10;
+ C100 : CONSTANT T := 100;
+
+ END SCALAR_PKG;
+
+
+ PACKAGE BODY SCALAR_PKG IS
+
+ FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T IS
+ BEGIN -- "+"
+ RETURN T(INTEGER(OLD) + INTEGER(INCREMENT));
+ END "+";
+
+ FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER IS
+ BEGIN -- CONVERT
+ RETURN INTEGER(OLD_PRIVATE);
+ END CONVERT;
+
+ END SCALAR_PKG;
+
+ USE SCALAR_PKG;
+
+ ---------------------------------------------------
+
+ BEGIN -- A_B
+
+ A : DECLARE
+
+ I : T;
+ E : EXCEPTION;
+
+ PROCEDURE P (PI : IN T; PO : OUT T; PIO : IN OUT T) IS
+
+ TEMP : T;
+
+ BEGIN -- P
+
+ TEMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
+
+ PO := C10;
+ IF (PI /= TEMP) THEN
+ FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TEMP := PI; -- RESET TEMP FOR NEXT CASE.
+ END IF;
+
+ PIO := PIO + C100;
+ IF (PI /= TEMP) THEN
+ FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) IN " &
+ "OUT PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TEMP := PI; -- RESET TEMP FOR NEXT CASE.
+ END IF;
+
+ I := I + C1;
+ IF (PI /= TEMP) THEN
+ FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) " &
+ "ACTUAL PARAMETER CHANGES THE " &
+ "VALUE OF INPUT PARAMETER");
+ END IF;
+
+ RAISE E; -- CHECK EXCEPTION HANDLING.
+ END P;
+
+ BEGIN -- A
+ I := C0; -- INITIALIZE I SO VARIOUS CASES CAN BE
+ -- DETECTED.
+ P (I, I, I);
+ FAILED ("EXCEPTION NOT RAISED - A");
+ EXCEPTION
+ WHEN E =>
+ IF (I /= C1) THEN
+ CASE CONVERT(I) IS
+ WHEN 11 =>
+ FAILED ("OUT ACTUAL PRIVATE " &
+ "(SCALAR) PARAMETER " &
+ "CHANGED GLOBAL VALUE");
+ WHEN 101 =>
+ FAILED ("IN OUT ACTUAL PRIVATE " &
+ "(SCALAR) PARAMETER " &
+ "CHANGED GLOBAL VALUE");
+ WHEN 111 =>
+ FAILED ("OUT AND IN OUT ACTUAL " &
+ "PRIVATE (SCALAR) " &
+ "PARAMETER CHANGED " &
+ "GLOBAL VALUE");
+ WHEN OTHERS =>
+ FAILED ("UNDETERMINED CHANGE TO " &
+ "GLOBAL VALUE");
+ END CASE;
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - A");
+ END A;
+
+ ---------------------------------------------------
+
+ B : DECLARE
+
+ I, J : T;
+
+ FUNCTION F (FI : IN T) RETURN T IS
+
+ TEMP : T := FI; -- SAVE VALUE OF FI AT FN ENTRY.
+
+ BEGIN -- F
+
+ I := I + C1;
+ IF (FI /= TEMP) THEN
+ FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) " &
+ "ACTUAL FUNCTION PARAMETER CHANGES " &
+ "THE VALUE OF INPUT PARAMETER ");
+ END IF;
+
+ RETURN C0;
+ END F;
+
+ BEGIN -- B
+ I := C0;
+ J := F(I);
+ END B;
+
+ END A_B;
+
+ ---------------------------------------------------
+
+C_D: DECLARE
+
+ PACKAGE ACCESS_PKG IS
+
+ TYPE T IS PRIVATE;
+ C_NULL : CONSTANT T;
+ C1 : CONSTANT T;
+ C10 : CONSTANT T;
+ C100 : CONSTANT T;
+ C101 : CONSTANT T;
+
+ PRIVATE
+ TYPE T IS ACCESS INTEGER;
+ C_NULL : CONSTANT T := NULL;
+ C1 : CONSTANT T := NEW INTEGER'(1);
+ C10 : CONSTANT T := NEW INTEGER'(10);
+ C100 : CONSTANT T := NEW INTEGER'(100);
+ C101 : CONSTANT T := NEW INTEGER'(101);
+
+ END ACCESS_PKG;
+
+ USE ACCESS_PKG;
+
+ ---------------------------------------------------
+
+ BEGIN -- C_D;
+
+ C : DECLARE
+
+ I : T;
+ E : EXCEPTION;
+ PROCEDURE P (PI : IN T; PO : OUT T; PIO : IN OUT T) IS
+
+ TEMP : T;
+
+ BEGIN -- P
+
+ TEMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY.
+
+ I := C101;
+ IF (PI /= TEMP) THEN
+ FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) " &
+ "ACTUAL VARIABLE CHANGES THE VALUE " &
+ "OF INPUT PARAMETER");
+ TEMP := PI; -- RESET TEMP FOR NEXT CASE.
+ END IF;
+
+ PO := C1;
+ IF (PI /= TEMP) THEN
+ FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) OUT " &
+ "PARAMETER CHANGES THE VALUE OF " &
+ "INPUT PARAMETER");
+ TEMP := PI; -- RESET TEMP FOR NEXT CASE.
+ END IF;
+
+ PIO := C10;
+ IF (PI /= TEMP) THEN
+ FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) IN " &
+ "OUT PARAMETER CHANGES THE VALUE " &
+ "OF INPUT PARAMETER");
+ END IF;
+
+ RAISE E; -- CHECK EXCEPTION HANDLING.
+ END P;
+
+ BEGIN -- C
+ I := C100;
+ P (I, I, I);
+ FAILED ("EXCEPTION NOT RAISED - C");
+ EXCEPTION
+ WHEN E =>
+ IF (I /= C101) THEN
+ FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " &
+ "PARAMETER VALUE CHANGED DESPITE " &
+ "RAISED EXCEPTION");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - C");
+ END C;
+
+ ---------------------------------------------------
+
+ D : DECLARE
+
+ I, J : T;
+
+ FUNCTION F (FI : IN T) RETURN T IS
+
+ TEMP : T := FI; -- SAVE VALUE OF FI AT FN ENTRY.
+
+ BEGIN -- F
+ I := C100;
+ IF (FI /= TEMP) THEN
+ FAILED ("ASSIGNMENT TO PRIVATE " &
+ "(ACCESS) ACTUAL FUNCTION " &
+ "PARAMETER CHANGES THE VALUE " &
+ "OF INPUT PARAMETER");
+ END IF;
+ RETURN C_NULL;
+ END F;
+
+ BEGIN -- D
+ I := C_NULL;
+ J := F(I);
+ END D;
+
+ END C_D;
+
+ ---------------------------------------------------
+
+ RESULT;
+
+END C62003B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62004a.ada b/gcc/testsuite/ada/acats/tests/c6/c62004a.ada
new file mode 100644
index 000000000..408a6cd6f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c62004a.ada
@@ -0,0 +1,64 @@
+-- C62004A.ADA
+
+-- 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.
+--*
+-- CHECK THAT ALIASING IS PERMITTED FOR PARAMETERS OF COMPOSITE TYPES,
+-- E.G., THAT A MATRIX ADDITION PROCEDURE CAN BE CALLED WITH THREE
+-- IDENTICAL ARGUMENTS. (NOTE: ALIASING MAY NOT WORK FOR ARGUMENTS
+-- TO ALL SUBROUTINES SINCE PARAMETER PASSING IS IMPLEMENTATION
+-- DEPENDENT. HOWEVER, THIS TEST IS NOT ERRONEOUS.)
+
+-- DAS 1/26/81
+
+WITH REPORT;
+PROCEDURE C62004A IS
+
+ USE REPORT;
+
+ TYPE MATRIX IS ARRAY (1..3,1..3) OF INTEGER;
+
+ A : MATRIX := ((1,2,3),(4,5,6),(7,8,9));
+
+ PROCEDURE MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX) IS
+ BEGIN
+ FOR I IN 1..3 LOOP
+ FOR J IN 1..3 LOOP
+ SUM(I,J) := X(I,J) + Y(I,J);
+ END LOOP;
+ END LOOP;
+ END MAT_ADD;
+
+BEGIN
+
+ TEST ("C62004A", "CHECK THAT ALIASING IS PERMITTED FOR" &
+ " PARAMETERS OF COMPOSITE TYPES");
+
+ MAT_ADD (A, A, A);
+
+ IF (A /= ((2,4,6),(8,10,12),(14,16,18))) THEN
+ FAILED ("THE RESULT OF THE MATRIX ADDITION IS INCORRECT");
+ END IF;
+
+ RESULT;
+
+END C62004A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c62006a.ada b/gcc/testsuite/ada/acats/tests/c6/c62006a.ada
new file mode 100644
index 000000000..c3ca244d4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c62006a.ada
@@ -0,0 +1,70 @@
+-- C62006A.ADA
+
+-- 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.
+--*
+-- CHECK THAT THE DISCRIMINANTS OF AN OUT FORMAL PARAMETER, AS WELL AS
+-- THE DISCRIMINANTS OF THE SUBCOMPONENTS OF AN OUT FORMAL PARAMETER,
+-- MAY BE READ INSIDE THE PROCEDURE.
+
+-- SPS 2/17/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C62006A IS
+BEGIN
+
+ TEST ("C62006A", "CHECK THAT THE DISCRIMINANTS OF AN OUT FORMAL " &
+ "PARAMETER CAN BE READ INSIDE THE PROCEDURE");
+
+ DECLARE
+
+ TYPE R1 (D1 : INTEGER) IS RECORD
+ NULL;
+ END RECORD;
+
+ TYPE R2 (D2 : POSITIVE) IS RECORD
+ C : R1 (2);
+ END RECORD;
+
+ R : R2 (5);
+
+ PROCEDURE P (REC : OUT R2) IS
+ BEGIN
+
+ IF REC.D2 /= 5 THEN
+ FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" &
+ " OUT PARAMETER");
+ END IF;
+
+ IF REC.C.D1 /= 2 THEN
+ FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " &
+ " OF THE SUBCOMPONENT OF AN OUT PARAMETER");
+ END IF;
+ END P;
+
+ BEGIN
+ P (R);
+ END;
+
+ RESULT;
+
+END C62006A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c631001.a b/gcc/testsuite/ada/acats/tests/c6/c631001.a
new file mode 100644
index 000000000..f8b0c775b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c631001.a
@@ -0,0 +1,134 @@
+-- C631001.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 different forms of a name are used in the default
+-- expression of a discriminant part, the selector may be an operator
+-- symbol or a character literal.
+--
+-- TEST DESCRIPTION:
+-- This transition test defines private types where their selectors in
+-- the default expression of the discriminant parts at the full type
+-- declarations are an operator and a literal, respectively.
+-- The test also declares procedures that use an operator and a literal
+-- as selectors in the formal parts.
+--
+-- Inspired by B63102A.ADA.
+--
+--
+-- CHANGE HISTORY:
+-- 25 Mar 96 SAIC Initial version for ACVC 2.1.
+-- 26 Feb 97 PWB.CTA Removed use of function called before elaboration
+--!
+
+with Report;
+
+procedure C631001 is
+
+ package C631001_0 is
+
+ type Int_Type is range 1 .. 100;
+ type Enu_Type is ('A', 'B', 'C', 'D');
+
+ type Private_Enu (D : Enu_Type := 'B') is private;
+
+ function "+" (X, Y : Int_Type) return Int_Type;
+
+ procedure Int_Proc (P1 : in Int_Type := "+" (10, 15);
+ P2 : out Int_Type);
+
+ procedure Enu_Proc (P1 : in Enu_Type := 'C';
+ P2 : out Enu_Type);
+
+ private
+
+ type Private_Enu (D : Enu_Type := C631001_0.'B') is -- OK.
+ record
+ C2 : Enu_Type := D;
+ end record;
+
+ -----------------------------------------------------------------
+ PE_Obj : C631001_0.Private_Enu;
+
+ end C631001_0;
+
+ --==================================================================--
+
+ package body C631001_0 is
+
+ function "+" (X, Y : Int_Type) return Int_Type is
+ begin
+ return 10;
+ end "+";
+
+ -----------------------------------------------------------------
+ procedure Int_Proc (P1 : in Int_Type := C631001_0."+" (10, 15); -- OK.
+ P2 : out Int_Type) is
+
+ begin
+ P2 := P1;
+ end Int_Proc;
+
+ -----------------------------------------------------------------
+ procedure Enu_Proc (P1 : in Enu_Type := C631001_0.'C'; -- OK.
+ P2 : out Enu_Type) is
+ begin
+ P2 := P1;
+ end Enu_Proc;
+
+ -----------------------------------------------------------------
+
+ end C631001_0;
+
+ ---------------------------------------------------------------------------
+ Int_Obj : C631001_0.Int_Type := 50;
+ Enu_Obj : C631001_0.Enu_Type := C631001_0.'D';
+
+ -- Direct visibility to operator symbols
+ use type C631001_0.Int_Type;
+ use type C631001_0.Enu_Type;
+
+begin -- main
+
+ Report.Test ("C631001", "Check that if different forms of a name are " &
+ "used in the default expression of a discriminant part, " &
+ "the selector may be an operator symbol or a character " &
+ "literal");
+
+ C631001_0.Int_Proc (P2 => Int_Obj);
+
+ if Int_Obj /= 10 then
+ Report.Failed ("Wrong result for Int_Obj");
+ end if;
+
+ C631001_0.Enu_Proc (P2 => Enu_Obj);
+
+ if Enu_Obj /= 'C' then
+ Report.Failed ("Wrong result for Enu_Obj");
+ end if;
+
+ Report.Result;
+
+end C631001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c640001.a b/gcc/testsuite/ada/acats/tests/c6/c640001.a
new file mode 100644
index 000000000..8e259162e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c640001.a
@@ -0,0 +1,334 @@
+-- C640001.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 the prefix of a subprogram call with an actual parameter
+-- part may be an implicit dereference of an access-to-subprogram value.
+-- Check that, for an access-to-subprogram type whose designated profile
+-- contains parameters of a tagged generic formal type, an access-to-
+-- subprogram value may designate dispatching and non-dispatching
+-- operations, and that dereferences of such a value call the appropriate
+-- subprogram.
+--
+-- TEST DESCRIPTION:
+-- The test declares a tagged type (Table) with a dispatching operation
+-- (Clear), as well as a derivative (Table2) which overrides that
+-- operation. A subprogram with the same name and profile as Clear is
+-- declared in a separate package -- it is therefore not a dispatching
+-- operation of Table. For the purposes of the test, each version of Clear
+-- modifies the components of its parameter in a unique way.
+--
+-- Additionally, an operation (Reset) of type Table is declared which
+-- makes a re-dispatching call to Clear, i.e.,
+--
+-- procedure Reset (A: in out Table) is
+-- begin
+-- ...
+-- Clear (Table'Class(A)); -- Re-dispatch based on tag of actual.
+-- ...
+-- end Reset;
+--
+-- An access-to-subprogram type is declared within a generic package,
+-- with a designated profile which declares a parameter of a generic
+-- formal tagged private type.
+--
+-- The generic is instantiated with type Table. The instance defines an
+-- array of access-to-subprogram values (which represents a table of
+-- operations to be performed sequentially on a single operand).
+-- Access values designating the dispatching version of Clear, the
+-- non-dispatching version of Clear, and Reset (which re-dispatches to
+-- Clear) are placed in this array.
+--
+-- In the instance, each subprogram in the array is called by implicitly
+-- dereferencing the corresponding access value. For the dispatching and
+-- non-dispatching versions of Clear, the actual parameter passed is of
+-- type Table. For Reset, the actual parameter passed is a view conversion
+-- of an object of type Table2 to type Table, i.e., Table(Table2_Obj).
+-- Since the tag of the operand never changes, the call to Clear within
+-- Reset should execute Table2's version of Clear.
+--
+-- The main program verifies that the appropriate version of Clear is
+-- called in each case, by checking that the components of the actual are
+-- updated as expected.
+--
+--
+-- CHANGE HISTORY:
+-- 06 Dec 94 SAIC ACVC 2.0
+--
+--!
+
+package C640001_0 is
+
+ -- Data type artificial for testing purposes.
+
+ Row_Len : constant := 10;
+
+ T : constant Boolean := True;
+ F : constant Boolean := False;
+
+ type Row_Type is array (1 .. Row_Len) of Boolean;
+
+ function Is_True (A : in Row_Type) return Boolean;
+ function Is_False (A : in Row_Type) return Boolean;
+
+
+ Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F);
+
+ type Table is tagged record -- Tagged type.
+ Row1 : Row_Type := Init;
+ Row2 : Row_Type := Init;
+ end record;
+
+ procedure Clear (A : in out Table); -- Dispatching operation.
+
+ procedure Reset (A : in out Table); -- Re-dispatching operation.
+
+ -- ...Other operations.
+
+
+ type Table2 is new Table with null record; -- Extension of Table (but
+ -- structurally identical).
+
+ procedure Clear (A : in out Table2); -- Overrides parent's op.
+
+ -- ...Other operations.
+
+
+end C640001_0;
+
+
+ --===================================================================--
+
+
+package body C640001_0 is
+
+ function Is_True (A : in Row_Type) return Boolean is
+ begin
+ for I in A'Range loop
+ if A(I) /= True then -- Return true if all elements
+ return False; -- of A are True.
+ end if;
+ end loop;
+ return True;
+ end Is_True;
+
+
+ function Is_False (A : in Row_Type) return Boolean is
+ begin
+ return A = Row_Type'(others => False); -- Return true if all elements
+ end Is_False; -- of A are False.
+
+
+ procedure Clear (A : in out Table) is
+ begin
+ for I in Row_Type'Range loop -- This version of Clear sets
+ A.Row1(I) := False; -- the elements of Row1 only
+ end loop; -- to False.
+ end Clear;
+
+
+ procedure Reset (A : in out Table) is
+ begin
+ Clear (Table'Class(A)); -- Redispatch to appropriate
+ -- ... Other "reset" activities. -- version of Clear.
+ end Reset;
+
+
+ procedure Clear (A : in out Table2) is
+ begin
+ for I in Row_Type'Range loop -- This version of Clear sets
+ A.Row1(I) := True; -- the elements of Row1 only
+ end loop; -- to True.
+ end Clear;
+
+
+end C640001_0;
+
+
+ --===================================================================--
+
+
+with C640001_0;
+package C640001_1 is
+
+ procedure Clear (T : in out C640001_0.Table); -- Non-dispatching operation.
+
+end C640001_1;
+
+
+ --===================================================================--
+
+
+package body C640001_1 is
+
+ procedure Clear (T : in out C640001_0.Table) is
+ begin
+ for I in C640001_0.Row_Type'Range loop -- This version of Clear sets
+ T.Row2(I) := True; -- the elements of Row2 only
+ end loop; -- to True.
+ end Clear;
+
+end C640001_1;
+
+
+ --===================================================================--
+
+
+-- This unit represents a support package for table-driven processing of
+-- data objects. Process_Operand performs a set of operations are performed
+-- sequentially on a single operand. Note that parameters are provided to
+-- specify which subset of operations in the operations table are to be
+-- performed (ordinarily these might be omitted, but the test requires that
+-- each operation be called individually for a single operand).
+
+generic
+ type Tag is tagged private;
+package C640001_2 is
+
+ type Proc_Ptr is access procedure (P: in out Tag);
+
+ type Op_List is private;
+
+ procedure Add_Op (Op : in Proc_Ptr; -- Add operation to
+ List : in out Op_List); -- to list of ops.
+
+ procedure Process_Operand (Operand : in out Tag; -- Execute a subset
+ List : in Op_List; -- of a list of
+ First_Op : in Positive; -- operations using
+ Last_Op : in Positive); -- a given operand.
+
+ -- ...Other operations.
+
+private
+ type Op_Array is array (1 .. 3) of Proc_Ptr;
+
+ type Op_List is record
+ Top : Natural := 0;
+ Ops : Op_Array;
+ end record;
+end C640001_2;
+
+
+ --===================================================================--
+
+
+package body C640001_2 is
+
+ procedure Add_Op (Op : in Proc_Ptr;
+ List : in out Op_List) is
+ begin
+ List.Top := List.Top + 1; -- Artificial; no Constraint_Error protection.
+ List.Ops(List.Top) := Op;
+ end Add_Op;
+
+
+ procedure Process_Operand (Operand : in out Tag;
+ List : in Op_List;
+ First_Op : in Positive;
+ Last_Op : in Positive) is
+ begin
+ for I in First_Op .. Last_Op loop
+ List.Ops(I)(Operand); -- Implicit dereference of an
+ end loop; -- access-to-subprogram value.
+ end Process_Operand;
+
+end C640001_2;
+
+
+ --===================================================================--
+
+
+with C640001_0;
+with C640001_1;
+with C640001_2;
+
+with Report;
+procedure C640001 is
+
+ package Table_Support is new C640001_2 (C640001_0.Table);
+
+ Sub_Ptr : Table_Support.Proc_Ptr;
+ My_List : Table_Support.Op_List;
+ My_Table1 : C640001_0.Table; -- Initial values of both Row1 &
+ -- Row2 are (T,F,T,F,T,F,T,F,T,F).
+ My_Table2 : C640001_0.Table2; -- Initial values of both Row1 &
+ -- Row2 are (T,F,T,F,T,F,T,F,T,F).
+begin
+ Report.Test ("C640001", "Check that, for an access-to-subprogram type " &
+ "whose designated profile contains parameters " &
+ "of a tagged generic formal type, an access-" &
+ "to-subprogram value may designate dispatching " &
+ "and non-dispatching operations");
+
+ --
+ -- Add subprogram access values to list:
+ --
+
+ Sub_Ptr := C640001_0.Clear'Access; -- Designates dispatching op.
+ Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List).
+
+ Sub_Ptr := C640001_1.Clear'Access; -- Designates non-dispatching op.
+ Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List).
+
+ Sub_Ptr := C640001_0.Reset'Access; -- Designates re-dispatching op.
+ Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List).
+
+
+ --
+ -- Call dispatching operation:
+ --
+
+ Table_Support.Process_Operand (My_Table1, My_List, 1, 1); -- Call 1st op.
+
+ if not C640001_0.Is_False (My_Table1.Row1) then
+ Report.Failed ("Wrong result after calling dispatching operation");
+ end if;
+
+
+ --
+ -- Call non-dispatching operation:
+ --
+
+ Table_Support.Process_Operand (My_Table1, My_List, 2, 2); -- Call 2nd op.
+
+ if not C640001_0.Is_True (My_Table1.Row2) then
+ Report.Failed ("Wrong result after calling non-dispatching operation");
+ end if;
+
+
+ --
+ -- Call re-dispatching operation:
+ --
+
+ Table_Support.Process_Operand (C640001_0.Table(My_Table2), -- View conv.
+ My_List, 3, 3); -- Call 3rd op.
+
+ if not C640001_0.Is_True (My_Table2.Row1) then
+ Report.Failed ("Wrong result after calling re-dispatching operation");
+ end if;
+
+
+ Report.Result;
+end C640001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64002b.ada b/gcc/testsuite/ada/acats/tests/c6/c64002b.ada
new file mode 100644
index 000000000..2f71f32d0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64002b.ada
@@ -0,0 +1,65 @@
+-- C64002B.ADA
+
+-- 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.
+--*
+-- CHECK THAT PARAMETERLESS SUBPROGRAMS CAN BE CALLED WITH APPROPRIATE
+-- NOTATION.
+
+-- DAS 1/27/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64002B IS
+
+ USE REPORT;
+
+ I : INTEGER := 1;
+
+ FUNCTION F0 RETURN INTEGER IS
+ BEGIN
+ RETURN 7;
+ END F0;
+
+ PROCEDURE P0 IS
+ BEGIN
+ I := 15;
+ END P0;
+
+BEGIN
+
+ TEST ("C64002B", "CHECK THAT PARAMETERLESS SUBPROGRAMS CAN BE" &
+ " CALLED");
+
+ IF (F0 /= 7) THEN
+ FAILED ("PARAMETERLESS FUNCTION CALL RETURNS BAD VALUE");
+ END IF;
+
+ P0;
+ IF (I /= 15) THEN
+ FAILED ("PARAMETERLESS PROCEDURE CALL YIELDS INCORRECT" &
+ " RESULT");
+ END IF;
+
+ RESULT;
+
+END C64002B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64004g.ada b/gcc/testsuite/ada/acats/tests/c6/c64004g.ada
new file mode 100644
index 000000000..005a3a742
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64004g.ada
@@ -0,0 +1,102 @@
+-- C64004G.ADA
+
+-- 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.
+--*
+-- CHECK THAT FOR CALLS TO SUBPROGRAMS HAVING AT LEAST ONE DEFAULT
+-- PARAMETER, THE CORRECT ASSOCIATION IS MADE BETWEEN ACTUAL AND
+-- FORMAL PARAMETERS.
+
+-- DAS 1/27/81
+
+
+WITH REPORT;
+PROCEDURE C64004G IS
+
+ USE REPORT;
+
+ Y1,Y2,Y3 : INTEGER := 0;
+ O1,O2 : INTEGER := 0;
+
+ PROCEDURE P (I1: INTEGER; I2: INTEGER := 2; I3: INTEGER := 3;
+ O1,O2,O3: OUT INTEGER) IS
+ BEGIN
+ O1 := I1;
+ O2 := I2;
+ O3 := I3;
+ END P;
+
+ FUNCTION F (I1: INTEGER := 1; I2: INTEGER) RETURN INTEGER IS
+ BEGIN
+ C64004G.O1 := I1;
+ C64004G.O2 := I2;
+ RETURN 1;
+ END F;
+
+BEGIN
+
+ TEST ("C64004G", "CHECK ASSOCIATIONS BETWEEN ACTUAL AND FORMAL" &
+ " PARAMETERS (HAVING DEFAULT VALUES)");
+
+ P (I1=>11, I2=>12, I3=>13, O1=>Y1, O2=>Y2, O3=>Y3);
+ IF (Y1 /= 11) OR (Y2 /= 12) OR (Y3 /= 13) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 1");
+ END IF;
+
+ P (I1=>21, O1=>Y1, O2=>Y2, O3=>Y3);
+ IF (Y1 /= 21) OR (Y2 /= 2) OR (Y3 /= 3) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 2");
+ END IF;
+
+ P (O1=>Y1, O3=>Y3, I1=>31, I3=>33, O2=>Y2);
+ IF (Y1 /= 31) OR (Y2 /= 2) OR (Y3 /= 33) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 3");
+ END IF;
+
+ P (41, 42, O1=>Y1, O2=>Y2, O3=>Y3);
+ IF (Y1 /= 41) OR (Y2 /= 42) OR (Y3 /= 3) THEN
+ FAILED ("INCORRECT PARANETER ASSOCIATION - 4");
+ END IF;
+
+ P (51, O3=>Y3, O1=>Y1, O2=>Y2, I3=>53);
+ IF (Y1 /= 51) OR (Y2 /= 2) OR (Y3 /= 53) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 5");
+ END IF;
+
+ Y1 := F (I1=>61, I2=>62);
+ IF (O1 /= 61) OR (O2 /= 62) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 6");
+ END IF;
+
+ Y2 := F (I2=>72, I1=>71);
+ IF (O1 /= 71) OR (O2 /= 72) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 7");
+ END IF;
+
+ Y3 := F (I2=>82);
+ IF (O1 /= 1) OR (O2 /= 82) THEN
+ FAILED ("INCORRECT PARAMETER ASSOCIATION - 8");
+ END IF;
+
+ RESULT;
+
+END C64004G;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005a.ada b/gcc/testsuite/ada/acats/tests/c6/c64005a.ada
new file mode 100644
index 000000000..af5584e9d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64005a.ada
@@ -0,0 +1,64 @@
+-- C64005A.ADA
+
+-- 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.
+--*
+-- CHECK THAT A SUBPROGRAM CAN BE CALLED
+-- RECURSIVELY AND THAT NON-LOCAL VARIABLES AND
+-- CONSTANTS ARE PROPERLY ACCESSED FROM WITHIN
+-- RECURSIVE INVOCATIONS.
+
+-- CVP 5/1/81
+
+WITH REPORT;
+PROCEDURE C64005A IS
+
+ USE REPORT;
+
+ TWENTY : CONSTANT INTEGER := 20;
+ C1 : CONSTANT INTEGER := 1;
+ I1, I2 : INTEGER := 0;
+
+ PROCEDURE RECURSE (I1A : INTEGER; I2 : IN OUT INTEGER) IS
+ C1 : CONSTANT INTEGER := 5;
+ BEGIN
+ IF I1A < TWENTY THEN
+ RECURSE (I1A+C1, I2);
+ I1 := I1 + C64005A.C1;
+ I2 := I2 + I1A;
+ END IF;
+ END RECURSE;
+
+BEGIN
+ TEST ("C64005A", "RECURSIVE SUBPROGRAMS WITH " &
+ "NON-LOCAL DATA ACCESS");
+
+ RECURSE (0, I2);
+
+ IF I1 /= 4 OR I2 /= 30 THEN
+ FAILED ("RECURSIVE PROCEDURE INVOCATIONS " &
+ "WITH GLOBAL DATA ACCESS NOT PERFORMED " &
+ "CORRECTLY");
+ END IF;
+
+ RESULT;
+END C64005A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005b.ada b/gcc/testsuite/ada/acats/tests/c6/c64005b.ada
new file mode 100644
index 000000000..5e3f4c507
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64005b.ada
@@ -0,0 +1,109 @@
+-- C64005B.ADA
+
+-- 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.
+--*
+-- CHECK THAT A SUBPROGRAM CAN BE CALLED RECURSIVELY AND THAT NON-LOCAL
+-- VARIABLES AND CONSTANTS ARE PROPERLY ACCESSED FROM WITHIN RECURSIVE
+-- INVOCATIONS.
+
+-- CPP 7/2/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64005B IS
+
+ COUNT : INTEGER := 0;
+ TWENTY : CONSTANT INTEGER := 20;
+ C1 : CONSTANT INTEGER := 1;
+ G1, G2, G3 : INTEGER := 0;
+ G4, G5 : INTEGER := 0;
+
+ PROCEDURE R (A1 : INTEGER; A2 : IN OUT INTEGER; A3 : OUT INTEGER)
+ IS
+ C1 : CONSTANT INTEGER := 5;
+ TEN : CONSTANT INTEGER := 10;
+ J1, J2 : INTEGER := 1;
+ J3 : INTEGER := 0;
+
+ PROCEDURE RECURSE (P1 : INTEGER; P2 : IN OUT INTEGER) IS
+ C1 : INTEGER := 2;
+ BEGIN -- RECURSE
+ C1 := IDENT_INT (10);
+ IF P1 < TWENTY THEN
+ RECURSE (P1 + C1, G2);
+ G1 := G1 + C64005B.C1;
+ G3 := G3 + P1;
+ P2 := P2 + IDENT_INT(2);
+ A2 := A2 + IDENT_INT(1);
+ J2 := J2 + R.C1;
+ END IF;
+ END RECURSE;
+
+ BEGIN -- R
+ IF A2 < TEN THEN
+ A2 := A2 + C1;
+ RECURSE (0, J1);
+ J3 := J3 + TEN;
+ COUNT := COUNT + 1;
+ COMMENT ("ON PASS # " & INTEGER'IMAGE(COUNT));
+ COMMENT ("VALUE OF A2 IS " & INTEGER'IMAGE(A2));
+ COMMENT ("VALUE OF J3 IS " & INTEGER'IMAGE(J3));
+ R (0, A2, J3);
+ J3 := J3 + A2;
+ END IF;
+ A3 := J1 + J3;
+ END R;
+
+BEGIN
+ TEST("C64005B", "RECURSIVE SUBPROGRAMS WITH ALL KINDS " &
+ "OF DATA ACCESS");
+
+ R (0, G4, G5);
+
+ IF (COUNT /= 2) OR (G1 /= 4) OR
+ (G2 /= 4) OR (G3 /= 20) OR
+ (G4 /= 14) OR (G5 /= 35) THEN
+ FAILED ("RECURSIVE INVOCATIONS' DATA ACCESS IS NOT" &
+ " WORKING CORRECTLY");
+ END IF;
+
+ COMMENT ("VALUE OF COUNT IS " & INTEGER'IMAGE(COUNT));
+ COMMENT ("VALUE OF G1 IS " & INTEGER'IMAGE(G1));
+ COMMENT ("VALUE OF G2 IS " & INTEGER'IMAGE(G2));
+ COMMENT ("VALUE OF G3 IS " & INTEGER'IMAGE(G3));
+ COMMENT ("VALUE OF G4 IS " & INTEGER'IMAGE(G4));
+ COMMENT ("VALUE OF G5 IS " & INTEGER'IMAGE(G5));
+
+ RESULT;
+
+EXCEPTION
+ WHEN PROGRAM_ERROR =>
+ FAILED ("PROGRAM_ERROR RAISED");
+ COMMENT ("VALUE OF COUNT IS " & INTEGER'IMAGE(COUNT));
+ COMMENT ("VALUE OF G1 IS " & INTEGER'IMAGE(G1));
+ COMMENT ("VALUE OF G2 IS " & INTEGER'IMAGE(G2));
+ COMMENT ("VALUE OF G3 IS " & INTEGER'IMAGE(G3));
+ COMMENT ("VALUE OF G4 IS " & INTEGER'IMAGE(G4));
+ COMMENT ("VALUE OF G5 IS " & INTEGER'IMAGE(G5));
+ RESULT;
+
+END C64005B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005c.ada b/gcc/testsuite/ada/acats/tests/c6/c64005c.ada
new file mode 100644
index 000000000..ccb0a2a0e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64005c.ada
@@ -0,0 +1,330 @@
+-- C64005C.ADA
+
+-- 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.
+--*
+-- CHECK THAT NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT
+-- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM
+-- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR
+-- STATIC CHAIN LEVEL CAN BE ACCESSED.
+
+-- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES.
+
+-- JRK 7/26/84
+
+WITH REPORT; USE REPORT;
+
+PROCEDURE C64005C IS
+
+ SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C';
+ SUBTYPE CALL IS CHARACTER RANGE '1' .. '3';
+
+ MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) -
+ LEVEL'POS (LEVEL'FIRST) + 1;
+ T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV +
+ MAX_LEV*(MAX_LEV+1)/2*2)) + 1;
+ G_LEN : CONSTANT := 2 + 4 * MAX_LEV;
+
+ TYPE TRACE IS
+ RECORD
+ E : NATURAL := 0;
+ S : STRING (1 .. T_LEN);
+ END RECORD;
+
+ V : CHARACTER := IDENT_CHAR ('<');
+ L : CHARACTER := IDENT_CHAR ('>');
+ T : TRACE;
+ G : STRING (1 .. G_LEN);
+
+ PROCEDURE C64005CA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
+
+ V : STRING (1..2);
+
+ M : CONSTANT NATURAL := LEVEL'POS (L) -
+ LEVEL'POS (LEVEL'FIRST) + 1;
+ N : CONSTANT NATURAL := 2 * M + 1;
+
+ PROCEDURE C64005CB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
+
+ V : STRING (1..2);
+
+ M : CONSTANT NATURAL := LEVEL'POS (L) -
+ LEVEL'POS (LEVEL'FIRST) + 1;
+ N : CONSTANT NATURAL := 2 * M + 1;
+
+ PROCEDURE C64005CC (L : LEVEL; C : CALL;
+ T : IN OUT TRACE) IS
+
+ V : STRING (1..2);
+
+ M : CONSTANT NATURAL := LEVEL'POS (L) -
+ LEVEL'POS (LEVEL'FIRST) + 1;
+ N : CONSTANT NATURAL := 2 * M + 1;
+
+ BEGIN
+
+ V (1) := IDENT_CHAR (ASCII.LC_C);
+ V (2) := C;
+
+ -- APPEND ALL V TO T.
+ T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V &
+ C64005CB.V & C64005CC.V;
+ T.E := T.E + N;
+
+ CASE C IS
+
+ WHEN '1' =>
+ C64005CA (IDENT_CHAR(LEVEL'FIRST),
+ IDENT_CHAR('2'), T);
+
+ WHEN '2' =>
+ C64005CC (L, IDENT_CHAR('3'), T);
+
+ WHEN '3' =>
+ -- APPEND MID-POINT SYMBOL TO T.
+ T.S (T.E+1) := IDENT_CHAR ('=');
+ T.E := T.E + 1;
+
+ -- G := CATENATE ALL V, L, C;
+ G := C64005C.V & C64005C.L &
+ C64005CA.V & C64005CA.L & C64005CA.C &
+ C64005CB.V & C64005CB.L & C64005CB.C &
+ C64005CC.V & C64005CC.L & C64005CC.C;
+ END CASE;
+
+ -- APPEND ALL L AND C TO T IN REVERSE ORDER.
+ T.S (T.E+1 .. T.E+N) := C64005CC.L & C64005CC.C &
+ C64005CB.L & C64005CB.C &
+ C64005CA.L & C64005CA.C &
+ C64005C.L;
+ T.E := T.E + N;
+
+ END C64005CC;
+
+ BEGIN
+
+ V (1) := IDENT_CHAR (ASCII.LC_B);
+ V (2) := C;
+
+ -- APPEND ALL V TO T.
+ T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V &
+ C64005CB.V;
+ T.E := T.E + N;
+
+ CASE C IS
+
+ WHEN '1' =>
+ C64005CC (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
+
+ WHEN '2' =>
+ C64005CB (L, IDENT_CHAR('3'), T);
+
+ WHEN '3' =>
+ C64005CC (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
+ END CASE;
+
+ -- APPEND ALL L AND C TO T IN REVERSE ORDER.
+ T.S (T.E+1 .. T.E+N) := C64005CB.L & C64005CB.C &
+ C64005CA.L & C64005CA.C &
+ C64005C.L;
+ T.E := T.E + N;
+
+ END C64005CB;
+
+ BEGIN
+
+ V (1) := IDENT_CHAR (ASCII.LC_A);
+ V (2) := C;
+
+ -- APPEND ALL V TO T.
+ T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V;
+ T.E := T.E + N;
+
+ CASE C IS
+
+ WHEN '1' =>
+ C64005CB (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
+
+ WHEN '2' =>
+ C64005CA (L, IDENT_CHAR('3'), T);
+
+ WHEN '3' =>
+ C64005CB (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
+ END CASE;
+
+ -- APPEND ALL L AND C TO T IN REVERSE ORDER.
+ T.S (T.E+1 .. T.E+N) := C64005CA.L & C64005CA.C & C64005C.L;
+ T.E := T.E + N;
+
+ END C64005CA;
+
+BEGIN
+ TEST ("C64005C", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " &
+ "PARAMETERS AT ALL LEVELS OF NESTED " &
+ "RECURSIVE PROCEDURES ARE ACCESSIBLE");
+
+ -- APPEND V TO T.
+ T.S (T.E+1) := V;
+ T.E := T.E + 1;
+
+ C64005CA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T);
+
+ -- APPEND L TO T.
+ T.S (T.E+1) := L;
+ T.E := T.E + 1;
+
+ COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E));
+ COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E));
+ COMMENT ("GLOBAL SNAPSHOT IS: " & G);
+
+ -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY.
+
+ DECLARE
+ SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A ..
+ CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1);
+
+ CT : TRACE;
+ CG : STRING (1 .. G_LEN);
+ BEGIN
+ COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " &
+ INTEGER'IMAGE(T_LEN));
+
+ IF T.E /= IDENT_INT (T_LEN) THEN
+ FAILED ("WRONG FINAL CALL TRACE LENGTH");
+
+ ELSE CT.S (CT.E+1) := '<';
+ CT.E := CT.E + 1;
+
+ FOR I IN LC_LEVEL LOOP
+ CT.S (CT.E+1) := '<';
+ CT.E := CT.E + 1;
+
+ FOR J IN LC_LEVEL'FIRST .. I LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '1';
+ CT.E := CT.E + 2;
+ END LOOP;
+ END LOOP;
+
+ FOR I IN LC_LEVEL LOOP
+ CT.S (CT.E+1) := '<';
+ CT.E := CT.E + 1;
+
+ FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '3';
+ CT.E := CT.E + 2;
+ END LOOP;
+
+ CT.S (CT.E+1) := I;
+ CT.S (CT.E+2) := '2';
+ CT.E := CT.E + 2;
+
+ CT.S (CT.E+1) := '<';
+ CT.E := CT.E + 1;
+
+ FOR J IN LC_LEVEL'FIRST .. I LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '3';
+ CT.E := CT.E + 2;
+ END LOOP;
+ END LOOP;
+
+ CT.S (CT.E+1) := '=';
+ CT.E := CT.E + 1;
+
+ FOR I IN REVERSE LEVEL LOOP
+ FOR J IN REVERSE LEVEL'FIRST .. I LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '3';
+ CT.E := CT.E + 2;
+ END LOOP;
+
+ CT.S (CT.E+1) := '>';
+ CT.E := CT.E + 1;
+
+ CT.S (CT.E+1) := I;
+ CT.S (CT.E+2) := '2';
+ CT.E := CT.E + 2;
+
+ FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '3';
+ CT.E := CT.E + 2;
+ END LOOP;
+
+ CT.S (CT.E+1) := '>';
+ CT.E := CT.E + 1;
+ END LOOP;
+
+ FOR I IN REVERSE LEVEL LOOP
+ FOR J IN REVERSE LEVEL'FIRST .. I LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '1';
+ CT.E := CT.E + 2;
+ END LOOP;
+
+ CT.S (CT.E+1) := '>';
+ CT.E := CT.E + 1;
+ END LOOP;
+
+ CT.S (CT.E+1) := '>';
+ CT.E := CT.E + 1;
+
+ IF CT.E /= IDENT_INT (T_LEN) THEN
+ FAILED ("WRONG ITERATIVE TRACE LENGTH");
+
+ ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S);
+
+ IF T.S /= CT.S THEN
+ FAILED ("WRONG FINAL CALL TRACE");
+ END IF;
+ END IF;
+ END IF;
+
+ DECLARE
+ E : NATURAL := 0;
+ BEGIN
+ CG (1..2) := "<>";
+ E := E + 2;
+
+ FOR I IN LEVEL LOOP
+ CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) -
+ LEVEL'POS(LEVEL'FIRST) +
+ LC_LEVEL'POS
+ (LC_LEVEL'FIRST));
+ CG (E+2) := '3';
+ CG (E+3) := I;
+ CG (E+4) := '3';
+ E := E + 4;
+ END LOOP;
+
+ COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG);
+
+ IF G /= CG THEN
+ FAILED ("WRONG GLOBAL SNAPSHOT");
+ END IF;
+ END;
+ END;
+
+ RESULT;
+END C64005C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada b/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada
new file mode 100644
index 000000000..adc8a0b55
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada
@@ -0,0 +1,219 @@
+-- C64005D0M.ADA
+
+-- 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.
+--*
+-- CHECK THAT NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT
+-- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM
+-- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR
+-- STATIC CHAIN LEVEL CAN BE ACCESSED.
+
+-- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES (SEPARATELY
+-- COMPILED AS SUBUNITS).
+
+-- SEPARATE FILES ARE:
+-- C64005D0M THE MAIN PROCEDURE.
+-- C64005DA A RECURSIVE PROCEDURE SUBUNIT OF C64005D0M.
+-- C64005DB A RECURSIVE PROCEDURE SUBUNIT OF C64005DA.
+-- C64005DC A RECURSIVE PROCEDURE SUBUNIT OF C64005DB.
+
+-- JRK 7/30/84
+
+WITH REPORT; USE REPORT;
+
+PROCEDURE C64005D0M IS
+
+ SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C';
+ SUBTYPE CALL IS CHARACTER RANGE '1' .. '3';
+
+ MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) -
+ LEVEL'POS (LEVEL'FIRST) + 1;
+ T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV +
+ MAX_LEV*(MAX_LEV+1)/2*2)) + 1;
+ G_LEN : CONSTANT := 2 + 4 * MAX_LEV;
+
+ TYPE TRACE IS
+ RECORD
+ E : NATURAL := 0;
+ S : STRING (1 .. T_LEN);
+ END RECORD;
+
+ V : CHARACTER := IDENT_CHAR ('<');
+ L : CHARACTER := IDENT_CHAR ('>');
+ T : TRACE;
+ G : STRING (1 .. G_LEN);
+
+ PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
+ SEPARATE;
+
+BEGIN
+ TEST ("C64005D", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " &
+ "PARAMETERS AT ALL LEVELS OF NESTED " &
+ "RECURSIVE PROCEDURES ARE ACCESSIBLE (FOR " &
+ "3 LEVELS OF SEPARATELY COMPILED SUBUNITS)");
+
+ -- APPEND V TO T.
+ T.S (T.E+1) := V;
+ T.E := T.E + 1;
+
+ C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T);
+
+ -- APPEND L TO T.
+ T.S (T.E+1) := L;
+ T.E := T.E + 1;
+
+ COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E));
+ COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E));
+ COMMENT ("GLOBAL SNAPSHOT IS: " & G);
+
+ -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY.
+
+ DECLARE
+ SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A ..
+ CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1);
+
+ CT : TRACE;
+ CG : STRING (1 .. G_LEN);
+ BEGIN
+ COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " &
+ INTEGER'IMAGE(T_LEN));
+
+ IF T.E /= IDENT_INT (T_LEN) THEN
+ FAILED ("WRONG FINAL CALL TRACE LENGTH");
+
+ ELSE CT.S (CT.E+1) := '<';
+ CT.E := CT.E + 1;
+
+ FOR I IN LC_LEVEL LOOP
+ CT.S (CT.E+1) := '<';
+ CT.E := CT.E + 1;
+
+ FOR J IN LC_LEVEL'FIRST .. I LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '1';
+ CT.E := CT.E + 2;
+ END LOOP;
+ END LOOP;
+
+ FOR I IN LC_LEVEL LOOP
+ CT.S (CT.E+1) := '<';
+ CT.E := CT.E + 1;
+
+ FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '3';
+ CT.E := CT.E + 2;
+ END LOOP;
+
+ CT.S (CT.E+1) := I;
+ CT.S (CT.E+2) := '2';
+ CT.E := CT.E + 2;
+
+ CT.S (CT.E+1) := '<';
+ CT.E := CT.E + 1;
+
+ FOR J IN LC_LEVEL'FIRST .. I LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '3';
+ CT.E := CT.E + 2;
+ END LOOP;
+ END LOOP;
+
+ CT.S (CT.E+1) := '=';
+ CT.E := CT.E + 1;
+
+ FOR I IN REVERSE LEVEL LOOP
+ FOR J IN REVERSE LEVEL'FIRST .. I LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '3';
+ CT.E := CT.E + 2;
+ END LOOP;
+
+ CT.S (CT.E+1) := '>';
+ CT.E := CT.E + 1;
+
+ CT.S (CT.E+1) := I;
+ CT.S (CT.E+2) := '2';
+ CT.E := CT.E + 2;
+
+ FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '3';
+ CT.E := CT.E + 2;
+ END LOOP;
+
+ CT.S (CT.E+1) := '>';
+ CT.E := CT.E + 1;
+ END LOOP;
+
+ FOR I IN REVERSE LEVEL LOOP
+ FOR J IN REVERSE LEVEL'FIRST .. I LOOP
+ CT.S (CT.E+1) := J;
+ CT.S (CT.E+2) := '1';
+ CT.E := CT.E + 2;
+ END LOOP;
+
+ CT.S (CT.E+1) := '>';
+ CT.E := CT.E + 1;
+ END LOOP;
+
+ CT.S (CT.E+1) := '>';
+ CT.E := CT.E + 1;
+
+ IF CT.E /= IDENT_INT (T_LEN) THEN
+ FAILED ("WRONG ITERATIVE TRACE LENGTH");
+
+ ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S);
+
+ IF T.S /= CT.S THEN
+ FAILED ("WRONG FINAL CALL TRACE");
+ END IF;
+ END IF;
+ END IF;
+
+ DECLARE
+ E : NATURAL := 0;
+ BEGIN
+ CG (1..2) := "<>";
+ E := E + 2;
+
+ FOR I IN LEVEL LOOP
+ CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) -
+ LEVEL'POS(LEVEL'FIRST) +
+ LC_LEVEL'POS
+ (LC_LEVEL'FIRST));
+ CG (E+2) := '3';
+ CG (E+3) := I;
+ CG (E+4) := '3';
+ E := E + 4;
+ END LOOP;
+
+ COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG);
+
+ IF G /= CG THEN
+ FAILED ("WRONG GLOBAL SNAPSHOT");
+ END IF;
+ END;
+ END;
+
+ RESULT;
+END C64005D0M;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005da.ada b/gcc/testsuite/ada/acats/tests/c6/c64005da.ada
new file mode 100644
index 000000000..33a50aa5f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64005da.ada
@@ -0,0 +1,65 @@
+-- C64005DA.ADA
+
+-- 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.
+--*
+-- JRK 7/30/84
+
+SEPARATE (C64005D0M)
+
+PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
+
+ V : STRING (1..2);
+
+ M : CONSTANT NATURAL := LEVEL'POS (L) -
+ LEVEL'POS (LEVEL'FIRST) + 1;
+ N : CONSTANT NATURAL := 2 * M + 1;
+
+ PROCEDURE C64005DB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
+ SEPARATE;
+
+BEGIN
+
+ V (1) := IDENT_CHAR (ASCII.LC_A);
+ V (2) := C;
+
+ -- APPEND ALL V TO T.
+ T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V;
+ T.E := T.E + N;
+
+ CASE C IS
+
+ WHEN '1' =>
+ C64005DB (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
+
+ WHEN '2' =>
+ C64005DA (L, IDENT_CHAR('3'), T);
+
+ WHEN '3' =>
+ C64005DB (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
+ END CASE;
+
+ -- APPEND ALL L AND C TO T IN REVERSE ORDER.
+ T.S (T.E+1 .. T.E+N) := C64005DA.L & C64005DA.C & C64005D0M.L;
+ T.E := T.E + N;
+
+END C64005DA;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005db.ada b/gcc/testsuite/ada/acats/tests/c6/c64005db.ada
new file mode 100644
index 000000000..92a5892a3
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64005db.ada
@@ -0,0 +1,67 @@
+-- C64005DB.ADA
+
+-- 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.
+--*
+-- JRK 7/30/84
+
+SEPARATE (C64005D0M.C64005DA)
+
+PROCEDURE C64005DB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
+
+ V : STRING (1..2);
+
+ M : CONSTANT NATURAL := LEVEL'POS (L) -
+ LEVEL'POS (LEVEL'FIRST) + 1;
+ N : CONSTANT NATURAL := 2 * M + 1;
+
+ PROCEDURE C64005DC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
+ SEPARATE;
+
+BEGIN
+
+ V (1) := IDENT_CHAR (ASCII.LC_B);
+ V (2) := C;
+
+ -- APPEND ALL V TO T.
+ T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V & C64005DB.V;
+ T.E := T.E + N;
+
+ CASE C IS
+
+ WHEN '1' =>
+ C64005DC (LEVEL'SUCC(L), IDENT_CHAR('1'), T);
+
+ WHEN '2' =>
+ C64005DB (L, IDENT_CHAR('3'), T);
+
+ WHEN '3' =>
+ C64005DC (LEVEL'SUCC(L), IDENT_CHAR('2'), T);
+ END CASE;
+
+ -- APPEND ALL L AND C TO T IN REVERSE ORDER.
+ T.S (T.E+1 .. T.E+N) := C64005DB.L & C64005DB.C &
+ C64005DA.L & C64005DA.C &
+ C64005D0M.L;
+ T.E := T.E + N;
+
+END C64005DB;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada b/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada
new file mode 100644
index 000000000..45e8a5ec4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada
@@ -0,0 +1,74 @@
+-- C64005DC.ADA
+
+-- 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.
+--*
+-- JRK 7/30/84
+
+SEPARATE (C64005D0M.C64005DA.C64005DB)
+
+PROCEDURE C64005DC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS
+
+ V : STRING (1..2);
+
+ M : CONSTANT NATURAL := LEVEL'POS (L) -
+ LEVEL'POS (LEVEL'FIRST) + 1;
+ N : CONSTANT NATURAL := 2 * M + 1;
+
+BEGIN
+
+ V (1) := IDENT_CHAR (ASCII.LC_C);
+ V (2) := C;
+
+ -- APPEND ALL V TO T.
+ T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V & C64005DB.V &
+ C64005DC.V;
+ T.E := T.E + N;
+
+ CASE C IS
+
+ WHEN '1' =>
+ C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('2'), T);
+
+ WHEN '2' =>
+ C64005DC (L, IDENT_CHAR('3'), T);
+
+ WHEN '3' =>
+ -- APPEND MID-POINT SYMBOL TO T.
+ T.S (T.E+1) := IDENT_CHAR ('=');
+ T.E := T.E + 1;
+
+ -- G := CATENATE ALL V, L, C;
+ G := C64005D0M.V & C64005D0M.L &
+ C64005DA.V & C64005DA.L & C64005DA.C &
+ C64005DB.V & C64005DB.L & C64005DB.C &
+ C64005DC.V & C64005DC.L & C64005DC.C;
+ END CASE;
+
+ -- APPEND ALL L AND C TO T IN REVERSE ORDER.
+ T.S (T.E+1 .. T.E+N) := C64005DC.L & C64005DC.C &
+ C64005DB.L & C64005DB.C &
+ C64005DA.L & C64005DA.C &
+ C64005D0M.L;
+ T.E := T.E + N;
+
+END C64005DC;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c641001.a b/gcc/testsuite/ada/acats/tests/c6/c641001.a
new file mode 100644
index 000000000..84ee58a7e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c641001.a
@@ -0,0 +1,281 @@
+-- C641001.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 actual parameters passed by reference are view converted
+-- to the nominal subtype of the formal parameter.
+--
+-- TEST DESCRIPTION:
+-- Check that sliding is allowed for formal parameters, especially
+-- check cases that would have caused errors in Ada'83.
+-- Check that length check for a formal parameter (esp out mode)
+-- is performed before the call, not after.
+--
+-- notes: 6.2; by reference ::= tagged, task, protected,
+-- limited (nonprivate), or composite containing such
+-- 4.6; view conversion
+--
+--
+-- CHANGE HISTORY:
+-- 26 JAN 96 SAIC Initial version
+-- 04 NOV 96 SAIC Commentary revision for release 2.1
+-- 27 FEB 97 PWB.CTA Corrected reference to the wrong string
+--!
+
+----------------------------------------------------------------- C641001_0
+
+package C641001_0 is
+
+ subtype String_10 is String(1..10);
+
+ procedure Check_String_10( S : out String_10; Start, Stop: Natural );
+
+ procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String;
+ Index: Natural );
+
+ type Tagged_Data(Bound: Natural) is tagged record
+ Data_Item : String(1..Bound) := (others => '*');
+ end record;
+
+ type Tag_List is array(Natural range <>) of Tagged_Data(5);
+
+ subtype Tag_List_10 is Tag_List(1..10);
+
+ procedure Check_Tag_Slice( TL : in out Tag_List_10 );
+
+ procedure Check_Out_Tagged_Data( Formal : out Tagged_Data );
+
+end C641001_0;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with Report;
+with TCTouch;
+package body C641001_0 is
+
+ String_Data : constant String := "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+ procedure Check_String_10( S : out String_10; Start, Stop: Natural ) is
+ begin
+ if S'Length /= 10 then
+ Report.Failed("Length check not performed prior to execution");
+ end if;
+ S := String_Data(Start..Stop);
+ exception
+ when others => Report.Failed("Exception encountered in Check_String_10");
+ end Check_String_10;
+
+ procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String;
+ Index: Natural ) is
+ begin
+ -- essentially "do-nothing" for optimization foilage...
+ if Slice_Passed(Index) in Character then
+ -- Intent is ^^^^^ should raise Constraint_Error
+ Report.Failed("Illegal Slice provided legal character");
+ else
+ Report.Failed("Illegal Slice provided illegal character");
+ end if;
+ exception
+ when Constraint_Error =>
+ null; -- expected case
+ when others =>
+ Report.Failed("Wrong exception in Check_Illegal_Slice_Reference");
+ end Check_Illegal_Slice_Reference;
+
+ procedure Check_Tag_Slice( TL : in out Tag_List_10 ) is
+ -- if the view conversion is not performed, one of the following checks
+ -- will fail (given data passed as 0..9 and then 2..11)
+ begin
+ Check_Under_Index: -- index 0 should raise C_E
+ begin
+ TCTouch.Assert( TL(Report.Ident_Int(0)).Data_Item = "*****",
+ "Index 0 (illegal); bad data" );
+ Report.Failed("Index 0 did not raise Constraint_Error");
+ exception
+ when Constraint_Error =>
+ null; -- expected case
+ when others =>
+ Report.Failed("Wrong exception in Check_Under_Index ");
+ end Check_Under_Index;
+
+ Check_Over_Index: -- index 11 should raise C_E
+ begin
+ TCTouch.Assert( TL(Report.Ident_Int(11)).Data_Item = "*****",
+ "Index 11 (illegal); bad data" );
+ Report.Failed("Index 11 did not raise Constraint_Error");
+ exception
+ when Constraint_Error =>
+ null; -- expected case
+ when others =>
+ Report.Failed("Wrong exception in Check_Over_Index ");
+ end Check_Over_Index;
+
+ end Check_Tag_Slice;
+
+ procedure Check_Out_Tagged_Data( Formal : out Tagged_Data ) is
+ begin
+ TCTouch.Assert( Formal.Data_Item = "*****", "out formal data bad" );
+ Formal.Data_Item(1) := '!';
+ end Check_Out_Tagged_Data;
+
+end C641001_0;
+
+------------------------------------------------------------------- C641001
+
+with Report;
+with TCTouch;
+with C641001_0;
+procedure C641001 is
+
+ function II( I: Integer ) return Integer renames Report.Ident_Int;
+ -- ^^ name chosen to allow embedding in calls
+
+ A_String_10 : C641001_0.String_10;
+ Slicable : String(1..40);
+ Tag_Slices : C641001_0.Tag_List(0..11);
+
+ Global_Data : String(1..26) := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+ procedure Check_Out_Sliding( Lo1, Hi1, Lo2, Hi2 : Natural ) is
+
+ subtype One_Constrained_String is String(Lo1..Hi1); -- 1 5
+ subtype Two_Constrained_String is String(Lo2..Hi2); -- 6 10
+
+ procedure Out_Param( Param : out One_Constrained_String ) is
+ begin
+ Param := Report.Ident_Str( Global_Data(Lo2..Hi2) );
+ end Out_Param;
+ Object : Two_Constrained_String;
+ begin
+ Out_Param( Object );
+ if Object /= Report.Ident_Str( Global_Data(Lo2..Hi2) ) then
+ Report.Failed("Bad result in Check_Out_Sliding");
+ end if;
+ exception
+ when others => Report.Failed("Exception in Check_Out_Sliding");
+ end Check_Out_Sliding;
+
+ procedure Check_Dynamic_Subtype_Cases(F_Lower,F_Upper: Natural;
+ A_Lower,A_Upper: Natural) is
+
+ subtype Dyn_String is String(F_Lower..F_Upper);
+
+ procedure Check_Dyn_Subtype_Formal_Out( Param : out Dyn_String ) is
+ begin
+ Param := Global_Data(11..20);
+ end Check_Dyn_Subtype_Formal_Out;
+
+ procedure Check_Dyn_Subtype_Formal_In( Param : in Dyn_String ) is
+ begin
+ if Param /= Global_Data(11..20) then
+ Report.Failed("Dynamic case, data mismatch");
+ end if;
+ end Check_Dyn_Subtype_Formal_In;
+
+ Stuff: String(A_Lower..A_Upper);
+
+ begin
+ Check_Dyn_Subtype_Formal_Out( Stuff );
+ Check_Dyn_Subtype_Formal_In( Stuff );
+ end Check_Dynamic_Subtype_Cases;
+
+begin -- Main test procedure.
+
+ Report.Test ("C641001", "Check that actual parameters passed by " &
+ "reference are view converted to the nominal " &
+ "subtype of the formal parameter" );
+
+ -- non error cases for string slices
+
+ C641001_0.Check_String_10( A_String_10, 1, 10 );
+ TCTouch.Assert( A_String_10 = "1234567890", "Nominal case" );
+
+ C641001_0.Check_String_10( A_String_10, 11, 20 );
+ TCTouch.Assert( A_String_10 = "ABCDEFGHIJ", "Sliding to subtype" );
+
+ C641001_0.Check_String_10( Slicable(1..10), 1, 10 );
+ TCTouch.Assert( Slicable(1..10) = "1234567890", "Slice, no sliding" );
+
+ C641001_0.Check_String_10( Slicable(1..10), 21, 30 );
+ TCTouch.Assert( Slicable(1..10) = "KLMNOPQRST", "Sliding to slice" );
+
+ C641001_0.Check_String_10( Slicable(11..20), 11, 20 );
+ TCTouch.Assert( Slicable(11..20) = "ABCDEFGHIJ", "Sliding to same" );
+
+ C641001_0.Check_String_10( Slicable(21..30), 11, 20 );
+ TCTouch.Assert( Slicable(21..30) = "ABCDEFGHIJ", "Sliding up" );
+
+ -- error cases for string slices
+
+ C641001_0.Check_Illegal_Slice_Reference( Slicable(21..30), 20 );
+
+ C641001_0.Check_Illegal_Slice_Reference( Slicable(1..15), Slicable'Last );
+
+ -- checks for view converting actuals to formals
+
+ -- catch low bound fault
+ C641001_0.Check_Tag_Slice( Tag_Slices(II(0)..9) ); -- II ::= Ident_Int
+ TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" );
+ TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" );
+
+ -- catch high bound fault
+ C641001_0.Check_Tag_Slice( Tag_Slices(2..II(11)) );
+ TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" );
+ TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" );
+
+ Check_Formal_Association_Check:
+ begin
+ C641001_0.Check_String_10( Slicable, 1, 10 ); -- catch length fault
+ Report.Failed("Exception not raised at Check_Formal_Association_Check");
+ exception
+ when Constraint_Error =>
+ null; -- expected case
+ when others =>
+ Report.Failed("Wrong exception at Check_Formal_Association_Check");
+ end Check_Formal_Association_Check;
+
+ -- check for constrained actual, unconstrained formal
+ C641001_0.Check_Out_Tagged_Data( Tag_Slices(5) );
+ TCTouch.Assert( Tag_Slices(5).Data_Item = "!****",
+ "formal out returned bad result" );
+
+ -- additional checks for out mode formal parameters, dynamic subtypes
+
+ Check_Out_Sliding( II(1),II(5), II(6),II(10) );
+
+ Check_Out_Sliding( 21,25, 6,10 );
+
+ Check_Dynamic_Subtype_Cases(F_Lower => II(1), F_Upper => II(10),
+ A_Lower => II(1), A_Upper => II(10));
+
+ Check_Dynamic_Subtype_Cases(F_Lower => II(21), F_Upper => II(30),
+ A_Lower => II( 1), A_Upper => II(10));
+
+ Check_Dynamic_Subtype_Cases(F_Lower => II( 1), F_Upper => II(10),
+ A_Lower => II(21), A_Upper => II(30));
+
+ Report.Result;
+
+end C641001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103b.ada b/gcc/testsuite/ada/acats/tests/c6/c64103b.ada
new file mode 100644
index 000000000..3af6c6191
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64103b.ada
@@ -0,0 +1,379 @@
+-- C64103B.ADA
+
+-- 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 IN-OUT PARAMETERS OF A SCALAR TYPE,
+-- CONSTRAINT_ERROR IS RAISED:
+-- BEFORE A SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL
+-- PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL PARAMETER'S
+-- SUBTYPE;
+-- AFTER A SUBPROGRAM CALL WHEN THE CONVERTED FORMAL PARAMETER
+-- IS OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S SUBTYPE.
+
+-- HISTORY:
+-- CPP 07/18/84 CREATED ORIGINAL TEST.
+-- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
+-- REFERENCED THE ACTUAL PARAMETERS IN THE SECOND
+-- SUBTEST.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64103B IS
+BEGIN
+ TEST ("C64103B", "FOR IN-OUT PARAMETERS OF A SCALAR TYPE, " &
+ "CONSTRAINT_ERROR IS RAISED: BEFORE A " &
+ "SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL " &
+ "PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL " &
+ "PARAMETER'S SUBTYPE; AFTER A SUBPROGRAM " &
+ "CALL WHEN THE CONVERTED FORMAL PARAMETER IS " &
+ "OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S " &
+ "SUBTYPE");
+
+
+ DECLARE
+ A0 : INTEGER := -9;
+ A1 : INTEGER := IDENT_INT(-1);
+ TYPE SUBINT IS RANGE -8 .. -2;
+
+ TYPE FLOAT_TYPE IS DIGITS 3 RANGE 0.0 .. 3.0;
+ A2 : FLOAT_TYPE := 0.12;
+ A3 : FLOAT_TYPE := 2.5;
+ TYPE NEW_FLOAT IS DIGITS 3 RANGE 1.0 .. 2.0;
+
+ TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0;
+ A4 : FIXED_TYPE := -2.0;
+ A5 : FIXED_TYPE := 4.0;
+ TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0;
+
+ A6 : CHARACTER := 'A';
+ SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q';
+
+ TYPE COLOR IS (RED, BURGUNDY, LILAC, MAROON, MAGENTA);
+ SUBTYPE A_COLOR IS COLOR RANGE RED..LILAC;
+ SUBTYPE B_COLOR IS COLOR RANGE MAROON..MAGENTA;
+ A7 : B_COLOR := MAROON;
+
+ PROCEDURE P1 (X : IN OUT SUBINT;
+ S : STRING) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (A" &
+ S & ")");
+ END P1;
+
+ PROCEDURE P2 (X : IN OUT NEW_FLOAT;
+ S : STRING) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A" &
+ S & ")");
+ END P2;
+
+ PROCEDURE P3 (X : IN OUT NEW_FIXED;
+ S : STRING) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P3 (A" &
+ S & ")");
+ END P3;
+
+ PROCEDURE P4 (X : IN OUT SUPER_CHAR;
+ S : STRING) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P4 (A" &
+ S & ")");
+ END P4;
+
+ PROCEDURE P5 (X : IN OUT A_COLOR;
+ S : STRING) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P5 (A" &
+ S & ")");
+ END P5;
+ BEGIN
+ BEGIN
+ P1 (SUBINT (A0), "1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (A1)");
+ END;
+
+ BEGIN
+ P1 (SUBINT (A1), "2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (A2)");
+ END;
+
+ BEGIN
+ P2 (NEW_FLOAT (A2), "1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P2 (A1)");
+ END;
+
+ BEGIN
+ P2 (NEW_FLOAT (A3), "2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P2 (A2)");
+ END;
+
+ BEGIN
+ P3 (NEW_FIXED (A4), "1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P3 (A1)");
+ END;
+
+ BEGIN
+ P3 (NEW_FIXED (A5), "2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P3 (A2)");
+ END;
+
+ BEGIN
+ P4 (SUPER_CHAR (A6),"1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P4 (A1)");
+ END;
+
+ BEGIN
+ P5 (A_COLOR (A7), "1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P5 (A1)");
+ END;
+ END;
+
+
+ DECLARE
+ CALLED : BOOLEAN;
+ TYPE SUBINT IS RANGE -8 .. -2;
+ A0 : SUBINT := -3;
+ A1 : INTEGER := -9;
+ A2 : INTEGER := -1;
+
+ TYPE FLOAT IS DIGITS 3 RANGE -1.0 .. 2.0;
+ TYPE A_FLOAT IS DIGITS 3 RANGE 0.0 .. 1.0;
+ A3 : A_FLOAT := 1.0;
+ A4 : FLOAT := -0.5;
+ A5 : FLOAT := 1.5;
+
+ TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0;
+ A6 : NEW_FIXED := 0.0;
+ TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0;
+ A7 : FIXED_TYPE := -2.0;
+ A8 : FIXED_TYPE := 4.0;
+
+ SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q';
+ A9 : SUPER_CHAR := 'C';
+ A10 : CHARACTER := 'A';
+ A11 : CHARACTER := 'R';
+
+ PROCEDURE P1 (X : IN OUT INTEGER; Y : INTEGER) IS
+ BEGIN
+ CALLED := TRUE;
+ X := IDENT_INT (Y);
+ END P1;
+
+ PROCEDURE P2 (X : IN OUT FLOAT; Y : FLOAT) IS
+ BEGIN
+ CALLED := TRUE;
+ X := Y;
+ END P2;
+
+ PROCEDURE P3 ( X : IN OUT FIXED_TYPE; Y : FIXED_TYPE) IS
+ BEGIN
+ CALLED := TRUE;
+ X := Y;
+ END P3;
+
+ PROCEDURE P4 (X : IN OUT CHARACTER; Y : CHARACTER) IS
+ BEGIN
+ CALLED := TRUE;
+ X := IDENT_CHAR(Y);
+ END P4;
+ BEGIN
+ BEGIN
+ CALLED := FALSE;
+ P1 (INTEGER(A0), A1);
+ IF A0 = -3 THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P1 (B1)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
+ END;
+
+ BEGIN
+ CALLED := FALSE;
+ P1 (INTEGER(A0), A2);
+ IF A0 = -3 THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B3)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B4)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P1 (B2)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
+ END;
+
+ BEGIN
+ CALLED := FALSE;
+ P2 (FLOAT (A3), A4);
+ IF A3 = 1.0 THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P2 (B1)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P2 (B1)");
+ END;
+
+ BEGIN
+ CALLED := FALSE;
+ P2 (FLOAT (A3), A5);
+ IF A3 = 1.0 THEN
+ FAILED ("EXCEPTION NOT RAISED -P2 (B3)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED -P2 (B4)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P2 (B2)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P2 (B2)");
+ END;
+
+ BEGIN
+ CALLED := FALSE;
+ P3 (FIXED_TYPE (A6), A7);
+ IF A6 = 0.0 THEN
+ FAILED ("EXCEPTION NOT RAISED -P3 (B1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED -P3 (B2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P3 (B1)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P3 (B1)");
+ END;
+
+ BEGIN
+ CALLED := FALSE;
+ P3 (FIXED_TYPE (A6), A8);
+ IF A6 = 0.0 THEN
+ FAILED ("EXCEPTION NOT RAISED -P3 (B3)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED -P3 (B4)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P3 (B2)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P3 (B2)");
+ END;
+
+ BEGIN
+ CALLED := FALSE;
+ P4 (CHARACTER (A9), A10);
+ IF A9 = 'C' THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P4 (B1)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P4 (B1)");
+ END;
+
+ BEGIN
+ CALLED := FALSE;
+ P4 (CHARACTER (A9), A11);
+ IF A9 = 'C' THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B3)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B4)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P4 (B2)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P4 (B2)");
+ END;
+ END;
+
+ RESULT;
+END C64103B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103c.ada b/gcc/testsuite/ada/acats/tests/c6/c64103c.ada
new file mode 100644
index 000000000..c08ef8693
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64103c.ada
@@ -0,0 +1,230 @@
+-- C64103C.ADA
+
+-- 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.
+--*
+-- CHECK THAT THE APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
+-- ON IN OUT ARRAY PARAMETERS. IN PARTICULAR:
+-- (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
+-- COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
+-- CONSTRAINTS.
+-- (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
+-- AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
+-- OUTSIDE OF A FORMAL INDEX SUBTYPE FOR A NON-NULL DIMENSION (SEE
+-- AI-00313 FOR MULTIDIMENSIONAL CASE)
+-- (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
+-- CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
+-- DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
+-- (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
+-- UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
+-- OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.
+
+-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
+-- *** remove incompatibilities associated with the transition -- 9X
+-- *** to Ada 9X. -- 9X
+-- *** -- 9X
+
+-- CPP 07/19/84
+-- JBG 06/05/85
+-- EG 10/29/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
+-- AI-00387.
+-- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY
+-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
+
+WITH SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C64103C IS
+
+ BEGIN
+ TEST ("C64103C", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
+ "TYPE CONVERSIONS OF IN OUT ARRAY PARAMETERS");
+
+ -----------------------------------------------
+
+ DECLARE -- (A)
+ BEGIN -- (A)
+
+ DECLARE
+ TYPE SUBINT IS RANGE 0..8;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
+ A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);
+
+ PROCEDURE P2 (X : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ NULL;
+ END P2;
+ BEGIN
+ P2 (ARRAY_TYPE (A0)); -- OK.
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED -P2 (A)");
+ END;
+
+ END; -- (A)
+
+ -----------------------------------------------
+
+ DECLARE -- (B1) NON-NULL ACTUAL PARAMETER
+
+ TYPE SUBINT IS RANGE 0..8;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
+ TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
+ A1 : AR1 (-1..7) := (-1..7 => TRUE);
+ A2 : AR1 (1..9) := (1..9 => TRUE);
+
+ PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
+ END P1;
+
+ BEGIN -- (B1)
+
+ BEGIN
+ COMMENT ("CALL TO P1 (B1) ON A1");
+ P1 (ARRAY_TYPE (A1));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
+ END;
+
+ BEGIN
+ COMMENT ("CALL TO P1 (B1) ON A2");
+ P1 (ARRAY_TYPE (A2));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
+ END;
+
+ END; -- (B1)
+
+ DECLARE -- (B2) NULL ACTUAL PARAMETER; MULTIDIMENSIONAL
+
+ TYPE SUBINT IS RANGE 0..8;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>,
+ SUBINT RANGE <>) OF BOOLEAN;
+ TYPE AR1 IS ARRAY (INTEGER RANGE <>,
+ INTEGER RANGE <>)OF BOOLEAN;
+ A1 : AR1 (IDENT_INT(-1)..7, 5..4) :=
+ (OTHERS => (OTHERS => TRUE));
+ A2 : AR1 (5..4, 1..IDENT_INT(9)) :=
+ (OTHERS => (OTHERS => TRUE));
+ PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
+ END P1;
+
+ BEGIN -- (B2)
+
+ BEGIN
+ COMMENT ("CALL TO P1 (B2) ON A1");
+ P1 (ARRAY_TYPE (A1));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
+ END;
+
+ BEGIN
+ COMMENT ("CALL TO P1 (B2) ON A2");
+ P1 (ARRAY_TYPE (A2));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
+ END;
+
+ END; -- (B2)
+
+ -----------------------------------------------
+
+ BEGIN -- (C)
+
+ DECLARE
+ TYPE INDEX1 IS RANGE 1..3;
+ TYPE INDEX2 IS RANGE 1..4;
+ TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
+ A0 : AR_TYPE := (1..3 => (1..4 => FALSE));
+
+ TYPE I1 IS RANGE 1..4;
+ TYPE I2 IS RANGE 1..3;
+ TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;
+
+ PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
+ END P1;
+ BEGIN
+ P1 (ARRAY_TYPE (A0));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
+ END;
+
+ END; -- (C)
+
+ -----------------------------------------------
+
+ DECLARE -- (D)
+ BEGIN -- (D)
+
+ DECLARE
+ TYPE SM_INT IS RANGE 0..2;
+ TYPE LG IS RANGE 0 .. SYSTEM.MAX_INT;
+ SUBTYPE LG_INT IS LG RANGE SYSTEM.MAX_INT - 3 ..
+ SYSTEM.MAX_INT;
+ TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
+ TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
+ A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
+ (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);
+
+ PROCEDURE P1 (X : IN OUT AR_SMALL) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
+ END P1;
+ BEGIN
+ IF LG (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
+ P1 (AR_SMALL (A0));
+ ELSE
+ COMMENT ("NOT APPLICABLE -P1 (D)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
+ END;
+
+ END; -- (D)
+
+ -----------------------------------------------
+
+ RESULT;
+
+END C64103C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103d.ada b/gcc/testsuite/ada/acats/tests/c6/c64103d.ada
new file mode 100644
index 000000000..180dab077
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64103d.ada
@@ -0,0 +1,187 @@
+-- C64103D.ADA
+
+-- 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.
+--*
+-- CHECK THAT THE APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
+-- ON OUT ARRAY PARAMETERS. IN PARTICULAR:
+-- (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
+-- COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
+-- CONSTRAINTS.
+-- (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
+-- AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
+-- OUTSIDE OF A FORMAL INDEX SUBTYPE.
+-- (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
+-- CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
+-- DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
+-- (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
+-- UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
+-- OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.
+
+-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X
+-- *** remove incompatibilities associated with the transition -- 9X
+-- *** to Ada 9X. -- 9X
+-- *** -- 9X
+
+-- CPP 07/19/84
+-- EG 10/29/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
+-- AI-00387.
+-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY
+-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
+
+WITH SYSTEM;
+WITH REPORT; USE REPORT;
+PROCEDURE C64103D IS
+
+ BEGIN
+ TEST ("C64103D", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
+ "TYPE CONVERSIONS OF OUT ARRAY PARAMETERS");
+
+ -----------------------------------------------
+
+ DECLARE -- (A)
+ BEGIN -- (A)
+
+ DECLARE
+ TYPE SUBINT IS RANGE 0..8;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
+ A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);
+
+ PROCEDURE P2 (X : OUT ARRAY_TYPE) IS
+ BEGIN
+ NULL;
+ END P2;
+ BEGIN
+ P2 (ARRAY_TYPE (A0)); -- OK.
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED -P2 (A)");
+ END;
+
+ END; -- (A)
+
+ -----------------------------------------------
+
+ DECLARE -- (B)
+
+ TYPE SUBINT IS RANGE 0..8;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
+ TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
+ A1 : AR1 (-1..7) := (-1..7 => TRUE);
+ A2 : AR1 (1..9) := (1..9 => TRUE);
+
+ PROCEDURE P1 (X : OUT ARRAY_TYPE) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
+ END P1;
+
+ BEGIN -- (B)
+
+ BEGIN
+ COMMENT ("CALL TO P1 (B) ON A1");
+ P1 (ARRAY_TYPE (A1));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
+ END;
+
+ BEGIN
+ COMMENT ("CALL TO P1 (B) ON A2");
+ P1 (ARRAY_TYPE (A2));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
+ END;
+
+ END; -- (B)
+
+ -----------------------------------------------
+
+ DECLARE -- (C)
+ BEGIN -- (C)
+
+ DECLARE
+ TYPE INDEX1 IS RANGE 1..3;
+ TYPE INDEX2 IS RANGE 1..4;
+ TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
+ A0 : AR_TYPE := (1..3 => (1..4 => FALSE));
+
+ TYPE I1 IS RANGE 1..4;
+ TYPE I2 IS RANGE 1..3;
+ TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;
+
+ PROCEDURE P1 (X : OUT ARRAY_TYPE) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
+ END P1;
+ BEGIN
+ P1 (ARRAY_TYPE (A0));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
+ END;
+
+ END; -- (C)
+
+ -----------------------------------------------
+
+ DECLARE -- (D)
+ BEGIN -- (D)
+
+ DECLARE
+ TYPE SM_INT IS RANGE 0..2;
+ TYPE LG_INT IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT;
+ TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
+ TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
+ A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
+ (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);
+
+ PROCEDURE P1 (X : OUT AR_SMALL) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
+ END P1;
+ BEGIN
+ IF LG_INT (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
+ P1 (AR_SMALL (A0));
+ ELSE
+ COMMENT ("NOT APPLICABLE -P1 (D)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
+ END;
+
+ END; -- (D)
+
+ -----------------------------------------------
+
+ RESULT;
+
+END C64103D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103e.ada b/gcc/testsuite/ada/acats/tests/c6/c64103e.ada
new file mode 100644
index 000000000..7f022dfdf
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64103e.ada
@@ -0,0 +1,219 @@
+-- C64103E.ADA
+
+-- 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 IN-OUT PARAMETERS OF AN ACCESS TYPE,
+-- CONSTRAINT_ERROR IS RAISED:
+-- BEFORE A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
+-- OF THE ACTUAL DESIGNATED PARAMETER ARE DIFFERENT FROM
+-- THOSE OF THE FORMAL DESIGNATED PARAMETER;
+-- AFTER A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
+-- OF THE FORMAL DESIGNATED PARAMETER ARE DIFFERENT FROM
+-- THOSE OF THE ACTUAL DESIGNATED PARAMETER.
+
+-- HISTORY:
+-- CPP 07/23/84 CREATED ORIGINAL TEST.
+-- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
+-- REFERENCED THE ACTUAL PARAMETERS IN THE SECOND
+-- SUBTEST.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64103E IS
+BEGIN
+ TEST ("C64103E", "FOR IN-OUT PARAMETERS OF AN ACCESS TYPE, " &
+ "CONSTRAINT_ERROR IS RAISED: BEFORE A " &
+ "SUBPROGRAM CALL WHEN THE BOUNDS OR " &
+ "DISCRIMINANTS OF THE ACTUAL DESIGNATED " &
+ "PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
+ "FORMAL DESIGNATED PARAMETER; AFTER A " &
+ "SUBPROGRAM CALL WHEN THE BOUNDS OR " &
+ "DISCRIMINANTS OF THE FORMAL DESIGNATED " &
+ "PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
+ "ACTUAL DESIGNATED PARAMETER");
+
+
+ BEGIN
+ DECLARE
+ TYPE AST IS ACCESS STRING;
+ SUBTYPE AST_3 IS AST(1..3);
+ SUBTYPE AST_5 IS AST(3..5);
+ X_3 : AST_3 := NEW STRING(1..IDENT_INT(3));
+
+ PROCEDURE P1 (X : IN OUT AST_5) IS
+ BEGIN
+ FAILED("EXCEPTION NOT RAISED BEFORE CALL -P1 (A)");
+ END P1;
+ BEGIN
+ P1 (AST_5 (X_3));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (A)");
+ END;
+
+ DECLARE
+ TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
+ TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
+ SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
+ TYPE A2_ARRAY IS NEW A_ARRAY (2..4);
+ A0 : A1_ARRAY := NEW ARRAY_TYPE (1..3);
+
+ PROCEDURE P2 (X : IN OUT A2_ARRAY) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A)");
+ END P2;
+ BEGIN
+ P2 (A2_ARRAY (A0));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P2 (A)");
+ END;
+
+ DECLARE
+ TYPE SUBINT IS RANGE 0..8;
+ TYPE REC1 (DISC : SUBINT := 8) IS
+ RECORD
+ FIELD : SUBINT := DISC;
+ END RECORD;
+ TYPE A1_REC IS ACCESS REC1;
+ TYPE A2_REC IS NEW A1_REC(3);
+ A0 : A1_REC := NEW REC1(4);
+
+ PROCEDURE P3 (X : IN OUT A2_REC) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL " &
+ "-P3 (A)");
+ END P3;
+
+ BEGIN
+ P3 (A2_REC (A0));
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P3 (A)");
+ END;
+
+ END;
+
+
+ BEGIN
+ DECLARE
+ TYPE AST IS ACCESS STRING;
+ SUBTYPE AST_3 IS AST(IDENT_INT(1)..IDENT_INT(3));
+ X_3 : AST_3 := NEW STRING'(1..IDENT_INT(3) => 'A');
+ CALLED : BOOLEAN := FALSE;
+
+ PROCEDURE P1 (X : IN OUT AST) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW STRING'(3..5 => 'C');
+ END P1;
+ BEGIN
+ P1 (AST (X_3));
+ IF X_3.ALL = STRING'(1 .. 3 => 'A') THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL" &
+ "-P1 (B)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (B)");
+ END;
+
+ DECLARE
+ TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
+ TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
+ SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
+ A0 : A1_ARRAY := NEW ARRAY_TYPE'(1..3 => TRUE);
+ CALLED : BOOLEAN := FALSE;
+
+ PROCEDURE P2 (X : IN OUT A_ARRAY) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW ARRAY_TYPE'(2..4 => FALSE);
+ END P2;
+ BEGIN
+ P2 (A_ARRAY (A0));
+ IF A0.ALL = ARRAY_TYPE'(1 .. 3 => TRUE) THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL" &
+ "-P1 (B)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P2 (B)");
+ END;
+
+ DECLARE
+ TYPE SUBINT IS RANGE 0..8;
+ TYPE REC1 (DISC : SUBINT := 8) IS
+ RECORD
+ FIELD : SUBINT := DISC;
+ END RECORD;
+ TYPE A1_REC IS ACCESS REC1;
+ TYPE A2_REC IS NEW A1_REC;
+ A0 : A1_REC(4) := NEW REC1(4);
+ CALLED : BOOLEAN := FALSE;
+
+ PROCEDURE P3 (X : IN OUT A2_REC) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW REC1;
+ END P3;
+
+ BEGIN
+ P3 (A2_REC (A0));
+ IF A0.ALL = REC1'(4,4) THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (B1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (B2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL" &
+ "-P1 (B)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P3 (B)");
+ END;
+
+ END;
+
+ RESULT;
+END C64103E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64103f.ada b/gcc/testsuite/ada/acats/tests/c6/c64103f.ada
new file mode 100644
index 000000000..ac26400e2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64103f.ada
@@ -0,0 +1,144 @@
+-- C64103F.ADA
+
+-- 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 OUT PARAMETERS OF AN ACCESS TYPE,
+-- CONSTRAINT_ERROR IS RAISED:
+-- AFTER A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS
+-- OF THE FORMAL DESIGNATED PARAMETER ARE DIFFERENT FROM
+-- THOSE OF THE ACTUAL DESIGNATED PARAMETER.
+
+-- HISTORY:
+-- CPP 07/23/84 CREATED ORIGINAL TEST.
+-- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH
+-- REFERENCE THE ACTUAL PARAMETERS.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64103F IS
+BEGIN
+ TEST ("C64103F", "FOR OUT PARAMETERS OF AN ACCESS TYPE, " &
+ "CONSTRAINT_ERROR IS RAISED: AFTER A " &
+ "SUBPROGRAM CALL WHEN THE BOUNDS OR " &
+ "DISCRIMINANTS OF THE FORMAL DESIGNATED " &
+ "PARAMETER ARE DIFFERENT FROM THOSE OF THE " &
+ "ACTUAL DESIGNATED PARAMETER");
+
+
+ BEGIN
+ DECLARE
+ TYPE AST IS ACCESS STRING;
+ SUBTYPE AST_3 IS AST(IDENT_INT(1)..IDENT_INT(3));
+ SUBTYPE AST_5 IS AST(3..5);
+ X_3 : AST_3 := NEW STRING'(1..IDENT_INT(3) => 'A');
+ CALLED : BOOLEAN := FALSE;
+
+ PROCEDURE P1 (X : OUT AST_5) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW STRING'(3..5 => 'C');
+ END P1;
+ BEGIN
+ P1 (AST_5 (X_3));
+ IF X_3.ALL = STRING'(1 .. 3 => 'A') THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (A1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (A2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P1 (A)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P1 (A)");
+ END;
+
+ DECLARE
+ TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
+ TYPE A_ARRAY IS ACCESS ARRAY_TYPE;
+ SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3));
+ TYPE A2_ARRAY IS NEW A_ARRAY (2..4);
+ A0 : A1_ARRAY := NEW ARRAY_TYPE'(1..3 => TRUE);
+ CALLED : BOOLEAN := FALSE;
+
+ PROCEDURE P2 (X : OUT A2_ARRAY) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW ARRAY_TYPE'(2..4 => FALSE);
+ END P2;
+ BEGIN
+ P2 (A2_ARRAY (A0));
+ IF A0.ALL = ARRAY_TYPE'(1 .. 3 => TRUE) THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (A1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (A2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P1 (A)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P2 (A)");
+ END;
+
+ DECLARE
+ TYPE SUBINT IS RANGE 0..8;
+ TYPE REC1 (DISC : SUBINT := 8) IS
+ RECORD
+ FIELD : SUBINT := DISC;
+ END RECORD;
+ TYPE A1_REC IS ACCESS REC1;
+ TYPE A2_REC IS NEW A1_REC (3);
+ A0 : A1_REC(4) := NEW REC1(4);
+ CALLED : BOOLEAN := FALSE;
+
+ PROCEDURE P3 (X : OUT A2_REC) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW REC1(3);
+ END P3;
+
+ BEGIN
+ P3 (A2_REC (A0));
+ IF A0.ALL = REC1'(4,4) THEN
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (A1)");
+ ELSE
+ FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (A2)");
+ END IF;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL " &
+ "-P1 (A)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED -P3 (A)");
+ END;
+ END;
+
+ RESULT;
+END C64103F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104a.ada b/gcc/testsuite/ada/acats/tests/c6/c64104a.ada
new file mode 100644
index 000000000..4a66476ca
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104a.ada
@@ -0,0 +1,215 @@
+-- C64104A.ADA
+
+-- 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 CONSTRAINT_ERROR IS RAISED FOR OUT OF RANGE SCALAR
+-- ARGUMENTS. SUBTESTS ARE:
+-- (A) STATIC IN ARGUMENT.
+-- (B) DYNAMIC IN ARGUMENT.
+-- (C) IN OUT, OUT OF RANGE ON CALL.
+-- (D) OUT, OUT OF RANGE ON RETURN.
+-- (E) IN OUT, OUT OF RANGE ON RETURN.
+
+-- HISTORY:
+-- DAS 01/14/81
+-- CPP 07/03/84
+-- LB 11/20/86 ADDED CODE TO ENSURE IN SUBTESTS WHICH CHECK
+-- RETURNED VALUES, THAT SUBPROGRAMS ARE ACTUALLY
+-- CALLED.
+-- JET 08/04/87 FIXED HEADER FOR STANDARD FORMAT.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64104A IS
+
+ SUBTYPE DIGIT IS INTEGER RANGE 0..9;
+
+ CALLED : BOOLEAN;
+ D : DIGIT;
+ I : INTEGER;
+ M1 : CONSTANT INTEGER := IDENT_INT(-1);
+ COUNT : INTEGER := 0;
+ SUBTYPE SI IS INTEGER RANGE M1 .. 10;
+
+ PROCEDURE P1 (PIN : IN DIGIT; WHO : STRING) IS -- (A), (B)
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - P1 " & WHO);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN P1 FOR " & WHO);
+ END P1;
+
+ PROCEDURE P2 (PINOUT : IN OUT DIGIT; WHO : STRING) IS -- (C)
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - P2 " & WHO);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN P2 FOR " & WHO);
+ END P2;
+
+ PROCEDURE P3 (POUT : OUT SI; WHO : STRING) IS -- (D)
+ BEGIN
+ IF WHO = "10" THEN
+ POUT := IDENT_INT(10); -- (10 IS NOT A DIGIT)
+ ELSE
+ POUT := -1;
+ END IF;
+ CALLED := TRUE;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN P3 FOR " & WHO);
+ END P3;
+
+ PROCEDURE P4 (PINOUT : IN OUT INTEGER; WHO : STRING) IS -- (E)
+ BEGIN
+ IF WHO = "10" THEN
+ PINOUT := 10; -- (10 IS NOT A DIGIT)
+ ELSE
+ PINOUT := IDENT_INT(-1);
+ END IF;
+ CALLED := TRUE;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN P4 FOR" & WHO);
+ END P4;
+
+BEGIN
+
+ TEST ("C64104A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "FOR OUT OF RANGE SCALAR ARGUMENTS");
+
+ BEGIN -- (A)
+ P1 (10, "10");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P1 (10)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR P1 (10)");
+ END; -- (A)
+
+ BEGIN -- (B)
+ P1 (IDENT_INT (-1), "-1");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P1 (" &
+ "IDENT_INT (-1))");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR P1 (" &
+ "IDENT_INT (-1))");
+ END; --(B)
+
+ BEGIN -- (C)
+ I := IDENT_INT (10);
+ P2 (I, "10");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P2 (10)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR P2 (10)");
+ END; -- (C)
+
+ BEGIN -- (C1)
+ I := IDENT_INT (-1);
+ P2 (I, "-1");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P2 (-1)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR P2 (-1)");
+ END; -- (C1)
+
+ BEGIN -- (D)
+ CALLED := FALSE;
+ D := IDENT_INT (1);
+ P3 (D, "10");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
+ " P3 (10)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM P3 WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR P3 (10)");
+ END; -- (D)
+
+ BEGIN -- (D1)
+ CALLED := FALSE;
+ D := IDENT_INT (1);
+ P3 (D, "-1");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
+ " P3 (-1)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM P3 WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR P3 (-1)");
+ END; -- (D1)
+
+ BEGIN -- (E)
+ CALLED := FALSE;
+ D := 9;
+ P4 (D, "10");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
+ " P4 (10)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM P4 WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR P4 (10)");
+ END; -- (E)
+
+ BEGIN -- (E1)
+ CALLED := FALSE;
+ D := 0;
+ P4 (D, "-1");
+ FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" &
+ " P4 (-1)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ COUNT := COUNT + 1;
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM P4 WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED FOR P4 (-1)");
+ END; -- (E1)
+
+ IF (COUNT /= 8) THEN
+ FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED");
+ END IF;
+
+ RESULT;
+
+END C64104A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104b.ada b/gcc/testsuite/ada/acats/tests/c6/c64104b.ada
new file mode 100644
index 000000000..dc23f70eb
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104b.ada
@@ -0,0 +1,136 @@
+-- C64104B.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER APPROPRIATE CIRCUMSTANCES
+-- WITH RESPECT TO PARAMETERS OF RECORD TYPES. SUBTESTS INVOLVE
+-- ACTUAL RECORD PARAMETERS WHOSE CONSTRAINT VALUES ARE NOT EQUAL
+-- TO THE CONSTRAINTS ON THEIR CORRESPONDING FORMAL PARAMETERS:
+-- (A) IN PARAMETER, STATIC AGGREGATE.
+-- (B) IN PARAMETER, DYNAMIC AGGREGATE.
+-- (C) IN PARAMETER, VARIABLE.
+-- (D) IN OUT PARAMETER, EXCEPTION RAISED ON CALL.
+-- (E) OUT PARAMETER, EXCEPTION RAISED ON CALL.
+
+-- DAS 2/11/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64104B IS
+
+ USE REPORT;
+ SUBTYPE INT IS INTEGER RANGE 0..10;
+ TYPE REC (N : INT := 0) IS
+ RECORD
+ A : STRING (1..N);
+ END RECORD;
+ SUBTYPE SREC IS REC(N=>3);
+ PROCEDURE P1 (R : IN SREC) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL TO P1");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
+ END P1;
+
+ PROCEDURE P2 (R : IN OUT SREC) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL TO P2");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
+ END P2;
+
+ PROCEDURE P3 (R : OUT SREC) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL TO P3");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
+ END P3;
+
+BEGIN
+
+ TEST ("C64104B", "CHECK RAISING OF CONSTRAINT_ERROR FOR " &
+ "PARAMETERS OF RECORD TYPES");
+
+ BEGIN -- (A)
+ P1 ((2,"AA"));
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (A)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (A)");
+ END; -- (A)
+
+ BEGIN -- (B)
+ P1 ((IDENT_INT(2), "AA"));
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (B)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (B)");
+ END; -- (B)
+
+ DECLARE -- (C)
+ R : REC := (IDENT_INT(2), "AA");
+ BEGIN -- (C)
+ P1 (R);
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (C)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (C)");
+ END; -- (C)
+
+ DECLARE -- (D)
+ R : REC := (IDENT_INT(2), "AA");
+ BEGIN -- (D)
+ P2 (R);
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (D)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (D)");
+ END; -- (D)
+
+
+ DECLARE -- (E)
+ R : REC;
+ BEGIN -- (E)
+ P3 (R);
+ FAILED ("EXCEPTION NOT RAISED IN SUBTEST (E)");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (E)");
+ END; -- (E)
+
+ RESULT;
+
+END C64104B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104c.ada b/gcc/testsuite/ada/acats/tests/c6/c64104c.ada
new file mode 100644
index 000000000..894182cb9
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104c.ada
@@ -0,0 +1,200 @@
+-- C64104C.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE
+-- APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS, NAMELY
+-- WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS
+-- (BEFORE THE CALL FOR ALL MODES).
+-- SUBTESTS ARE:
+-- (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE.
+-- (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE.
+-- (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE.
+-- (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE.
+-- (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE.
+-- (F) IN OUT MODE, NULL STRING AGGREGATE.
+-- (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE).
+-- IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE.
+
+-- JRK 3/17/81
+-- SPS 10/26/82
+-- CPP 8/6/84
+-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
+
+WITH REPORT;
+PROCEDURE C64104C IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
+ "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+ SUBTYPE ST IS STRING (1..3);
+
+ PROCEDURE P (A : ST) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL - (A)");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)");
+ END P;
+
+ BEGIN -- (A)
+
+ P ("AB");
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (A)");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ SUBTYPE S IS INTEGER RANGE 1..3;
+ TYPE T IS ARRAY (S,S) OF INTEGER;
+
+ PROCEDURE P (A : T) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL - (B)");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)");
+ END P;
+
+ BEGIN -- (B)
+
+ P ((1..3 => (1..IDENT_INT(2) => 0)));
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (B)");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ SUBTYPE S IS INTEGER RANGE 1..5;
+ TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER;
+ SUBTYPE ST IS T (1..3,1..3);
+ V : T (1..IDENT_INT(2), 1..3) :=
+ (1..IDENT_INT(2) => (1..3 => 0));
+
+ PROCEDURE P (A :ST) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL - (C)");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
+ END P;
+
+ BEGIN -- (C)
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (C)");
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ SUBTYPE S IS INTEGER RANGE 1..5;
+ TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF
+ INTEGER;
+ SUBTYPE ST IS T (1..3, 1..3, 1..3);
+ V : T (1..3, 1..2, 1..3) :=
+ (1..3 => (1..2 => (1..3 => 0)));
+
+ PROCEDURE P (A : IN OUT ST) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALLL - (D)");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
+ END P;
+
+ BEGIN -- (D)
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - (D)");
+ END; -- (D)
+
+ --------------------------------------------------
+
+
+ DECLARE -- (G)
+
+ SUBTYPE S IS INTEGER RANGE 1..5;
+ TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER;
+ SUBTYPE ST IS T (2..1, 2..1);
+ V : T (2..1, 2..1) := (2..1 => (2..1 => ' '));
+
+ PROCEDURE P (A : IN OUT ST) IS
+ BEGIN
+ COMMENT ("OK CASE CALLED CORRECTLY");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)");
+ END P;
+
+ BEGIN -- (G)
+
+ P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)");
+ WHEN OTHERS =>
+ FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)");
+ END; -- (G)
+
+ --------------------------------------------------
+
+ --------------------------------------------------
+
+ RESULT;
+END C64104C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104d.ada b/gcc/testsuite/ada/acats/tests/c6/c64104d.ada
new file mode 100644
index 000000000..10dea0ef6
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104d.ada
@@ -0,0 +1,93 @@
+-- C64104D.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (A) BEFORE CALL, IN MODE, STATIC PRIVATE DISCRIMINANT.
+
+-- JRK 3/18/81
+-- NL 10/13/81
+-- ABW 6/11/82
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64104D IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104D", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ PACKAGE PKG IS
+ TYPE E IS (E1, E2, E3);
+ TYPE T (D : E := E1) IS PRIVATE;
+ TYPE AR IS ARRAY (E1 .. E3) OF INTEGER;
+ PRIVATE
+ TYPE T (D : E := E1) IS
+ RECORD
+ I : INTEGER;
+ A : AR;
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE A1 IS A(E3);
+ V : A (E2) := NEW T (E2);
+
+ PROCEDURE P (X : A1) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ ------------------------------------------------
+
+ RESULT;
+
+END C64104D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104e.ada b/gcc/testsuite/ada/acats/tests/c6/c64104e.ada
new file mode 100644
index 000000000..c64634613
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104e.ada
@@ -0,0 +1,82 @@
+-- C64104E.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (B) BEFORE CALL, IN MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
+
+-- JRK 3/18/81
+-- NL 10/13/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64104E IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104E", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ TYPE T IS ARRAY (BOOLEAN RANGE <>, CHARACTER RANGE <>) OF
+ INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE A1 IS A(BOOLEAN, 'A'..'C');
+ V : A := NEW T (BOOLEAN, 'A'..IDENT_CHAR('B'));
+
+ PROCEDURE P (X : A1) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64104E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104f.ada b/gcc/testsuite/ada/acats/tests/c6/c64104f.ada
new file mode 100644
index 000000000..f54e1169d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104f.ada
@@ -0,0 +1,79 @@
+-- C64104F.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (C) BEFORE CALL, IN OUT MODE, STATIC ONE DIMENSIONAL BOUNDS.
+
+-- JRK 3/18/81
+-- NL 10/13/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64104F IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104F", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ TYPE A IS ACCESS STRING;
+ SUBTYPE A1 IS A(1..3);
+ V : A (2..4) := NEW STRING (2..4);
+
+ PROCEDURE P (X : IN OUT A1) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64104F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104g.ada b/gcc/testsuite/ada/acats/tests/c6/c64104g.ada
new file mode 100644
index 000000000..76550651f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104g.ada
@@ -0,0 +1,93 @@
+-- C64104G.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (D) BEFORE CALL, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS.
+
+-- JRK 3/18/81
+-- NL 10/13/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64104G IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104G", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+ SUBTYPE INT IS INTEGER RANGE 0..10;
+ TYPE T (C : CHARACTER := 'A';
+ B : BOOLEAN := FALSE;
+ I : INT := 0
+ ) IS
+ RECORD
+ J : INTEGER;
+ CASE B IS
+ WHEN FALSE =>
+ K : INTEGER;
+ WHEN TRUE =>
+ S : STRING (1 .. I);
+ END CASE;
+ END RECORD;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A ('Z', TRUE, 5);
+ V : A := NEW T ('Z', IDENT_BOOL(FALSE), 5);
+
+ PROCEDURE P (X : IN OUT SA ) IS
+ BEGIN
+ FAILED ("EXCEPTION NOT RAISED ON CALL");
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED BEFORE CALL");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64104G;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104h.ada b/gcc/testsuite/ada/acats/tests/c6/c64104h.ada
new file mode 100644
index 000000000..4d522806f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104h.ada
@@ -0,0 +1,111 @@
+-- C64104H.ADA
+
+-- 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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (E) AFTER RETURN, IN OUT MODE, STATIC LIMITED PRIVATE
+-- DISCRIMINANTS.
+
+-- HISTORY:
+-- JRK 03/18/81 CREATED ORIGINAL TEST.
+-- NL 10/13/81
+-- LB 11/25/86 ADDED CODE TO ENSURE THAT SUBPROGRAMS ARE
+-- ACTUALLY BEING CALLED.
+-- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT.
+
+
+WITH REPORT;
+PROCEDURE C64104H IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104H", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ PACKAGE PKG IS
+ SUBTYPE INT IS INTEGER RANGE 0..10;
+ SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'C';
+ TYPE T (I : INT := 0; C : CHAR := 'A') IS
+ LIMITED PRIVATE;
+ PRIVATE
+ TYPE T (I : INT := 0; C : CHAR := 'A') IS
+ RECORD
+ J : INTEGER;
+ CASE C IS
+ WHEN 'A' =>
+ K : INTEGER;
+ WHEN 'B' =>
+ S : STRING (1..I);
+ WHEN OTHERS =>
+ NULL;
+ END CASE;
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ CALLED : BOOLEAN;
+ TYPE A IS ACCESS T;
+
+ V : A (2,'B') := NEW T (2,'B');
+
+ PROCEDURE P (X : IN OUT A) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW T (2,'A');
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ CALLED := FALSE;
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM P WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64104H;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104i.ada b/gcc/testsuite/ada/acats/tests/c6/c64104i.ada
new file mode 100644
index 000000000..ecd24e00f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104i.ada
@@ -0,0 +1,101 @@
+-- C64104I.ADA
+
+-- 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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (F) AFTER RETURN, IN OUT MODE, DYNAMIC THREE DIMENSIONAL
+-- BOUNDS.
+
+-- HISTORY:
+-- JRK 03/18/81 CREATED ORIGINAL TEST.
+-- NL 10/13/81
+-- LB 11/25/86 ADDED CODE TO ENSURE THAT SUBPROGRAMS ARE
+-- ACTUALLY BEING CALLED.
+-- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT.
+
+
+WITH REPORT;
+PROCEDURE C64104I IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104I", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ CALLED : BOOLEAN;
+
+ TYPE E IS (E1, E2, E3);
+
+ TYPE T IS ARRAY (CHARACTER RANGE <>,
+ E RANGE <>,
+ BOOLEAN RANGE <>
+ ) OF INTEGER;
+
+ TYPE A IS ACCESS T;
+
+ V : A ('A'..'Z', E1..E2, BOOLEAN) :=
+ NEW T ('A'..'Z', E1..E2, BOOLEAN);
+
+ PROCEDURE P (X : IN OUT A) IS
+ BEGIN
+ CALLED := TRUE;
+ IF EQUAL (3,3) THEN
+ X := NEW T ('A'..'Z', E2..E3, BOOLEAN);
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ CALLED := FALSE;
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM P WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64104I;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104j.ada b/gcc/testsuite/ada/acats/tests/c6/c64104j.ada
new file mode 100644
index 000000000..1577fc07b
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104j.ada
@@ -0,0 +1,88 @@
+-- C64104J.ADA
+
+-- 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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (G) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, STATIC ONE
+-- DIMENSIONAL BOUNDS.
+
+-- HISTORY:
+-- JRK 03/18/81 CREATED ORIGINAL TEST.
+-- NL 10/13/81
+-- BCB 11/12/87 CHANGED HEADING TO STANDARD FORMAT. ADDED CODE TO
+-- ENSURE THAT SUBPROGRAMS ARE ACTUALLY CALLED.
+
+WITH REPORT;
+PROCEDURE C64104J IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104J", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ TYPE A IS ACCESS STRING;
+
+ CALLED : BOOLEAN := FALSE;
+
+ V : A (1..3) := NEW STRING (1..3);
+
+ PROCEDURE P (X : OUT A) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW STRING (2..3);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM P WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64104J;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104k.ada b/gcc/testsuite/ada/acats/tests/c6/c64104k.ada
new file mode 100644
index 000000000..8819d3ce0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104k.ada
@@ -0,0 +1,95 @@
+-- C64104K.ADA
+
+-- 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 CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (H) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, DYNAMIC
+-- RECORD DISCRIMINANT.
+
+-- HISTORY:
+-- JRK 03/18/81 CREATED ORIGINAL TEST.
+-- NL 10/13/81
+-- SPS 10/26/82
+-- BCB 11/12/87 CHANGED HEADING TO STANDARD FORMAT. ADDED CODE TO
+-- ENSURE THAT SUBPROGRAMS ARE ACTUALLY CALLED.
+
+WITH REPORT;
+PROCEDURE C64104K IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104K", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+ TYPE ARR IS ARRAY (BOOLEAN RANGE <>) OF INTEGER;
+ TYPE T (B : BOOLEAN := FALSE) IS
+ RECORD
+ I : INTEGER;
+ A : ARR (FALSE..B);
+ END RECORD;
+
+ TYPE A IS ACCESS T;
+
+ CALLED : BOOLEAN := FALSE;
+
+ V : A (IDENT_BOOL(FALSE)) := NEW T (IDENT_BOOL(FALSE));
+
+ PROCEDURE P (X : OUT A) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW T (TRUE);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM P WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64104K;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104l.ada b/gcc/testsuite/ada/acats/tests/c6/c64104l.ada
new file mode 100644
index 000000000..1ecabfbbd
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104l.ada
@@ -0,0 +1,109 @@
+-- C64104L.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (I) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, STATIC
+-- PRIVATE DISCRIMINANTS.
+
+-- JRK 3/18/81
+-- NL 10/13/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64104L IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104L", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ PACKAGE PKG IS
+ TYPE E IS (E1, E2, E3);
+ TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS
+ PRIVATE;
+ PRIVATE
+ TYPE ARR IS ARRAY (E RANGE <>) OF INTEGER;
+ TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS
+ RECORD
+ I : INTEGER;
+ CASE B IS
+ WHEN FALSE =>
+ J : INTEGER;
+ WHEN TRUE =>
+ A : ARR (E1 .. D);
+ END CASE;
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A(E2, TRUE);
+ V : A (E2, FALSE) := NEW T (E2, FALSE);
+
+ ENTERED : BOOLEAN := FALSE;
+
+ PROCEDURE P (X : OUT SA ) IS
+ BEGIN
+ ENTERED := TRUE;
+ X := NEW T (E2, TRUE);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("CONSTRAINT_ERROR RAISED BEFORE " &
+ "CALL");
+ END IF;
+ WHEN OTHERS =>
+ IF NOT ENTERED THEN
+ FAILED ("OTHER EXCEPTION RAISED BEFORE CALL");
+ ELSE FAILED ("WRONG EXCEPTION RAISED AFTER " &
+ "RETURN");
+ END IF;
+ END;
+
+ ------------------------------------------------
+
+ RESULT;
+
+END C64104L;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104m.ada b/gcc/testsuite/ada/acats/tests/c6/c64104m.ada
new file mode 100644
index 000000000..e08932120
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104m.ada
@@ -0,0 +1,95 @@
+-- C64104M.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE
+-- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE
+-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL
+-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT
+-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE
+-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES).
+
+-- (J) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, DYNAMIC TWO
+-- DIMENSIONAL BOUNDS.
+
+-- JRK 3/18/81
+-- NL 10/13/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64104M IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64104M", "CHECK THAT CONSTRAINT_ERROR IS RAISED " &
+ "APPROPRIATELY FOR ACCESS PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE
+
+ TYPE T IS ARRAY (INTEGER RANGE <>,
+ CHARACTER RANGE <>
+ ) OF INTEGER;
+
+ TYPE A IS ACCESS T;
+
+ V : A (1..10, 'A'..'Z') := NEW T (1..10, 'A'..'Z');
+
+ ENTERED : BOOLEAN := FALSE;
+ Y : CONSTANT CHARACTER := IDENT_CHAR('Y');
+ SUBTYPE SA IS A(1..10, 'A'..Y);
+ PROCEDURE P (X : OUT SA ) IS
+ BEGIN
+ ENTERED := TRUE;
+ X := NEW T (1..10, 'A'..IDENT_CHAR('Y'));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE");
+ END P;
+
+ BEGIN
+
+ P (V);
+ FAILED ("EXCEPTION NOT RAISED AFTER RETURN");
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("CONSTRAINT_ERROR RAISED BEFORE " &
+ "CALL");
+ END IF;
+ WHEN OTHERS =>
+ IF NOT ENTERED THEN
+ FAILED ("OTHER EXCEPTION RAISED BEFORE CALL");
+ ELSE FAILED ("WRONG EXCEPTION RAISED AFTER " &
+ "RETURN");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64104M;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104n.ada b/gcc/testsuite/ada/acats/tests/c6/c64104n.ada
new file mode 100644
index 000000000..6ee8ac403
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104n.ada
@@ -0,0 +1,116 @@
+-- C64104N.ADA
+
+-- 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 CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE CALL
+-- FOR THE CASE OF A PRIVATE TYPE IMPLEMENTED AS A SCALAR TYPE
+-- WHERE THE VALUE OF THE FORMAL PARAMETER DOES NOT BELONG TO THE
+-- SUBTYPE OF THE ACTUAL PARAMETER.
+
+-- HISTORY:
+-- DAVID A. TAFFS
+-- CPP 07/23/84
+-- RDH 04/18/90 REVISED TO CHECK THAT SUBPROGRAM IS ACTUALLY
+-- CALLED.
+-- THS 09/21/90 REWORDED COMMENT STATING THAT THE TEST DOES NOT
+-- ACCEPT THE LITERAL INTERPRETATION OF 6.4.1(9).
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64104N IS
+
+BEGIN
+ TEST ("C64104N", "CHECK THAT PRIVATE TYPE (SCALAR) RAISES " &
+ "CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER " &
+ "BOUNDS DIFFER");
+
+ DECLARE
+
+ CALLED : BOOLEAN := FALSE;
+
+ PACKAGE P IS
+ TYPE T IS PRIVATE;
+ DC : CONSTANT T;
+
+ GENERIC PACKAGE PP IS
+ END PP;
+ PRIVATE
+ TYPE T IS NEW INTEGER;
+ DC : CONSTANT T := -1;
+ END P;
+
+ PROCEDURE Q (X : IN OUT P.T) IS
+ BEGIN
+ CALLED := TRUE;
+ X := P.DC;
+ IF P. "=" (X, P.DC) THEN
+ COMMENT("PROCEDURE Q WAS CALLED");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED("EXCEPTION RAISED INSIDE SUBPROGRAM");
+ END Q;
+
+ GENERIC
+ Y : IN OUT P.T;
+ PACKAGE CALL IS
+ END CALL;
+
+ PACKAGE BODY CALL IS
+ BEGIN
+ Q (Y);
+ END CALL;
+
+-- NOTE CALL HAS VARIABLE OF A PRIVATE TYPE AS AN OUT PARAMETER.
+-- THIS TEST DOES NOT ACCEPT THE LITERAL INTERPRETATION OF 6.4.1(9).
+-- REFER TO ADA IMPLEMENTOR'S GUIDE 6.4.1 SEMANTIC RAMIFICATION 19
+-- AND AI-00025 FOR CLARIFICATION AS TO WHY THE LITERAL
+-- INTERPRETATION IS REJECTED.
+
+ PACKAGE BODY P IS
+ Z : T RANGE 0..1 := 0;
+ PACKAGE BODY PP IS
+ PACKAGE CALL_Q IS NEW CALL(Z);
+ END PP;
+ END P;
+
+ BEGIN
+ BEGIN
+ DECLARE
+ PACKAGE CALL_Q_NOW IS NEW P.PP; -- EXCEPTION
+ BEGIN
+ FAILED ("NO EXCEPTION RAISED");
+ END;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED("SUBPROGRAM Q WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED("WRONG EXCEPTION RAISED");
+ END;
+
+ RESULT;
+
+ END;
+END C64104N;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64104o.ada b/gcc/testsuite/ada/acats/tests/c6/c64104o.ada
new file mode 100644
index 000000000..5d390b0b0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64104o.ada
@@ -0,0 +1,112 @@
+-- C64104O.ADA
+
+-- 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 CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE CALL
+-- FOR THE CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE
+-- THE ACTUAL BOUNDS OR DISCRIMINANTS OF THE DESIGNATED OBJECT DIFFER
+-- FROM THOSE OF THE FORMAL.
+
+-- HISTORY
+-- CPP 7/23/84 CREATED ORIGINAL TEST.
+-- DHH 8/31/87 ADDED COMMENT IN PROCEDURE Q SO THAT CODE WILL NOT BE
+-- OPTIMIZED OUT OF EXISTENCE.
+
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64104O IS
+
+BEGIN
+
+ TEST ("C64104O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " &
+ "CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER BOUNDS " &
+ "DIFFER");
+
+ DECLARE
+
+
+ CALLED : BOOLEAN := FALSE;
+
+ PACKAGE P IS
+ TYPE T IS PRIVATE;
+ DC : CONSTANT T;
+ GENERIC PACKAGE PP IS
+ END PP;
+ PRIVATE
+ TYPE T IS ACCESS STRING;
+ DC : CONSTANT T := NEW STRING'("AAA");
+ END P;
+
+ PROCEDURE Q (X : IN OUT P.T) IS
+
+ BEGIN
+
+ CALLED := TRUE;
+ X := P.DC;
+ IF P. "=" (X, P.DC) THEN
+ COMMENT("PROCEDURE Q WAS CALLED");
+ END IF;
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED INSIDE SUBPROGRAM");
+ END Q;
+
+ GENERIC
+ Y : IN OUT P.T;
+ PACKAGE CALL IS
+ END CALL;
+
+ PACKAGE BODY CALL IS
+ BEGIN
+ Q(Y);
+ END CALL;
+
+ PACKAGE BODY P IS
+ Z : T(1..5) := NEW STRING'("CCCCC");
+ PACKAGE BODY PP IS
+ PACKAGE CALL_Q IS NEW CALL(Z);
+ END PP;
+ END P;
+
+ BEGIN
+ BEGIN
+ DECLARE
+ PACKAGE CALL_Q_NOW IS NEW P.PP;
+ BEGIN
+ FAILED ("NO EXCEPTION RAISED");
+ END;
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("SUBPROGRAM Q WAS NOT CALLED");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED");
+ END;
+
+ RESULT;
+ END;
+
+END C64104O;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64105a.ada b/gcc/testsuite/ada/acats/tests/c6/c64105a.ada
new file mode 100644
index 000000000..a1739097c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64105a.ada
@@ -0,0 +1,84 @@
+-- C64105A.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED AT THE TIME OF CALL WHEN
+-- THE VALUE OF AN ACTUAL OUT SCALAR PARAMETER DOES NOT SATISFY THE
+-- RANGE CONSTRAINTS OF THE FORMAL PARAMETER.
+
+-- DAS 1/29/81
+-- CPP 8/6/84
+
+WITH REPORT;
+PROCEDURE C64105A IS
+
+ USE REPORT;
+
+ SUBTYPE SUBINT1 IS INTEGER RANGE -10..10;
+ SUBTYPE SUBINT2 IS INTEGER RANGE -20..20;
+
+ I10 : SUBINT1 := 10;
+ I20 : SUBINT2 := 20;
+
+ PROCEDURE P1 (I : OUT SUBINT1) IS
+ BEGIN
+ I := SUBINT1'FIRST;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
+ END P1;
+
+BEGIN
+
+ TEST ("C64105A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED" &
+ " AT THE TIME OF CALL WHEN THE VALUE OF AN" &
+ " ACTUAL OUT SCALAR PARAMETER DOES NOT" &
+ " SATISFY THE RANGE CONSTRAINTS OF THE FORMAL" &
+ " PARAMETER");
+
+ DECLARE
+ BEGIN
+ P1 (SUBINT1(I20));
+ IF I20 /= IDENT_INT(-10) THEN
+ FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 1");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED ON CALL TO P1 - 1");
+ END;
+
+ DECLARE
+ BEGIN
+ I20 := IDENT_INT(20);
+ P1 (I20);
+ IF I20 /= IDENT_INT(-10) THEN
+ FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 2");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED ON CALL TO P1 - 2");
+ END;
+
+ RESULT;
+
+END C64105A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64105b.ada b/gcc/testsuite/ada/acats/tests/c6/c64105b.ada
new file mode 100644
index 000000000..4eb217a72
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64105b.ada
@@ -0,0 +1,184 @@
+-- C64105B.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
+-- IN THE FOLLOWING CIRCUMSTANCES:
+-- (1) BEFORE THE CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS
+-- PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT
+-- FROM THE FORMAL PARAMETER.
+-- (2)
+-- (3)
+-- SUBTESTS ARE:
+-- (A) CASE 1, IN MODE, STATIC ONE DIMENSIONAL BOUNDS.
+-- (B) CASE 1, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS.
+-- (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
+-- (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
+
+-- JRK 3/20/81
+-- SPS 10/26/82
+-- CPP 8/6/84
+
+WITH REPORT;
+PROCEDURE C64105B IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64105B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "BEFORE THE CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS " &
+ "PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT " &
+ "FROM THE FORMAL PARAMETER" );
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE E IS (E1, E2, E3, E4);
+ TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A(E2..E4);
+ V : A (E1..E2) := NULL;
+
+ PROCEDURE P (X : SA ) IS
+ BEGIN
+ NULL;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)");
+ END P;
+
+ BEGIN -- (A)
+
+ P (V);
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (A)");
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+ TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
+ TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
+ RECORD
+ I : INTEGER;
+ CASE B IS
+ WHEN FALSE =>
+ J : INTEGER;
+ WHEN TRUE =>
+ A : ARR ('A' .. C);
+ END CASE;
+ END RECORD;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A(TRUE, 'C');
+ V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
+
+ PROCEDURE P (X : IN OUT SA ) IS
+ BEGIN
+ NULL;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)");
+ END P;
+
+ BEGIN -- (B)
+
+ P (V);
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (B)");
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ TYPE E IS (E1, E2, E3, E4);
+ TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A(E2..E4);
+ V : A (E1..E2) := NULL;
+
+ PROCEDURE P (X : SA ) IS
+ BEGIN
+ NULL;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
+ END P;
+
+ BEGIN -- (C)
+
+ P (SA(V));
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (C)");
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+ TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
+ TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
+ RECORD
+ I : INTEGER;
+ CASE B IS
+ WHEN FALSE =>
+ J : INTEGER;
+ WHEN TRUE =>
+ A : ARR ('A' .. C);
+ END CASE;
+ END RECORD;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A(TRUE, 'C');
+ V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
+
+ PROCEDURE P (X : IN OUT SA ) IS
+ BEGIN
+ NULL;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
+ END P;
+
+ BEGIN -- (D)
+
+ P (SA(V));
+
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (D)");
+ END; -- (D)
+
+ --------------------------------------------------
+
+ RESULT;
+END C64105B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64105c.ada b/gcc/testsuite/ada/acats/tests/c6/c64105c.ada
new file mode 100644
index 000000000..32fc9b635
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64105c.ada
@@ -0,0 +1,230 @@
+-- C64105C.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
+-- IN THE FOLLOWING CIRCUMSTANCES:
+-- (1)
+-- (2) AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL
+-- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS
+-- DIFFERENT CONSTRAINTS.
+-- (3)
+-- SUBTESTS ARE:
+-- (C) CASE 2, IN OUT MODE, STATIC PRIVATE DISCRIMINANT.
+-- (D) CASE 2, OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
+-- (E) SAME AS (C), WITH TYPE CONVERSION.
+-- (F) SAME AS (D), WITH TYPE CONVERSION.
+
+-- JRK 3/20/81
+-- SPS 10/26/82
+-- CPP 8/8/84
+
+WITH REPORT;
+PROCEDURE C64105C IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64105C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL " &
+ "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " &
+ "DIFFERENT CONSTRAINTS" );
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PACKAGE PKG IS
+ TYPE E IS (E1, E2);
+ TYPE T (D : E := E1) IS PRIVATE;
+ PRIVATE
+ TYPE T (D : E := E1) IS
+ RECORD
+ I : INTEGER;
+ CASE D IS
+ WHEN E1 =>
+ B : BOOLEAN;
+ WHEN E2 =>
+ C : CHARACTER;
+ END CASE;
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A(E2);
+ V : A (E1) := NULL;
+ ENTERED : BOOLEAN := FALSE;
+
+ PROCEDURE P (X : IN OUT SA) IS
+ BEGIN
+ ENTERED := TRUE;
+ X := NULL;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
+ END P;
+
+ BEGIN -- (C)
+
+ P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (C)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (C)");
+ END; -- (C)
+
+ --------------------------------------------------
+
+ DECLARE -- (D)
+
+ TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
+ INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
+ V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
+ IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
+ ENTERED : BOOLEAN := FALSE;
+
+ PROCEDURE P (X : OUT SA) IS
+ BEGIN
+ ENTERED := TRUE;
+ X := NULL;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
+ END P;
+
+ BEGIN -- (D)
+
+ P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (D)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (D)");
+ END; -- (D)
+
+ --------------------------------------------------
+
+ DECLARE -- (E)
+
+ PACKAGE PKG IS
+ TYPE E IS (E1, E2);
+ TYPE T (D : E := E1) IS PRIVATE;
+ PRIVATE
+ TYPE T (D : E := E1) IS
+ RECORD
+ I : INTEGER;
+ CASE D IS
+ WHEN E1 =>
+ B : BOOLEAN;
+ WHEN E2 =>
+ C : CHARACTER;
+ END CASE;
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A(E2);
+ V : A (E1) := NULL;
+ ENTERED : BOOLEAN := FALSE;
+
+ PROCEDURE P (X : IN OUT SA) IS
+ BEGIN
+ ENTERED := TRUE;
+ X := NULL;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
+ END P;
+
+ BEGIN -- (E)
+
+ P (SA(V));
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (E)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (E)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (E)");
+ END; -- (E)
+
+ --------------------------------------------------
+
+ DECLARE -- (F)
+
+ TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
+ INTEGER;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
+ V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
+ IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
+ ENTERED : BOOLEAN := FALSE;
+
+ PROCEDURE P (X : OUT SA) IS
+ BEGIN
+ ENTERED := TRUE;
+ X := NULL;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
+ END P;
+
+ BEGIN -- (D)
+
+ P (SA(V));
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT ENTERED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (F)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (F)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (F)");
+ END; -- (F)
+
+ --------------------------------------------------
+
+ RESULT;
+END C64105C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64105d.ada b/gcc/testsuite/ada/acats/tests/c6/c64105d.ada
new file mode 100644
index 000000000..f70b49a2c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64105d.ada
@@ -0,0 +1,134 @@
+-- C64105D.ADA
+
+-- 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.
+--*
+-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS
+-- IN THE FOLLOWING CIRCUMSTANCES:
+-- (1)
+-- (2)
+-- (3) BEFORE OR AFTER THE CALL, WHEN AN UNCONSTRAINED ACTUAL
+-- OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE
+-- CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL
+-- PARAMETER.
+-- SUBTESTS ARE:
+-- (G) CASE 3, STATIC LIMITED PRIVATE DISCRIMINANT.
+-- (H) CASE 3, DYNAMIC ONE DIMENSIONAL BOUNDS.
+
+-- JRK 3/20/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C64105D IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64105D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
+ "BEFORE AND AFTER THE CALL, WHEN AN UNCONSTRAINED ACTUAL " &
+ "OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE " &
+ "CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL " &
+ "PARAMETER" );
+
+ --------------------------------------------------
+
+ DECLARE -- (G)
+
+ PACKAGE PKG IS
+ SUBTYPE INT IS INTEGER RANGE 0..5;
+ TYPE T (I : INT := 0) IS LIMITED PRIVATE;
+ PRIVATE
+ TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
+ TYPE T (I : INT := 0) IS
+ RECORD
+ J : INTEGER;
+ A : ARR (1..I);
+ END RECORD;
+ END PKG;
+ USE PKG;
+
+ TYPE A IS ACCESS T;
+ SUBTYPE SA IS A(3);
+ V : A := NEW T (2);
+ CALLED : BOOLEAN := FALSE;
+
+ PROCEDURE P (X : OUT SA) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW T (3);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)");
+ END P;
+
+ BEGIN -- (G)
+
+ P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (G)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (G)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (G)");
+ END; -- (G)
+
+ --------------------------------------------------
+
+ DECLARE -- (H)
+
+ TYPE A IS ACCESS STRING;
+ SUBTYPE SA IS A (1..2);
+ V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7));
+ CALLED : BOOLEAN := FALSE;
+
+ PROCEDURE P (X : OUT SA) IS
+ BEGIN
+ CALLED := TRUE;
+ X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE - (H)");
+ END P;
+
+ BEGIN -- (H)
+
+ P (V);
+
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ IF NOT CALLED THEN
+ FAILED ("EXCEPTION RAISED BEFORE CALL - (H)");
+ ELSE
+ FAILED ("EXCEPTION RAISED ON RETURN - (H)");
+ END IF;
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - (H)");
+ END; -- (H)
+
+ --------------------------------------------------
+
+ RESULT;
+END C64105D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64106a.ada b/gcc/testsuite/ada/acats/tests/c6/c64106a.ada
new file mode 100644
index 000000000..a74a91b68
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64106a.ada
@@ -0,0 +1,351 @@
+-- C64106A.ADA
+
+-- 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.
+--*
+-- CHECK THAT UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY
+-- FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS.
+-- SUBTESTS ARE:
+-- (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS.
+-- (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS.
+-- (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS.
+-- (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS.
+
+-- DAS 1/15/81
+-- JBG 5/16/83
+-- CPP 5/22/84
+
+WITH REPORT;
+PROCEDURE C64106A IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C64106A", "CHECK USE OF ACTUAL CONSTRAINTS BY " &
+ "UNCONSTRAINED FORMAL PARAMETERS");
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INT IS INTEGER RANGE 0..100;
+
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+
+ REC1 : RECTYPE := (10,10,"0123456789");
+ REC2 : RECTYPE := (17,7,"C64106A..........");
+ REC3 : RECTYPE := (1,1,"A");
+ REC4 : RECTYPE; -- 80
+
+ PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE);
+
+ PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
+ END PKG;
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB");
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE) IS
+ BEGIN
+ IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
+ FAILED ("RECORD TYPE IN PARAMETER DID " &
+ "NOT USE CONSTRAINT OF ACTUAL");
+ END IF;
+ IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
+ FAILED ("RECORD TYPE OUT PARAMETER DID " &
+ "NOT USE CONSTRAINT OF ACTUAL");
+ END IF;
+ IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
+ FAILED ("RECORD TYPE IN OUT PARAMETER DID " &
+ "NOT USE CONSTRAINT OF ACTUAL");
+ END IF;
+ REC2 := PKG.REC2;
+ END CHK_RECTYPE1;
+
+ PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
+ BEGIN
+ IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
+ FAILED ("RECORD TYPE OUT PARAMETER DID " &
+ "NOT USE CONSTRAINT OF " &
+ "UNINITIALIZED ACTUAL");
+ END IF;
+ REC := (10,10,"9876543210");
+ END CHK_RECTYPE2;
+ END PKG;
+
+ BEGIN -- (A)
+
+ PKG.CHK_RECTYPE1 (PKG.REC1, PKG.REC2, PKG.REC3);
+ PKG.CHK_RECTYPE2 (PKG.REC4);
+
+ END; -- (A)
+
+ ---------------------------------------------
+
+B : DECLARE -- (B)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INT IS INTEGER RANGE 0..100;
+
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE;
+
+
+ PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE);
+
+ PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
+
+ PRIVATE
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC1 : PKG.RECTYPE(10);
+ REC2 : PKG.RECTYPE(17);
+ REC3 : PKG.RECTYPE(1);
+ REC4 : PKG.RECTYPE(10);
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE) IS
+ BEGIN
+ IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
+ FAILED ("PRIVATE TYPE IN PARAMETER DID " &
+ "NOT USE CONSTRAINT OF ACTUAL");
+ END IF;
+ IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
+ FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
+ "NOT USE CONSTRAINT OF ACTUAL");
+ END IF;
+ IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
+ FAILED ("PRIVATE TYPE IN OUT PARAMETER DID " &
+ "NOT USE CONSTRAINT OF ACTUAL");
+ END IF;
+ REC2 := B.REC2;
+ END CHK_RECTYPE1;
+
+ PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
+ BEGIN
+ IF (REC.CONSTRAINT /= IDENT_INT(10)) THEN
+ FAILED ("PRIVATE TYPE OUT PARAMETER DID " &
+ "NOT USE CONSTRAINT OF " &
+ "UNINITIALIZED ACTUAL");
+ END IF;
+ REC := (10,10,"9876543210");
+ END CHK_RECTYPE2;
+
+ BEGIN
+ REC1 := (10,10,"0123456789");
+ REC2 := (17,7,"C64106A..........");
+ REC3 := (1,1,"A");
+
+ END PKG;
+
+ BEGIN -- (B)
+
+ PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
+ PKG.CHK_RECTYPE2 (REC4);
+
+ END B; -- (B)
+
+ ---------------------------------------------
+
+C : DECLARE -- (C)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INT IS INTEGER RANGE 0..100;
+
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS
+ LIMITED PRIVATE;
+
+ PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE);
+
+ PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE);
+
+ PRIVATE
+ TYPE RECTYPE (CONSTRAINT : INT := 80) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC1 : PKG.RECTYPE; -- 10
+ REC2 : PKG.RECTYPE; -- 17
+ REC3 : PKG.RECTYPE; -- 1
+ REC4 : PKG.RECTYPE; -- 80
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE;
+ REC2 : OUT RECTYPE;
+ REC3 : IN OUT RECTYPE) IS
+ BEGIN
+ IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN
+ FAILED ("LIMITED PRIVATE TYPE IN PARAMETER " &
+ "DID NOT USE CONSTRAINT OF " &
+ "ACTUAL");
+ END IF;
+ IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN
+ FAILED ("LIMITED PRIVATE TYPE OUT PARAMETER " &
+ "DID NOT USE CONSTRAINT OF " &
+ "ACTUAL");
+ END IF;
+ IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN
+ FAILED ("LIMITED PRIVATE TYPE IN OUT " &
+ "PARAMETER DID NOT USE " &
+ "CONSTRAINT OF ACTUAL");
+ END IF;
+ REC2 := C.REC2;
+ END CHK_RECTYPE1;
+
+ PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS
+ BEGIN
+ IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN
+ FAILED ("LIMITED PRIVATE TYPE OUT " &
+ "PARAMETER DID NOT USE " &
+ "CONSTRAINT OF UNINITIALIZED ACTUAL");
+ END IF;
+ REC := (10,10,"9876543210");
+ END CHK_RECTYPE2;
+
+ BEGIN
+ REC1 := (10,10,"0123456789");
+ REC2 := (17,7,"C64106A..........");
+ REC3 := (1,1,"A");
+ END PKG;
+
+ BEGIN -- (C)
+
+ PKG.CHK_RECTYPE1 (REC1, REC2, REC3);
+ PKG.CHK_RECTYPE2 (REC4);
+
+ END C; -- (C)
+
+ ---------------------------------------------
+
+D : DECLARE -- (D)
+
+ TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF
+ CHARACTER;
+
+ A1, A2, A3 : ATYPE(-1..1, 4..5) := (('A','B'),
+ ('C','D'),
+ ('E','F'));
+
+ A4 : ATYPE(-1..1, 4..5);
+
+ CA1 : CONSTANT ATYPE(8..9, -7..INTEGER'FIRST) :=
+ (8..9 => (-7..INTEGER'FIRST => 'A'));
+
+ S1 : STRING(1..INTEGER'FIRST) := "";
+ S2 : STRING(-5..-7) := "";
+ S3 : STRING(1..0) := "";
+
+ PROCEDURE CHK_ARRAY1 (A1 : IN ATYPE := CA1; A2 : OUT ATYPE;
+ A3 : IN OUT ATYPE) IS
+ BEGIN
+ IF ((A1'FIRST(1) /= IDENT_INT(-1)) OR
+ (A1'LAST(1) /= IDENT_INT(1)) OR
+ (A1'FIRST(2) /= IDENT_INT(4)) OR
+ (A1'LAST(2) /= IDENT_INT(5))) THEN
+ FAILED ("ARRAY TYPE IN PARAMETER DID NOT " &
+ "USE CONSTRAINTS OF ACTUAL");
+ END IF;
+ IF ((A2'FIRST(1) /= IDENT_INT(-1)) OR
+ (A2'LAST(1) /= IDENT_INT(1)) OR
+ (A2'FIRST(2) /= IDENT_INT(4)) OR
+ (A2'LAST(2) /= IDENT_INT(5))) THEN
+ FAILED ("ARRAY TYPE OUT PARAMETER DID NOT USE" &
+ "CONSTRAINTS OF ACTUAL");
+ END IF;
+ IF ((A3'FIRST(1) /= IDENT_INT(-1)) OR
+ (A3'LAST(1) /= IDENT_INT(1)) OR
+ (A3'FIRST(2) /= IDENT_INT(4)) OR
+ (A3'LAST(2) /= IDENT_INT(5))) THEN
+ FAILED ("ARRAY TYPE IN OUT PARAMETER DID NOT " &
+ "USE CONSTRAINTS OF ACTUAL");
+ END IF;
+ A2 := D.A2;
+ END CHK_ARRAY1;
+
+ PROCEDURE CHK_ARRAY2 (A4 : OUT ATYPE) IS
+ BEGIN
+ IF ((A4'FIRST(1) /= IDENT_INT(-1)) OR
+ (A4'LAST(1) /= IDENT_INT(1)) OR
+ (A4'FIRST(2) /= IDENT_INT(4)) OR
+ (A4'LAST(2) /= IDENT_INT(5))) THEN
+ FAILED ("ARRAY TYPE OUT PARAMETER DID NOT " &
+ "USE CONSTRAINTS OF UNINITIALIZED " &
+ "ACTUAL");
+ END IF;
+ A4 := A2;
+ END CHK_ARRAY2;
+
+ PROCEDURE CHK_STRING (S1 : IN STRING;
+ S2 : IN OUT STRING;
+ S3 : OUT STRING) IS
+ BEGIN
+ IF ((S1'FIRST /= IDENT_INT(1)) OR
+ (S1'LAST /= IDENT_INT(INTEGER'FIRST))) THEN
+ FAILED ("STRING TYPE IN PARAMETER DID NOT " &
+ "USE CONSTRAINTS OF ACTUAL NULL " &
+ "STRING");
+ END IF;
+ IF ((S2'FIRST /= IDENT_INT(-5)) OR
+ (S2'LAST /= IDENT_INT(-7))) THEN
+ FAILED ("STRING TYPE IN OUT PARAMETER DID NOT " &
+ "USE CONSTRAINTS OF ACTUAL NULL STRING");
+ END IF;
+ IF ((S3'FIRST /= IDENT_INT(1)) OR
+ (S3'LAST /= IDENT_INT(0))) THEN
+ FAILED ("STRING TYPE OUT PARAMETER DID NOT " &
+ "USE CONSTRAINTS OF ACTUAL NULL STRING");
+ END IF;
+ S3 := "";
+ END CHK_STRING;
+
+ BEGIN -- (D)
+ CHK_ARRAY1 (A1, A2, A3);
+ CHK_ARRAY2 (A4);
+ CHK_STRING (S1, S2, S3);
+ END D; -- (D)
+
+ RESULT;
+END C64106A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64106b.ada b/gcc/testsuite/ada/acats/tests/c6/c64106b.ada
new file mode 100644
index 000000000..95d6fe195
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64106b.ada
@@ -0,0 +1,237 @@
+-- C64106B.ADA
+
+-- 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.
+--*
+-- CHECK THAT ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED RECORD,
+-- PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT DEFAULT CONSTRAINTS
+-- RAISE CONSTRAINT_ERROR IF AN ATTEMPT IS MADE TO CHANGE THE
+-- CONSTRAINT OF THE ACTUAL PARAMETER.
+-- SUBTESTS ARE:
+-- (A) RECORD TYPE.
+-- (B) PRIVATE TYPE.
+-- (C) LIMITED PRIVATE TYPE.
+
+-- DAS 1/15/81
+-- CPP 8/9/84
+
+WITH REPORT;
+PROCEDURE C64106B IS
+
+ USE REPORT;
+
+BEGIN
+
+ TEST ("C64106B", "CHECK ASSIGNMENT TO FORMAL PARAMETERS OF " &
+ "UNCONSTRAINED TYPE (WITH NO DEFAULT)");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+
+ PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE);
+ END PKG;
+
+ REC9 : PKG.RECTYPE(IDENT_INT(9)) :=
+ (IDENT_INT(9), 9, "123456789");
+ REC6 : PKG.RECTYPE(IDENT_INT(6)) :=
+ (IDENT_INT(6), 5, "AEIOUY");
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE) IS
+
+ REC4 : CONSTANT RECTYPE(IDENT_INT(4)) :=
+ (IDENT_INT(4), 4, "OOPS");
+
+ BEGIN
+ BEGIN -- (A.1)
+ REC9 := REC6;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - A.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - A.1");
+ END; -- (A.1)
+
+ BEGIN -- (A.2)
+ REC6 := REC4;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - A.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - A.2");
+ END; -- (A.2)
+
+ REC9 := (IDENT_INT(9), 9, "987654321");
+
+ END CHK_RECTYPE;
+ END PKG;
+
+ BEGIN -- (A)
+
+ PKG.CHK_RECTYPE (REC9, REC6);
+ IF REC9.STRFIELD /= IDENT_STR("987654321") THEN
+ FAILED ("ASSIGNMENT TO REC9 FAILED - (A)");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ PACKAGE PKG IS
+
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS PRIVATE;
+
+ PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE);
+ PRIVATE
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC9 : PKG.RECTYPE(9);
+ REC6 : PKG.RECTYPE(6);
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE) IS
+
+ REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS");
+
+ BEGIN
+ BEGIN -- (B.1)
+ REC9 := REC6;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - B.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - B.1");
+ END; -- (B.1)
+
+ BEGIN -- (B.2)
+ REC6 := REC4;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - B.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - B.2");
+ END; -- (B.2)
+ END CHK_RECTYPE;
+
+ BEGIN
+ REC9 := (9, 9, "123456789");
+ REC6 := (6, 5, "AEIOUY");
+ END PKG;
+
+ BEGIN -- (B)
+
+ PKG.CHK_RECTYPE (REC9, REC6);
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PACKAGE PKG IS
+
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE;
+
+ PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE);
+ PRIVATE
+ TYPE RECTYPE (CONSTRAINT : INTEGER) IS
+ RECORD
+ INTFIELD : INTEGER;
+ STRFIELD : STRING (1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC6 : PKG.RECTYPE(IDENT_INT(6));
+ REC9 : PKG.RECTYPE(IDENT_INT(9));
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE;
+ REC6 : IN OUT RECTYPE) IS
+
+ REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS");
+
+ BEGIN
+ BEGIN -- (C.1)
+ REC9 := REC6;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - C.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - C.1");
+ END; -- (C.1)
+
+ BEGIN -- (C.2)
+ REC6 := REC4;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - C.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - C.2");
+ END; -- (C.2)
+ END CHK_RECTYPE;
+
+ BEGIN
+ REC6 := (6, 5, "AEIOUY");
+ REC9 := (9, 9, "123456789");
+ END PKG;
+
+ BEGIN -- (C)
+
+ PKG.CHK_RECTYPE (REC9, REC6);
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64106B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64106c.ada b/gcc/testsuite/ada/acats/tests/c6/c64106c.ada
new file mode 100644
index 000000000..9adfa4d81
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64106c.ada
@@ -0,0 +1,309 @@
+-- C64106C.ADA
+
+-- 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.
+--*
+-- CHECK THAT ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED
+-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
+-- CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS
+-- CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING
+-- ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER.
+
+-- SUBTESTS ARE:
+-- (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
+-- (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
+-- (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
+
+-- DAS 1/16/81
+-- VKG 1/7/83
+-- CPP 8/9/84
+
+WITH REPORT;
+PROCEDURE C64106C IS
+
+ USE REPORT;
+
+BEGIN
+
+ TEST ("C64106C", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " &
+ "UNCONSTRAINED TYPES (WITH DEFAULTS)");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+
+ REC91,REC92,REC93 : RECTYPE(9);
+ REC_OOPS : RECTYPE(4);
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+ END PKG;
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) IS
+
+ PROCEDURE P1 (REC11 : IN RECTYPE;
+ REC12 : IN OUT RECTYPE;
+ REC13 : OUT RECTYPE) IS
+ BEGIN
+ IF (NOT REC11'CONSTRAINED) OR
+ (REC11.CONSTRAINT /= IDENT_INT(9)) THEN
+ FAILED ("CONSTRAINT ON RECORD " &
+ "TYPE IN PARAMETER " &
+ "NOT RECOGNIZED");
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
+ REC12 := REC_OOPS;
+ FAILED ("CONSTRAINT ERROR NOT RAISED - " &
+ "A.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - " &
+ "A.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER
+ REC13 := REC_OOPS;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
+ "A.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - " &
+ "A.2");
+ END;
+ END P1;
+
+ BEGIN
+ P1 (REC1, REC2, REC3);
+ END P;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (A)
+
+ PKG.P (PKG.REC91, PKG.REC92, PKG.REC93);
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+
+ PRIVATE
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC91, REC92, REC93 : PKG.RECTYPE(9);
+ REC_OOPS : PKG.RECTYPE(4);
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) IS
+
+ PROCEDURE P1 (REC11 : IN RECTYPE;
+ REC12 : IN OUT RECTYPE;
+ REC13 : OUT RECTYPE) IS
+ BEGIN
+ IF (NOT REC11'CONSTRAINED) OR
+ (REC11.CONSTRAINT /= IDENT_INT(9)) THEN
+ FAILED ("CONSTRAINT ON PRIVATE " &
+ "TYPE IN PARAMETER " &
+ "NOT RECOGNIZED");
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
+ REC12 := REC_OOPS;
+ FAILED ("CONSTRAINT ERROR NOT RAISED - " &
+ "B.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - " &
+ "B.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER
+ REC13 := REC_OOPS;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
+ "B.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - " &
+ "B.2");
+ END;
+ END P1;
+
+ BEGIN
+ P1 (REC1, REC2, REC3);
+ END P;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (B)
+
+ PKG.P (REC91, REC92, REC93);
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ LIMITED PRIVATE;
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+
+ PRIVATE
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC91,REC92,REC93 : PKG.RECTYPE(9);
+ REC_OOPS : PKG.RECTYPE(4);
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) IS
+
+ PROCEDURE P1 (REC11 : IN RECTYPE;
+ REC12 : IN OUT RECTYPE;
+ REC13 : OUT RECTYPE) IS
+ BEGIN
+ IF (NOT REC11'CONSTRAINED) OR
+ (REC11.CONSTRAINT /= 9) THEN
+ FAILED ("CONSTRAINT ON LIMITED PRIVATE " &
+ "TYPE IN PARAMETER " &
+ "NOT RECOGNIZED");
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
+ REC12 := REC_OOPS;
+ FAILED ("CONSTRAINT ERROR NOT RAISED - " &
+ "C.1");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - " &
+ "C.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER
+ REC13 := REC_OOPS;
+ FAILED ("CONSTRAINT_ERROR NOT RAISED - " &
+ "C.2");
+ EXCEPTION
+ WHEN CONSTRAINT_ERROR =>
+ NULL;
+ WHEN OTHERS =>
+ FAILED ("WRONG EXCEPTION RAISED - " &
+ "C.2");
+ END;
+ END P1;
+
+ BEGIN
+ P1 (REC1, REC2, REC3);
+ END P;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (C)
+
+ PKG.P (REC91, REC92, REC93);
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64106C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64106d.ada b/gcc/testsuite/ada/acats/tests/c6/c64106d.ada
new file mode 100644
index 000000000..0b3670842
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64106d.ada
@@ -0,0 +1,280 @@
+-- C64106D.ADA
+
+-- 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.
+--*
+-- CHECK THAT ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED
+-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT
+-- CONSTRAINTS DO NOT RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER
+-- IS UNCONSTRAINED, EVEN IF THE CONSTRAINT VALUES OF THE OBJECT
+-- BEING ASSIGNED ARE DIFFERENT THAN THOSE OF THE ACTUAL PARAMETER.
+
+-- SUBTESTS ARE:
+-- (A) UNCONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE.
+-- (B) UNCONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE.
+-- (C) UNCONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE.
+
+-- JRK 4/16/81
+-- CPP 8/9/84
+-- JRK 11/28/84
+
+WITH REPORT;
+PROCEDURE C64106D IS
+
+ USE REPORT;
+
+BEGIN
+
+ TEST ("C64106D", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " &
+ "UNCONSTRAINED TYPES WITH UNCONSTRAINED " &
+ "ACTUAL PARAMETERS");
+
+ --------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+ END PKG;
+
+ REC91, REC92, REC93 : PKG.RECTYPE :=
+ (IDENT_INT(5), 5, IDENT_STR("12345"));
+ REC_OOPS : PKG.RECTYPE;
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) IS
+
+ PROCEDURE P1 (REC11 : IN RECTYPE;
+ REC12 : IN OUT RECTYPE;
+ REC13 : OUT RECTYPE) IS
+ BEGIN
+
+ IF NOT REC11'CONSTRAINED THEN
+ FAILED ("REC11 IS NOT CONSTRAINED - A.1");
+ END IF;
+ IF REC11.CONSTRAINT /= IDENT_INT(9) THEN
+ FAILED ("REC11 CONSTRAINT IS NOT 9 " &
+ "- A.1");
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
+ REC12 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - A.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER
+ REC13 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - A.2");
+ END;
+ END P1;
+
+ BEGIN
+ P1 (REC1, REC2, REC3);
+ END P;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ USE PKG;
+
+ BEGIN -- (A)
+
+ PKG.P (REC91, REC92, REC93);
+ IF (REC92 /= REC_OOPS) OR (REC93 /= REC_OOPS) THEN
+ FAILED ("RESULTANT VALUE OF REC92 OR REC93 INCORRECT");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------------
+
+ DECLARE -- (B)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE;
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+
+ PRIVATE
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC91, REC92, REC93 : PKG.RECTYPE;
+ REC_OOPS : PKG.RECTYPE;
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) IS
+
+ PROCEDURE P1 (REC11 : IN RECTYPE;
+ REC12 : IN OUT RECTYPE;
+ REC13 : OUT RECTYPE) IS
+ BEGIN
+
+ IF REC3'CONSTRAINED THEN
+ FAILED ("REC3 IS CONSTRAINED - B.1");
+ END IF;
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
+ REC12 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - B.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER
+ REC13 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - B.2");
+ END;
+ END P1;
+
+ BEGIN
+ P1 (REC1, REC2, REC3);
+ END P;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (B)
+
+ PKG.P (REC91, REC92, REC93);
+
+ END; -- (B)
+
+ --------------------------------------------------
+
+ DECLARE -- (C)
+
+ PACKAGE PKG IS
+
+ SUBTYPE INTRANGE IS INTEGER RANGE 0..31;
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ LIMITED PRIVATE;
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE);
+
+ PRIVATE
+
+ TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS
+ RECORD
+ INTFLD : INTRANGE;
+ STRFLD : STRING(1..CONSTRAINT);
+ END RECORD;
+ END PKG;
+
+ REC91, REC92, REC93 : PKG.RECTYPE;
+ REC_OOPS : PKG.RECTYPE;
+
+ PACKAGE BODY PKG IS
+
+ PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE;
+ REC3 : OUT RECTYPE) IS
+
+ PROCEDURE P1 (REC11 : IN RECTYPE;
+ REC12 : IN OUT RECTYPE;
+ REC13 : OUT RECTYPE) IS
+ BEGIN
+
+ BEGIN -- ASSIGNMENT TO IN OUT PARAMETER
+ REC12 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - C.1");
+ END;
+
+ BEGIN -- ASSIGNMENT TO OUT PARAMETER
+ REC13 := REC_OOPS;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED - C.2");
+ END;
+ END P1;
+
+ BEGIN
+ P1 (REC1, REC2, REC3);
+ END P;
+
+ BEGIN
+
+ REC91 := (9, 9, "123456789");
+ REC92 := REC91;
+ REC93 := REC91;
+
+ REC_OOPS := (4, 4, "OOPS");
+
+ END PKG;
+
+ BEGIN -- (C)
+
+ PKG.P (REC91, REC92, REC93);
+
+ END; -- (C)
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C64106D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64107a.ada b/gcc/testsuite/ada/acats/tests/c6/c64107a.ada
new file mode 100644
index 000000000..fd846e86d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64107a.ada
@@ -0,0 +1,73 @@
+-- C64107A.ADA
+
+-- 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.
+--*
+-- CHECK THAT ACTUAL PARAMETERS ARE EVALUATED AND IDENTIFIED AT THE
+-- TIME OF CALL.
+
+-- DAS 1/29/81
+-- SPS 12/13/82
+
+WITH REPORT;
+PROCEDURE C64107A IS
+
+ USE REPORT;
+
+ TYPE VECTOR IS ARRAY (1..10) OF INTEGER;
+ TYPE PTRINT IS ACCESS INTEGER;
+
+ I : INTEGER := 1;
+ A : VECTOR := (1,2,3,4,5,6,7,8,9,10);
+ P1 : PTRINT := NEW INTEGER'(2);
+ P2 : PTRINT := P1;
+
+ PROCEDURE PROC1 (I : OUT INTEGER; J : OUT INTEGER) IS
+ BEGIN
+ I := 10;
+ J := -1;
+ END PROC1;
+
+ PROCEDURE PROC2 (P : OUT PTRINT; I : OUT INTEGER) IS
+ BEGIN
+ P := NEW INTEGER'(3);
+ I := 5;
+ END PROC2;
+
+BEGIN
+
+ TEST ("C64107A", "CHECK THAT ACTUAL PARAMETERS ARE EVALUATED" &
+ " AND IDENTIFIED AT THE TIME OF CALL");
+
+ PROC1 (I, A(I));
+ IF (A /= (-1,2,3,4,5,6,7,8,9,10)) THEN
+ FAILED ("A(I) EVALUATED UPON RETURN");
+ END IF;
+
+ PROC2 (P1, P1.ALL);
+ IF (P2.ALL /= 5) THEN
+ FAILED ("P1.ALL EVALUATED UPON RETURN");
+ END IF;
+
+ RESULT;
+
+END C64107A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64108a.ada b/gcc/testsuite/ada/acats/tests/c6/c64108a.ada
new file mode 100644
index 000000000..ae69d6632
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64108a.ada
@@ -0,0 +1,148 @@
+-- C64108A.ADA
+
+-- 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.
+--*
+-- CHECK THAT ALL PERMITTED FORMS OF VARIABLE NAMES ARE PERMITTED
+-- AS ACTUAL PARAMETERS.
+
+-- DAS 2/10/81
+-- SPS 10/26/82
+-- SPS 11/5/82
+
+WITH REPORT;
+PROCEDURE C64108A IS
+
+ USE REPORT;
+ SUBTYPE INT IS INTEGER RANGE 1..3;
+ TYPE REC (N : INT) IS
+ RECORD
+ S : STRING (1..N);
+ END RECORD;
+ TYPE PTRSTR IS ACCESS STRING;
+
+ R1,R2,R3 : REC(3);
+ S1,S2,S3 : STRING (1..3);
+ PTRTBL : ARRAY (1..3) OF PTRSTR;
+
+ PROCEDURE P1 (S1 : IN STRING; S2: IN OUT STRING;
+ S3 : OUT STRING) IS
+ BEGIN
+ S3 := S2;
+ S2 := S1;
+ END P1;
+
+ PROCEDURE P2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER;
+ C3 : OUT CHARACTER) IS
+ BEGIN
+ C3 := C2;
+ C2 := C1;
+ END P2;
+
+ FUNCTION F1 (X : INT) RETURN PTRSTR IS
+ BEGIN
+ RETURN PTRTBL(X);
+ END F1;
+
+ FUNCTION "+" (S1,S2 : STRING) RETURN PTRSTR IS
+ BEGIN
+ RETURN PTRTBL(CHARACTER'POS(S1(1))-CHARACTER'POS('A')+1);
+ END "+";
+
+BEGIN
+
+ TEST ("C64108A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE" &
+ " NAMES ARE PERMITTED AS ACTUAL PARAMETERS");
+
+ S1 := "AAA";
+ S2 := "BBB";
+ P1 (S1, S2, S3);
+ IF (S2 /= "AAA") OR (S3 /= "BBB") THEN
+ FAILED ("SIMPLE VARIABLE AS AN ACTUAL PARAMETER NOT WORKING");
+ END IF;
+
+ S1 := "AAA";
+ S2 := "BBB";
+ S3 := IDENT_STR("CCC");
+ P2 (S1(1), S2(IDENT_INT(1)), S3(1));
+ IF (S2 /= "ABB") OR (S3 /= "BCC") THEN
+ FAILED ("INDEXED COMPONENT AS AN ACTUAL PARAMETER NOT " &
+ "WORKING");
+ END IF;
+
+ R1.S := "AAA";
+ R2.S := "BBB";
+ P1 (R1.S, R2.S, R3.S);
+ IF (R2.S /= "AAA") OR (R3.S /= "BBB") THEN
+ FAILED ("SELECTED COMPONENT AS AN ACTUAL PARAMETER" &
+ " NOT WORKING");
+ END IF;
+
+ S1 := "AAA";
+ S2 := "BBB";
+ P1 (S1(1..IDENT_INT(2)), S2(1..2), S3(IDENT_INT(1)..IDENT_INT(2)));
+ IF (S2 /= "AAB") OR (S3 /= "BBC") THEN
+ FAILED ("SLICE AS AN ACTUAL PARAMETER NOT WORKING");
+ END IF;
+
+ PTRTBL(1) := NEW STRING'("AAA");
+ PTRTBL(2) := NEW STRING'("BBB");
+ PTRTBL(3) := NEW STRING'("CCC");
+ P1 (F1(1).ALL, F1(2).ALL, F1(IDENT_INT(3)).ALL);
+ IF (PTRTBL(2).ALL /= "AAA") OR (PTRTBL(3).ALL /= "BBB") THEN
+ FAILED ("SELECTED COMPONENT OF FUNCTION VALUE AS AN ACTUAL" &
+ " PARAMETER NOT WORKING");
+ END IF;
+
+ PTRTBL(1) := NEW STRING'("AAA");
+ PTRTBL(2) := NEW STRING'("BBB");
+ PTRTBL(3) := NEW STRING'("CCC");
+ S1 := IDENT_STR("AAA");
+ S2 := IDENT_STR("BBB");
+ S3 := IDENT_STR("CCC");
+ P1 ("+"(S1,S1).ALL, "+"(S2,S2).ALL, "+"(S3,S3).ALL);
+ IF (PTRTBL(2).ALL /= "AAA") OR (PTRTBL(3).ALL /= "BBB") THEN
+ FAILED ("SELECTED COMPONENT OF OVERLOADED OPERATOR FUNCTION" &
+ " VALUE AS AN ACTUAL PARAMETER NOT WORKING");
+ END IF;
+
+ PTRTBL(1) := NEW STRING'("AAA");
+ PTRTBL(2) := NEW STRING'("BBB");
+ PTRTBL(3) := NEW STRING'("CCC");
+ P2 (F1(1)(1), F1(IDENT_INT(2))(1), F1(3)(IDENT_INT(1)));
+ IF (PTRTBL(2).ALL /= "ABB") OR (PTRTBL(3).ALL /= "BCC") THEN
+ FAILED ("INDEXED COMPONENT OF FUNCTION VALUE AS AN ACTUAL" &
+ " PARAMETER NOT WORKING");
+ END IF;
+
+ PTRTBL(1) := NEW STRING'("AAA");
+ PTRTBL(2) := NEW STRING'("BBB");
+ PTRTBL(3) := NEW STRING'("CCC");
+ P1 (F1(1)(2..3), F1(2)(IDENT_INT(2)..3), F1(3)(2..IDENT_INT(3)));
+ IF (PTRTBL(2).ALL /= "BAA") OR (PTRTBL(3).ALL /= "CBB") THEN
+ FAILED ("SLICE OF FUNCTION VALUE AS AN ACTUAL PARAMETER" &
+ " NOT WORKING");
+ END IF;
+
+ RESULT;
+
+END C64108A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109a.ada b/gcc/testsuite/ada/acats/tests/c6/c64109a.ada
new file mode 100644
index 000000000..19c3f69d2
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109a.ada
@@ -0,0 +1,128 @@
+-- C64109A.ADA
+
+-- 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.
+--*
+-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
+-- TO SUBPROGRAMS. SPECIFICALLY,
+-- (A) CHECK ALL PARAMETER MODES.
+
+-- CPP 8/20/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109A IS
+
+BEGIN
+ TEST ("C64109A", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
+ "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS");
+
+ --------------------------------------------
+
+ DECLARE -- (A)
+
+ TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
+ SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5));
+ TYPE RECORD_TYPE IS
+ RECORD
+ I : INTEGER;
+ A : ARRAY_SUBTYPE;
+ END RECORD;
+ REC : RECORD_TYPE := (I => 23,
+ A => (1..3 => IDENT_INT(7), 4..5 => 9));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= IDENT_INT(1) OR
+ ARR'LAST /= IDENT_INT(5) THEN
+ FAILED ("WRONG BOUNDS FOR IN PARAMETER");
+ END IF;
+ END P1;
+
+ FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(1) OR
+ ARR'LAST /= IDENT_INT(5) THEN
+ FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN");
+ END IF;
+
+ RETURN TRUE;
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN OUT PARAMETER NOT PASSED " &
+ "CORRECTLY");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(1) OR
+ ARR'LAST /= IDENT_INT(5) THEN
+ FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER");
+ END IF;
+ ARR := (ARR'RANGE => 5);
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR'FIRST /= IDENT_INT(1) OR
+ ARR'LAST /= IDENT_INT(5) THEN
+ FAILED ("WRONG BOUNDS FOR OUT PARAMETER");
+ END IF;
+
+ ARR := (ARR'RANGE => 3);
+ END P3;
+
+ BEGIN -- (A)
+
+ P1 (REC.A);
+ IF REC.A /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+
+ BOOL := F1 (REC.A);
+ IF REC.A /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+
+ P2 (REC.A);
+ IF REC.A /= (5, 5, 5, 5, 5) THEN
+ FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+
+ P3 (REC.A);
+ IF REC.A /= (3, 3, 3, 3, 3) THEN
+ FAILED ("OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+
+ END; -- (A)
+
+ --------------------------------------------
+
+ RESULT;
+END C64109A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109b.ada b/gcc/testsuite/ada/acats/tests/c6/c64109b.ada
new file mode 100644
index 000000000..a644974d6
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109b.ada
@@ -0,0 +1,155 @@
+-- C64109B.ADA
+
+-- 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.
+--*
+-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
+-- TO SUBPROGRAMS. SPECIFICALLY,
+-- (B) CHECK MULTIDIMENSIONAL ARRAYS.
+
+-- CPP 8/20/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109B IS
+
+BEGIN
+ TEST ("C64109B", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
+ "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
+ "MULTIDIMENSIONAL ARRAYS");
+
+ DECLARE -- (B)
+
+ TYPE MULTI_TYPE IS ARRAY (POSITIVE RANGE <>,
+ POSITIVE RANGE <>) OF BOOLEAN;
+ SUBTYPE MULTI_SUBTYPE IS MULTI_TYPE (1..2, 1..3);
+ TYPE RECORD_TYPE IS
+ RECORD
+ I : BOOLEAN;
+ A : MULTI_SUBTYPE;
+ END RECORD;
+ REC : RECORD_TYPE :=
+ (I => FALSE,
+ A => (1..2 => (1..3 => IDENT_BOOL(TRUE))));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : MULTI_TYPE) IS
+ BEGIN
+ IF ARR /= (1..2 => (1..3 => TRUE)) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
+ FAILED ("FIRST DIM NOT CORRECT - IN PARAMETER");
+ ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
+ THEN
+ FAILED ("2ND DIM NOT CORRECT - IN PARAMETER");
+ END IF;
+ END P1;
+
+ FUNCTION F1 (ARR : MULTI_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (1..2 => (1..3 => TRUE)) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+
+ IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
+ FAILED ("FIRST DIM NOT CORRECT - IN PARAMETER FN");
+ ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
+ THEN
+ FAILED ("2ND DIM NOT CORRECT - IN PARAMETER FN");
+ END IF;
+ RETURN TRUE;
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT MULTI_TYPE) IS
+ BEGIN
+ IF ARR /= (1..2 => (1..3 => TRUE)) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
+ FAILED ("FIRST DIM NOT CORRECT - IN OUT PARAMETER");
+ ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
+ THEN
+ FAILED ("2ND DIM NOT CORRECT - IN OUT PARAMETER");
+ END IF;
+ ARR := (ARR'RANGE(1) => (ARR'RANGE(2) => FALSE));
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT MULTI_TYPE) IS
+ BEGIN
+ FOR I IN 1 .. 2 LOOP
+ FOR J IN 1 .. 3 LOOP
+ IF (J MOD 2) = 0 THEN
+ ARR(I, J) := TRUE;
+ ELSE
+ ARR(I, J) := FALSE;
+ END IF;
+ END LOOP;
+ END LOOP;
+
+ IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN
+ FAILED ("FIRST DIM NOT CORRECT - OUT PARAMETER");
+ ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3
+ THEN
+ FAILED ("2ND DIM NOT CORRECT - OUT PARAMETER");
+ END IF;
+ END P3;
+
+ BEGIN -- (B)
+
+ P1 (REC.A);
+ IF REC.A /= (1..2 => (1..3 => TRUE)) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+
+ BOOL := F1 (REC.A);
+ IF REC.A /= (1..2 => (1..3 => TRUE)) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+
+ P2 (REC.A);
+ IF REC.A /= (1..2 => (1..3 => FALSE)) THEN
+ FAILED ("IN OUT PARAM CHANGED BY PROCEDURE");
+ END IF;
+
+ P3 (REC.A);
+ FOR I IN 1 .. 2 LOOP
+ FOR J IN 1 .. 3 LOOP
+ IF (J MOD 2) = 0 THEN
+ IF REC.A(I, J) /= TRUE THEN
+ FAILED ("OUT PARAM RETURNED " &
+ "INCORRECTLY - (B)");
+ END IF;
+ ELSE
+ IF REC.A(I, J) /= FALSE THEN
+ FAILED ("OUT PARAM RETURNED " &
+ "INCORRECTLY - (B)2");
+ END IF;
+ END IF;
+ END LOOP;
+ END LOOP;
+
+ END; -- (B)
+
+ RESULT;
+END C64109B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109c.ada b/gcc/testsuite/ada/acats/tests/c6/c64109c.ada
new file mode 100644
index 000000000..1845f9e61
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109c.ada
@@ -0,0 +1,127 @@
+-- C64109C.ADA
+
+-- 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.
+--*
+-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
+-- TO SUBPROGRAMS. SPECIFICALLY,
+-- (C) CHECK RECORDS HAVING A DISCRIMINANT, WITH MORE THAN ONE ARRAY
+-- COMPONENT, WHERE THE BOUNDS OF THE ARRAY DEPEND ON THE
+-- DISCRIMINANT.
+
+-- CPP 8/20/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109C IS
+
+BEGIN
+ TEST ("C64109C", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
+ "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
+ "RECORDS WITH DISCRIMINANTS");
+
+ DECLARE -- (C)
+
+ SUBTYPE SUBINT IS INTEGER RANGE 1..6;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
+ TYPE RECORD_TYPE (BOUND : INTEGER) IS
+ RECORD
+ B : BOOLEAN;
+ A : ARRAY_TYPE (1..BOUND);
+ AA : ARRAY_TYPE (BOUND..6);
+ END RECORD;
+ REC : RECORD_TYPE (BOUND => IDENT_INT(4)) :=
+ (BOUND => 4,
+ B => TRUE,
+ A => (1..IDENT_INT(4) => 6),
+ AA => (4..6 => 8));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (6, 6, 6, 6) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
+ FAILED ("WRONG BOUNDS - IN PARAMETER");
+ END IF;
+ END P1;
+
+ FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (6, 6, 6, 6) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+
+ IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
+ FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
+ END IF;
+ RETURN TRUE;
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (8, 8, 8) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= 4 OR ARR'LAST /= IDENT_INT(6) THEN
+ FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
+ END IF;
+
+ ARR := (ARR'RANGE => 10);
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN
+ FAILED ("WRONG BOUNDS - OUT PARAMETER");
+ END IF;
+ ARR := (ARR'RANGE => 4);
+ END P3;
+
+ BEGIN -- (C)
+
+ P1 (REC.A);
+ IF REC.A /= (6, 6, 6, 6) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+
+ BOOL := F1 (REC.A);
+ IF REC.A /= (6, 6, 6, 6) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+
+ P2 (REC.AA);
+ IF REC.AA /= (10, 10, 10) THEN
+ FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+
+ P3 (REC.A);
+ IF REC.A /= (4, 4, 4, 4) THEN
+ FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+
+ END; -- (C)
+
+ RESULT;
+END C64109C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109d.ada b/gcc/testsuite/ada/acats/tests/c6/c64109d.ada
new file mode 100644
index 000000000..c8469bef1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109d.ada
@@ -0,0 +1,128 @@
+-- C64109D.ADA
+
+-- 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.
+--*
+-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
+-- TO SUBPROGRAMS. SPECIFICALLY,
+-- (D) CHECK OBJECTS DESIGNATED BY ACCESS TYPES.
+
+-- CPP 8/20/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109D IS
+
+BEGIN
+ TEST ("C64109D", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
+ "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
+ "OBJECTS DESIGNATED BY ACCESS TYPES");
+
+ DECLARE -- (D)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..3;
+ TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>) OF INTEGER;
+ SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(3));
+ TYPE NODE_TYPE;
+ TYPE ACCESS_TYPE IS ACCESS NODE_TYPE;
+ TYPE NODE_TYPE IS
+ RECORD
+ A : ARRAY_SUBTYPE;
+ NEXT : ACCESS_TYPE;
+ END RECORD;
+ PTR : ACCESS_TYPE := NEW NODE_TYPE'
+ (A => (IDENT_INT(1)..3 => IDENT_INT(5)),
+ NEXT => NULL);
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (5, 5, 5) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
+ FAILED ("WRONG BOUNDS - IN PARAMETER");
+ END IF;
+ END P1;
+
+ FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (5, 5, 5) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+
+ IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
+ FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
+ END IF;
+
+ RETURN TRUE;
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT ARRAY_SUBTYPE) IS
+ BEGIN
+ IF ARR /= (5, 5, 5) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
+ FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
+ END IF;
+
+ ARR := (OTHERS => 6);
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
+ BEGIN
+
+ IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
+ FAILED ("WRONG BOUNDS - OUT PARAMETER");
+ END IF;
+
+ ARR := (ARR'RANGE => 7);
+ END P3;
+
+ BEGIN -- (D)
+
+ P1 (PTR.A);
+ IF PTR.A /= (5, 5, 5) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+
+ BOOL := F1 (PTR.A);
+ IF PTR.A /= (5, 5, 5) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+
+ P2 (PTR.A);
+ IF PTR.A /= (6, 6, 6) THEN
+ FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+
+ P3 (PTR.A);
+ IF PTR.A /= (7, 7, 7) THEN
+ FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+
+ END; -- (D)
+
+ RESULT;
+END C64109D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109e.ada b/gcc/testsuite/ada/acats/tests/c6/c64109e.ada
new file mode 100644
index 000000000..5860ac7d7
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109e.ada
@@ -0,0 +1,156 @@
+-- C64109E.ADA
+
+-- 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.
+--*
+-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
+-- TO SUBPROGRAMS. SPECIFICALLY,
+-- (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS
+-- WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS.
+
+-- CPP 8/20/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109E IS
+
+BEGIN
+ TEST ("C64109E", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
+ "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
+ "ARRAYS WITH DIFFERENT BOUNDS PASSED TO UNCONSTRAINED " &
+ "FORMAL");
+
+ DECLARE -- (E)
+
+ SUBTYPE SUBINT IS INTEGER RANGE 0..5;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
+ TYPE RECORD_TYPE IS
+ RECORD
+ A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(2));
+ B : ARRAY_TYPE (1..3);
+ END RECORD;
+ REC : RECORD_TYPE := (A => (0..2 => IDENT_BOOL(TRUE)),
+ B => (1..3 => IDENT_BOOL(FALSE)));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
+ FAILED ("WRONG IN PARAMETER BOUNDS - 1");
+ END IF;
+ IF ARR2 /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY - 2");
+ END IF;
+ IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
+ FAILED ("WRONG IN PARAMETER BOUNDS - 2");
+ END IF;
+ END P1;
+
+ FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE)
+ RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
+ FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1");
+ END IF;
+ IF ARR2 /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+ IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
+ FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2");
+ END IF;
+ RETURN TRUE;
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE;
+ ARR2 : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
+ FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1");
+ END IF;
+ IF ARR2 /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+ IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
+ FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2");
+ END IF;
+ ARR := (ARR'RANGE => FALSE);
+ ARR2 := (ARR2'RANGE => TRUE);
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
+ FAILED ("WRONG OUT PARAMETER BOUNDS - 1");
+ END IF;
+ IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
+ FAILED ("WRONG OUT PARAMETER BOUNDS - 2");
+ END IF;
+ ARR := (ARR'RANGE => FALSE);
+ ARR2 := (ARR2'RANGE => TRUE);
+ END P3;
+
+ BEGIN -- (E)
+
+ P1 (REC.A, REC.B);
+ IF REC.A /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+ IF REC.B /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE - 2");
+ END IF;
+
+ BOOL := F1 (REC.A, REC.B);
+ IF REC.A /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+ IF REC.B /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION - 2");
+ END IF;
+
+ P2 (REC.A, REC.B);
+ IF REC.A /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+ IF REC.B /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2");
+ END IF;
+
+ P3 (REC.A, REC.B);
+ IF REC.A /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+ IF REC.B /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("OUT PARAM RETURNED INCORRECTLY - 2");
+ END IF;
+
+ END; -- (E)
+
+ RESULT;
+END C64109E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109f.ada b/gcc/testsuite/ada/acats/tests/c6/c64109f.ada
new file mode 100644
index 000000000..48a202c2d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109f.ada
@@ -0,0 +1,126 @@
+-- C64109F.ADA
+
+-- 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.
+--*
+-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY
+-- TO SUBPROGRAMS. SPECIFICALLY,
+-- (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN
+-- ANOTHER CALL.
+
+-- CPP 8/20/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109F IS
+
+BEGIN
+ TEST ("C64109F", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " &
+ "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " &
+ "FORMAL AS AN ACTUAL");
+
+ DECLARE -- (F)
+
+ TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
+ SUBTYPE ARRAY_SUBTYPE IS
+ ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5));
+ TYPE RECORD_TYPE IS
+ RECORD
+ I : INTEGER;
+ A : ARRAY_SUBTYPE;
+ END RECORD;
+ REC : RECORD_TYPE := (I => 23,
+ A => (1..3 => 7, 4..5 => 9));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF A /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY");
+ END IF;
+ IF A'FIRST /= 1 OR A'LAST /= 5 THEN
+ FAILED ("BOUNDS WRONG - IN OUT");
+ END IF;
+ A := (6, 6, 6, 6, 6);
+ END P_CALLED;
+
+ PROCEDURE P (A : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ P_CALLED (A);
+ END P;
+
+ FUNCTION F_CALLED (A : ARRAY_SUBTYPE) RETURN BOOLEAN IS
+ GOOD : BOOLEAN;
+ BEGIN
+ GOOD := (A = (7, 7, 7, 9, 9));
+ IF NOT GOOD THEN
+ FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY");
+ END IF;
+ IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(5) THEN
+ FAILED ("BOUNDS WRONG - FUNCTION");
+ END IF;
+ RETURN GOOD;
+ END F_CALLED;
+
+ FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ RETURN (F_CALLED (A));
+ END F;
+
+ PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS
+ BEGIN
+ IF A'FIRST /= 1 OR A'LAST /= 5 THEN
+ FAILED ("BOUNDS WRONG - OUT");
+ END IF;
+ A := (8, 8, 8, 8, 8);
+ END P_OUT_CALLED;
+
+ PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS
+ BEGIN
+ P_OUT_CALLED (A);
+ A := (9, 9, 9, 9, 9);
+ END P_OUT;
+
+ BEGIN -- (F)
+
+ P (REC.A);
+ IF REC.A /= (6, 6, 6, 6, 6) THEN
+ FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+
+ REC.A := (7, 7, 7, 9, 9);
+ BOOL := F (REC.A);
+ IF NOT BOOL THEN
+ FAILED ("IN PARAM NOT RETURNED CORRECTLY");
+ END IF;
+
+ REC.A := (7, 7, 7, 9, 9);
+ P_OUT (REC.A);
+ IF REC.A /= (9, 9, 9, 9, 9) THEN
+ FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2");
+ END IF;
+
+ END; -- (F)
+
+ --------------------------------------------
+
+ RESULT;
+END C64109F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109g.ada b/gcc/testsuite/ada/acats/tests/c6/c64109g.ada
new file mode 100644
index 000000000..df6a827e7
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109g.ada
@@ -0,0 +1,125 @@
+-- C64109G.ADA
+
+-- 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.
+--*
+-- CHECK THAT SLICES OF ARRAYS ARE PASSED CORRECTLY TO SUBPROGRAMS.
+-- SPECIFICALLY,
+-- (A) CHECK ALL PARAMETER MODES.
+
+-- CPP 8/28/84
+-- PWN 05/31/96 Corrected spelling problem.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109G IS
+
+BEGIN
+ TEST ("C64109G", "CHECK THAT SLICES OF ARRAYS ARE PASSED " &
+ "CORRECTLY TO SUBPROGRAMS");
+
+ --------------------------------------------
+
+ DECLARE -- (A)
+
+ SUBTYPE SUBINT IS INTEGER RANGE 1..5;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
+ ARR : ARRAY_TYPE (1..5) := (1..3 => 7, 4..5 => 9);
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (S : ARRAY_TYPE) IS
+ BEGIN
+ IF S(IDENT_INT(3)) /= 7 THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)");
+ END IF;
+ IF S(4) /= 9 THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)2");
+ END IF;
+ END P1;
+
+ FUNCTION F1 (S : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ IF S(3) /= 7 THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)");
+ END IF;
+ IF S(IDENT_INT(4)) /= 9 THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)2");
+ END IF;
+ RETURN TRUE;
+ END F1;
+
+ PROCEDURE P2 (S : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF S(3) /= 7 THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY - (A)");
+ END IF;
+ IF S(4) /= 9 THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY - (A)2");
+ END IF;
+ FOR I IN 3 .. 4 LOOP
+ S(I) := 5;
+ END LOOP;
+ END P2;
+
+ PROCEDURE P3 (S : OUT ARRAY_TYPE) IS
+ BEGIN
+ FOR I IN 3 .. 4 LOOP
+ S(I) := 3;
+ END LOOP;
+ END P3;
+
+ BEGIN -- (A)
+
+ P1 (ARR(3..4));
+ IF ARR(3) /= 7 THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE - (A)");
+ END IF;
+ IF ARR(4) /= 9 THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE - (A)2");
+ END IF;
+
+ BOOL := F1 (ARR(IDENT_INT(3)..IDENT_INT(4)));
+ IF ARR(3) /= 7 THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION - (A)");
+ END IF;
+ IF ARR(4) /= 9 THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION - (A)2");
+ END IF;
+
+ P2 (ARR(3..4));
+ FOR I IN 3 .. 4 LOOP
+ IF ARR(I) /= 5 THEN
+ FAILED ("IN OUT PARAM RETURNED INCORRECTLY - (A)");
+ END IF;
+ END LOOP;
+
+ P3 (ARR(IDENT_INT(3)..4));
+ FOR I IN 3 .. 4 LOOP
+ IF ARR(I) /= 3 THEN
+ FAILED ("OUT PARAM RETURNED INCORRECTLY - (A)");
+ END IF;
+ END LOOP;
+
+ END;
+
+ RESULT;
+
+END C64109G;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109h.ada b/gcc/testsuite/ada/acats/tests/c6/c64109h.ada
new file mode 100644
index 000000000..182856329
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109h.ada
@@ -0,0 +1,160 @@
+-- C64109H.ADA
+
+-- 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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
+-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
+-- (A) CHECK ALL PARAMETER MODES.
+
+-- HISTORY:
+-- TBN 07/11/86 CREATED ORIGINAL TEST.
+-- JET 08/04/87 MODIFIED REC.A REFERENCES.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109H IS
+
+BEGIN
+ TEST ("C64109H", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
+ "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
+ "TO SUBPROGRAMS");
+
+ DECLARE -- (A)
+
+ TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
+ SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5));
+ TYPE RECORD_TYPE IS
+ RECORD
+ I : INTEGER;
+ A : ARRAY_SUBTYPE;
+ END RECORD;
+ REC : RECORD_TYPE := (I => 23,
+ A => (1..3 => IDENT_INT(7), 4..5 => 9));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (7, 9, 9) THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= IDENT_INT(3) OR
+ ARR'LAST /= IDENT_INT(5) THEN
+ FAILED ("WRONG BOUNDS FOR IN PARAMETER");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
+ END P1;
+
+ FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (7, 7, 9) THEN
+ FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(2) OR
+ ARR'LAST /= IDENT_INT(4) THEN
+ FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN");
+ END IF;
+
+ RETURN TRUE;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN FUNCTION F1");
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (7, 7, 7, 9) THEN
+ FAILED ("IN OUT PARAMETER NOT PASSED " &
+ "CORRECTLY");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(1) OR
+ ARR'LAST /= IDENT_INT(4) THEN
+ FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER");
+ END IF;
+ ARR := (ARR'RANGE => 5);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR'FIRST /= IDENT_INT(3) OR
+ ARR'LAST /= IDENT_INT(4) THEN
+ FAILED ("WRONG BOUNDS FOR OUT PARAMETER");
+ END IF;
+
+ ARR := (ARR'RANGE => 3);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
+ END P3;
+
+ BEGIN -- (A)
+
+ BEGIN -- (B)
+ P1 (REC.A (3..5));
+ IF REC.A /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P1");
+ END; -- (B)
+
+ BEGIN -- (C)
+ BOOL := F1 (REC.A (2..4));
+ IF REC.A /= (7, 7, 7, 9, 9) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF F1");
+ END; -- (C)
+
+ BEGIN -- (D)
+ P2 (REC.A (1..4));
+ IF REC.A /= (5, 5, 5, 5, 9) THEN
+ FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P2");
+ END; -- (D)
+
+ BEGIN -- (E)
+ P3 (REC.A (3..4));
+ IF REC.A /= (5, 5, 3, 3, 9) THEN
+ FAILED ("OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P3");
+ END; -- (E)
+
+ END; -- (A)
+
+ RESULT;
+END C64109H;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109i.ada b/gcc/testsuite/ada/acats/tests/c6/c64109i.ada
new file mode 100644
index 000000000..de7ede6b0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109i.ada
@@ -0,0 +1,163 @@
+-- C64109I.ADA
+
+-- 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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
+-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
+-- (C) CHECK RECORDS HAVING A DISCRIMINANT, WITH MORE THAN ONE ARRAY
+-- COMPONENT, WHERE THE BOUNDS OF THE ARRAY DEPEND ON THE
+-- DISCRIMINANT.
+
+-- HISTORY:
+-- TBN 07/10/86 CREATED ORIGINAL TEST.
+-- JET 08/04/87 REMOVED PARTIAL ARRAY REFERENCES IN
+-- RECORD FIELDS.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109I IS
+
+BEGIN
+ TEST ("C64109I", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
+ "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
+ "TO SUBPROGRAMS - RECORDS WITH DISCRIMINANTS");
+
+ DECLARE -- (C)
+
+ SUBTYPE SUBINT IS INTEGER RANGE 1..6;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER;
+ TYPE RECORD_TYPE (BOUND : INTEGER) IS
+ RECORD
+ B : BOOLEAN;
+ A : ARRAY_TYPE (1..BOUND);
+ AA : ARRAY_TYPE (BOUND..6);
+ END RECORD;
+ REC : RECORD_TYPE (BOUND => IDENT_INT(4)) :=
+ (BOUND => 4,
+ B => TRUE,
+ A => (1..IDENT_INT(4) => 6),
+ AA => (4..6 => 8));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (6, 6, 6) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(3) THEN
+ FAILED ("WRONG BOUNDS - IN PARAMETER");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
+ END P1;
+
+ FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (6, 6, 6) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+
+ IF ARR'FIRST /= 2 OR ARR'LAST /= IDENT_INT(4) THEN
+ FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
+ END IF;
+ RETURN TRUE;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN FUNCTION F1");
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (8, 8) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= 4 OR ARR'LAST /= IDENT_INT(5) THEN
+ FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
+ END IF;
+
+ ARR := (ARR'RANGE => 10);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR'FIRST /= 2 OR ARR'LAST /= IDENT_INT(3) THEN
+ FAILED ("WRONG BOUNDS - OUT PARAMETER");
+ END IF;
+ ARR := (ARR'RANGE => 4);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
+ END P3;
+
+ BEGIN -- (C)
+
+ BEGIN -- (D)
+ P1 (REC.A (1..3));
+ IF REC.A /= (6, 6, 6, 6) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P1");
+ END; -- (D)
+
+ BEGIN -- (E)
+ BOOL := F1 (REC.A (2..4));
+ IF REC.A /= (6, 6, 6, 6) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF F1");
+ END; -- (E)
+
+ BEGIN -- (F)
+ P2 (REC.AA (4..5));
+ IF REC.AA /= (10, 10, 8) THEN
+ FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P2");
+ END; -- (F)
+
+ BEGIN -- (G)
+ P3 (REC.A (2..3));
+ IF REC.A /= (6, 4, 4, 6) THEN
+ FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P3");
+ END; -- (G)
+
+ END; -- (C)
+
+ RESULT;
+END C64109I;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109j.ada b/gcc/testsuite/ada/acats/tests/c6/c64109j.ada
new file mode 100644
index 000000000..c326ef2c4
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109j.ada
@@ -0,0 +1,164 @@
+-- C64109J.ADA
+
+-- 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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
+-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
+-- (D) CHECK OBJECTS DESIGNATED BY ACCESS TYPES.
+
+-- HISTORY:
+-- TBN 07/10/86 CREATED ORIGINAL TEST.
+-- JET 08/04/87 MODIFIED PTR.A REFERENCES.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109J IS
+
+BEGIN
+ TEST ("C64109J", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
+ "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
+ "TO SUBPROGRAMS - OBJECTS DESIGNATED BY ACCESS " &
+ "TYPES");
+
+ DECLARE -- (D)
+
+ SUBTYPE INDEX IS INTEGER RANGE 1..5;
+ TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>) OF INTEGER;
+ SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5));
+ TYPE NODE_TYPE;
+ TYPE ACCESS_TYPE IS ACCESS NODE_TYPE;
+ TYPE NODE_TYPE IS
+ RECORD
+ A : ARRAY_SUBTYPE;
+ NEXT : ACCESS_TYPE;
+ END RECORD;
+ PTR : ACCESS_TYPE := NEW NODE_TYPE'
+ (A => (IDENT_INT(1)..5 => IDENT_INT(5)),
+ NEXT => NULL);
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (5, 5, 5) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
+ FAILED ("WRONG BOUNDS - IN PARAMETER");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
+ END P1;
+
+ FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (5, 5, 5) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+
+ IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN
+ FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN");
+ END IF;
+
+ RETURN TRUE;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN FUNCTION F1");
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (5, 5, 5) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+
+ IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
+ FAILED ("WRONG BOUNDS - IN OUT PARAMETER");
+ END IF;
+
+ ARR := (ARR'RANGE => 6);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS
+ BEGIN
+
+ IF ARR'FIRST /= IDENT_INT(3) OR ARR'LAST /= 5 THEN
+ FAILED ("WRONG BOUNDS - OUT PARAMETER");
+ END IF;
+
+ ARR := (ARR'RANGE => 7);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
+ END P3;
+
+ BEGIN -- (D)
+
+ BEGIN -- (E)
+ P1 (PTR.A (1..3));
+ IF PTR.A /= (5, 5, 5, 5, 5) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P1");
+ END; -- (E)
+
+ BEGIN -- (F)
+ BOOL := F1 (PTR.A (2..4));
+ IF PTR.A /= (5, 5, 5, 5, 5) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF F1");
+ END; -- (F)
+
+ BEGIN -- (G)
+ P2 (PTR.A (1..3));
+ IF PTR.A /= (6, 6, 6, 5, 5) THEN
+ FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P2");
+ END; -- (G)
+
+ BEGIN -- (H)
+ P3 (PTR.A (3..5));
+ IF PTR.A /= (6, 6, 7, 7, 7) THEN
+ FAILED ("OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P3");
+ END; -- (H)
+
+ END; -- (D)
+
+ RESULT;
+END C64109J;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109k.ada b/gcc/testsuite/ada/acats/tests/c6/c64109k.ada
new file mode 100644
index 000000000..d72d8ec6c
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109k.ada
@@ -0,0 +1,191 @@
+-- C64109K.ADA
+
+-- 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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
+-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
+-- (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS
+-- WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS.
+
+-- HISTORY:
+-- TBN 07/11/86 CREATED ORIGINAL TEST.
+-- JET 08/04/87 MODIFIED REC.A REFERENCES.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109K IS
+
+BEGIN
+ TEST ("C64109K", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
+ "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
+ "TO SUBPROGRAMS - ARRAYS WITH DIFFERENT BOUNDS " &
+ "PASSED TO UNCONSTRAINED FORMAL");
+
+ DECLARE -- (E)
+
+ SUBTYPE SUBINT IS INTEGER RANGE 0..5;
+ TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
+ TYPE RECORD_TYPE IS
+ RECORD
+ A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(4));
+ B : ARRAY_TYPE (1..5);
+ END RECORD;
+ REC : RECORD_TYPE := (A => (0..4 => IDENT_BOOL(TRUE)),
+ B => (1..5 => IDENT_BOOL(FALSE)));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
+ FAILED ("WRONG IN PARAMETER BOUNDS - 1");
+ END IF;
+ IF ARR2 /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY - 2");
+ END IF;
+ IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
+ FAILED ("WRONG IN PARAMETER BOUNDS - 2");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P1");
+ END P1;
+
+ FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE)
+ RETURN BOOLEAN IS
+ BEGIN
+ IF ARR /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN
+ FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1");
+ END IF;
+ IF ARR2 /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN");
+ END IF;
+ IF ARR2'FIRST /= 3 OR ARR2'LAST /= IDENT_INT(5) THEN
+ FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2");
+ END IF;
+ RETURN TRUE;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN FUNCTION F1");
+ END F1;
+
+ PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE;
+ ARR2 : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR /= (TRUE, TRUE, TRUE) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+ IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN
+ FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1");
+ END IF;
+ IF ARR2 /= (FALSE, FALSE, FALSE) THEN
+ FAILED ("IN OUT PARAM NOT PASSED CORRECTLY");
+ END IF;
+ IF ARR2'FIRST /= 2 OR ARR2'LAST /= IDENT_INT(4) THEN
+ FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2");
+ END IF;
+ ARR := (ARR'RANGE => FALSE);
+ ARR2 := (ARR2'RANGE => TRUE);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P2");
+ END P2;
+
+ PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS
+ BEGIN
+ IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN
+ FAILED ("WRONG OUT PARAMETER BOUNDS - 1");
+ END IF;
+ IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN
+ FAILED ("WRONG OUT PARAMETER BOUNDS - 2");
+ END IF;
+ ARR := (ARR'RANGE => FALSE);
+ ARR2 := (ARR2'RANGE => TRUE);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P3");
+ END P3;
+
+ BEGIN -- (E)
+
+ BEGIN -- (F)
+ P1 (REC.A (0..2), REC.B (1..3));
+ IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE");
+ END IF;
+ IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
+ FAILED ("IN PARAM CHANGED BY PROCEDURE - 2");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P1");
+ END; -- (F)
+
+ BEGIN -- (G)
+ BOOL := F1 (REC.A (1..3), REC.B (3..5));
+ IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION");
+ END IF;
+ IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
+ FAILED ("IN PARAM CHANGED BY FUNCTION - 2");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF F1");
+ END; -- (G)
+
+ BEGIN -- (H)
+ P2 (REC.A (2..4), REC.B (2..4));
+ IF REC.A /= (TRUE, TRUE, FALSE, FALSE, FALSE) THEN
+ FAILED ("IN OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+ IF REC.B /= (FALSE, TRUE, TRUE, TRUE, FALSE) THEN
+ FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P2");
+ END; -- (H)
+
+ BEGIN -- (I)
+ P3 (REC.A (0..2), REC.B (1..3));
+ IF REC.A /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN
+ FAILED ("OUT PARAM RETURNED INCORRECTLY");
+ END IF;
+ IF REC.B /= (TRUE, TRUE, TRUE, TRUE, FALSE) THEN
+ FAILED ("OUT PARAM RETURNED INCORRECTLY - 2");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P3");
+ END; -- (I)
+
+ END; -- (E)
+
+ RESULT;
+END C64109K;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64109l.ada b/gcc/testsuite/ada/acats/tests/c6/c64109l.ada
new file mode 100644
index 000000000..7bdb17040
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64109l.ada
@@ -0,0 +1,158 @@
+-- C64109L.ADA
+
+-- 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 SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE
+-- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY,
+-- (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN
+-- ANOTHER SUBPROGRAM CALL.
+
+-- HISTORY:
+-- TBN 07/11/86 CREATED ORIGINAL TEST.
+-- JET 08/04/87 MODIFIED REC.A REFERENCES.
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64109L IS
+
+BEGIN
+ TEST ("C64109L", "CHECK THAT SLICES OF ARRAYS WHICH ARE " &
+ "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " &
+ "TO SUBPROGRAMS - FORMAL AS AN ACTUAL");
+
+ DECLARE -- (F)
+
+ TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
+ SUBTYPE ARRAY_SUBTYPE IS
+ ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5));
+ TYPE RECORD_TYPE IS
+ RECORD
+ I : INTEGER;
+ A : ARRAY_SUBTYPE;
+ END RECORD;
+ REC : RECORD_TYPE := (I => 23,
+ A => (1..3 => 7, 4..5 => 9));
+ BOOL : BOOLEAN;
+
+ PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ IF A /= (7, 7, 7) THEN
+ FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY");
+ END IF;
+ IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(3) THEN
+ FAILED ("BOUNDS WRONG - IN OUT");
+ END IF;
+ A := (A'RANGE => 6);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P_CALLED");
+ END P_CALLED;
+
+ PROCEDURE P (A : IN OUT ARRAY_TYPE) IS
+ BEGIN
+ P_CALLED (A);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P");
+ END P;
+
+ FUNCTION F_CALLED (A : ARRAY_TYPE) RETURN BOOLEAN IS
+ GOOD : BOOLEAN;
+ BEGIN
+ GOOD := (A = (6, 9, 9));
+ IF NOT GOOD THEN
+ FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY");
+ END IF;
+ IF A'FIRST /= 3 OR A'LAST /= IDENT_INT(5) THEN
+ FAILED ("BOUNDS WRONG - FUNCTION");
+ END IF;
+ RETURN GOOD;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN FUNCTION F_CALLED");
+ END F_CALLED;
+
+ FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS
+ BEGIN
+ RETURN (F_CALLED (A));
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN FUNCTION F");
+ END F;
+
+ PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS
+ BEGIN
+ IF A'FIRST /= IDENT_INT(2) OR A'LAST /= 4 THEN
+ FAILED ("BOUNDS WRONG - OUT");
+ END IF;
+ A := (8, 8, 8);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE " &
+ "P_OUT_CALLED");
+ END P_OUT_CALLED;
+
+ PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS
+ BEGIN
+ P_OUT_CALLED (A);
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED IN PROCEDURE P_OUT");
+ END P_OUT;
+
+ BEGIN -- (F)
+
+ BEGIN -- (G)
+ P (REC.A (1..3));
+ IF REC.A /= (6, 6, 6, 9, 9) THEN
+ FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P");
+ END; -- (G)
+
+ BEGIN -- (H)
+ BOOL := F (REC.A (3..5));
+ IF NOT BOOL THEN
+ FAILED ("IN PARAM NOT RETURNED CORRECTLY");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF F");
+ END; -- (H)
+
+ BEGIN -- (I)
+ P_OUT (REC.A (2..4));
+ IF REC.A /= (6, 8, 8, 8, 9) THEN
+ FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2");
+ END IF;
+ EXCEPTION
+ WHEN OTHERS =>
+ FAILED ("EXCEPTION RAISED DURING CALL OF P_OUT");
+ END; -- (I)
+
+ END; -- (F)
+
+ RESULT;
+END C64109L;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64201b.ada b/gcc/testsuite/ada/acats/tests/c6/c64201b.ada
new file mode 100644
index 000000000..e550b34ca
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64201b.ada
@@ -0,0 +1,101 @@
+-- C64201B.ADA
+
+-- 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.
+--*
+-- CHECK THAT INITALIZATION OF IN PARAMETERS OF A TASK
+-- TYPE IS PERMITTED.
+-- (SEE ALSO 7.4.4/T2 FOR TESTS OF LIMITED PRIVATE TYPES.)
+
+-- CVP 5/14/81
+-- ABW 7/1/82
+-- BHS 7/9/84
+
+WITH REPORT;
+PROCEDURE C64201B IS
+
+ USE REPORT;
+
+BEGIN
+
+ TEST( "C64201B" , "CHECK THAT INITIALIZATION OF IN PARAMETERS " &
+ "OF A TASK TYPE IS PERMITTED" );
+
+ DECLARE
+
+ GLOBAL : INTEGER := 10;
+
+ TASK TYPE T_TYPE IS
+ ENTRY E (X : IN OUT INTEGER);
+ END;
+
+ TSK1, TSK2 : T_TYPE;
+
+ TASK BODY T_TYPE IS
+ BEGIN
+ ACCEPT E (X : IN OUT INTEGER) DO
+ X := X - 1;
+ END E;
+ ACCEPT E (X : IN OUT INTEGER) DO
+ X := X + 1;
+ END E;
+ END T_TYPE;
+
+
+ PROCEDURE PROC1 (T : T_TYPE := TSK1) IS
+ BEGIN
+ T.E (X => GLOBAL);
+ END PROC1;
+
+ PROCEDURE PROC2 (T : T_TYPE := TSK1) IS
+ BEGIN
+ T.E (X => GLOBAL);
+ IF (GLOBAL /= IDENT_INT(8)) THEN
+ FAILED( "TASK NOT PASSED IN PROC1, " &
+ "DEFAULT TSK1 EMPLOYED" );
+ END IF;
+ END PROC2;
+
+ PROCEDURE TERM (T : T_TYPE; NUM : CHARACTER) IS
+ BEGIN
+ IF NOT T'TERMINATED THEN
+ ABORT T;
+ COMMENT ("ABORTING TASK " & NUM);
+ END IF;
+ END TERM;
+
+ BEGIN
+
+ PROC1(TSK2);
+ IF GLOBAL /= 9 THEN
+ FAILED ("INCORRECT GLOBAL VALUE AFTER PROC1");
+ ELSE
+ PROC2;
+ END IF;
+
+ TERM(TSK1, '1');
+ TERM(TSK2, '2');
+ END;
+
+ RESULT;
+
+END C64201B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64201c.ada b/gcc/testsuite/ada/acats/tests/c6/c64201c.ada
new file mode 100644
index 000000000..ac7fec806
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64201c.ada
@@ -0,0 +1,196 @@
+-- C64201C.ADA
+
+-- 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.
+--*
+-- CHECK THAT INITIALIZATION OF IN PARAMETERS OF A COMPOSITE
+-- TYPE HAVING AT LEAST ONE COMPONENT (INCLUDING COMPONENTS
+-- OF COMPONENTS) OF A TASK TYPE IS PERMITTED.
+-- (SEE ALSO 7.4.4/T2 FOR TESTS OF LIMITED PRIVATE TYPES.)
+
+-- CVP 5/14/81
+-- ABW 7/1/82
+-- BHS 7/9/84
+
+WITH REPORT;
+USE REPORT;
+PROCEDURE C64201C IS
+
+
+ GLOBAL : INTEGER := 10;
+
+
+ TASK TYPE T IS
+ ENTRY E (X : IN OUT INTEGER);
+ END;
+
+ TYPE REC_T IS
+ RECORD
+ TT : T;
+ BB : BOOLEAN := TRUE;
+ END RECORD;
+
+ TYPE REC_REC_T IS
+ RECORD
+ RR : REC_T;
+ END RECORD;
+
+ TYPE ARR_T IS ARRAY (1 .. 2) OF T;
+
+ TYPE ARR_REC_T IS ARRAY (1 .. 2) OF REC_T;
+
+ RT1, RT2 : REC_T;
+ RRT1, RRT2 : REC_REC_T;
+ AT1, AT2 : ARR_T;
+ ART1, ART2 : ARR_REC_T;
+
+
+ TASK BODY T IS
+ BEGIN
+ ACCEPT E (X : IN OUT INTEGER) DO
+ X := X - 1;
+ END E;
+ ACCEPT E (X : IN OUT INTEGER) DO
+ X := X + 1;
+ END E;
+ END T;
+
+
+ PROCEDURE PROC1A (P1X : REC_T := RT1) IS
+ BEGIN
+ IF P1X.BB THEN -- EXPECT RT2 PASSED.
+ FAILED( "RECORD OF TASK NOT PASSED, DEFAULT EMPLOYED" );
+ END IF;
+ END PROC1A;
+
+ PROCEDURE PROC1B (P1X : REC_T := RT1) IS
+ BEGIN
+ IF NOT P1X.BB THEN -- EXPECT DEFAULT USED.
+ FAILED( "DEFAULT RECORD OF TASK NOT EMPLOYED" );
+ END IF;
+ END PROC1B;
+
+
+ PROCEDURE PROC2A (P2X : REC_REC_T := RRT1) IS
+ BEGIN
+ IF P2X.RR.BB THEN -- EXPECT RRT2 PASSED.
+ FAILED( "RECORD OF RECORD OF TASK NOT PASSED, " &
+ "DEFAULT EMPLOYED" );
+ END IF;
+ END PROC2A;
+
+ PROCEDURE PROC2B (P2X : REC_REC_T := RRT1) IS
+ BEGIN
+ IF NOT P2X.RR.BB THEN -- EXPECT DEFAULT USED.
+ FAILED( "DEFAULT RECORD OF RECORD OF TASK " &
+ "NOT EMPLOYED" );
+ END IF;
+ END PROC2B;
+
+
+ PROCEDURE PROC3 (P3X : ARR_T := AT1) IS
+ BEGIN
+ P3X(1).E (X => GLOBAL); -- CALL TO AT2(1).E,
+ -- GLOBAL => GLOBAL - 1.
+ END PROC3;
+
+ PROCEDURE PROC4 (P4X : ARR_T := AT1) IS
+ BEGIN
+ P4X(1).E (X => GLOBAL); -- CALL TO DEFAULT AT1(1).E,
+ -- GLOBAL => GLOBAL - 1.
+ IF GLOBAL /= IDENT_INT(8) THEN
+ FAILED( "ARRAY OF TASKS NOT PASSED " &
+ "CORRECTLY IN PROC3" );
+ END IF;
+ END PROC4;
+
+ PROCEDURE PROC5 (P5X : ARR_REC_T := ART1) IS
+ BEGIN
+ P5X(1).TT.E (X => GLOBAL); -- CALL TO ART2(1).TT.E,
+ -- GLOBAL => GLOBAL - 1.
+ END PROC5;
+
+ PROCEDURE PROC6 (P6X : ARR_REC_T := ART1) IS
+ BEGIN
+ P6X(1).TT.E (X => GLOBAL); -- CALL DEFAULT ART1(1).TT.E,
+ -- GLOBAL => GLOBAL - 1.
+ IF GLOBAL /= IDENT_INT(8) THEN
+ FAILED( "ARRAY OF RECORDS OF TASKS NOT " &
+ "PASSED IN PROC5" );
+ END IF;
+ END PROC6;
+
+ PROCEDURE TERM (TSK : T; NUM : CHARACTER) IS
+ BEGIN
+ IF NOT TSK'TERMINATED THEN
+ ABORT TSK;
+ COMMENT ("ABORTING TASK " & NUM);
+ END IF;
+ END TERM;
+
+
+BEGIN
+
+ TEST( "C64201C" , "CHECK THAT INITIALIZATION OF IN " &
+ "PARAMETERS OF A COMPOSITE TYPE " &
+ "IS PERMITTED" );
+
+ RT2.BB := FALSE;
+ RRT2.RR.BB := FALSE;
+
+ PROC1A(RT2); -- NO ENTRY CALL
+ PROC1B; -- NO ENTRY CALL
+ PROC2A(RRT2); -- NO ENTRY CALL
+ PROC2B; -- NO ENTRY CALL
+
+ PROC3(AT2); -- CALL AT2(1).E
+ IF GLOBAL /= 9 THEN
+ FAILED ("INCORRECT GLOBAL VALUE AFTER PROC3");
+ ELSE
+ PROC4; -- CALL AT1(1).E
+ END IF;
+
+ GLOBAL := 10;
+ PROC5(ART2); -- CALL ART2(1).TT.E
+ IF GLOBAL /= 9 THEN
+ FAILED ("INCORRECT GLOBAL VALUE AFTER PROC5");
+ ELSE
+ PROC6; -- CALL ART1(1).TT.E
+ END IF;
+
+-- MAKE SURE ALL TASKS TERMINATED
+ TERM (RT1.TT, '1');
+ TERM (RT2.TT, '2');
+ TERM (RRT1.RR.TT, '3');
+ TERM (RRT2.RR.TT, '4');
+ TERM (AT1(1), '5');
+ TERM (AT2(1), '6');
+ TERM (AT1(2), '7');
+ TERM (AT2(2), '8');
+ TERM (ART1(1).TT, '9');
+ TERM (ART2(1).TT, 'A');
+ TERM (ART1(2).TT, 'B');
+ TERM (ART2(2).TT, 'C');
+
+ RESULT;
+
+END C64201C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c64202a.ada b/gcc/testsuite/ada/acats/tests/c6/c64202a.ada
new file mode 100644
index 000000000..3c4af8ef9
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c64202a.ada
@@ -0,0 +1,72 @@
+-- C64202A.ADA
+
+-- 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.
+--*
+-- CHECK THAT THE DEFAULT EXPRESSIONS OF FORMAL PARAMETERS ARE EVALUATED
+-- EACH TIME THEY ARE NEEDED.
+
+-- SPS 2/22/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C64202A IS
+BEGIN
+
+ TEST ("C64202A", "CHECK THAT THE DEFAULT EXPRESSION IS EVALUATED" &
+ " EACH TIME IT IS NEEDED");
+
+ DECLARE
+ X : INTEGER := 1;
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ X := X + 1;
+ RETURN X;
+ END F;
+
+ PROCEDURE P (CALL : POSITIVE; X, Y : INTEGER := F) IS
+ BEGIN
+ IF CALL = 1 THEN
+ IF X = Y OR Y /= 2 THEN
+ FAILED ("DEFAULT NOT EVALUATED CORRECTLY - 1" &
+ " X =" & INTEGER'IMAGE(X) & " Y =" &
+ INTEGER'IMAGE(Y));
+ END IF;
+ ELSIF CALL = 2 THEN
+ IF X = Y OR
+ NOT ((X = 3 AND Y = 4) OR (X = 4 AND Y = 3)) THEN
+ FAILED ("DEFAULT NOT EVALUATED CORRECTLY - 2" &
+ " X =" & INTEGER'IMAGE(X) & " Y =" &
+ INTEGER'IMAGE(Y));
+ END IF;
+ END IF;
+ END P;
+
+ BEGIN
+ COMMENT ("FIRST CALL");
+ P (1, 3);
+ COMMENT ("SECOND CALL");
+ P(2);
+ END;
+
+ RESULT;
+
+END C64202A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c650001.a b/gcc/testsuite/ada/acats/tests/c6/c650001.a
new file mode 100644
index 000000000..595e81dad
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c650001.a
@@ -0,0 +1,412 @@
+-- C650001.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 a function result type that is a return-by-reference
+-- type, Program_Error is raised if the return expression is a name that
+-- denotes an object view whose accessibility level is deeper than that
+-- of the master that elaborated the function body.
+--
+-- Check for cases where the result type is:
+-- (a) A tagged limited type.
+-- (b) A task type.
+-- (c) A protected type.
+-- (d) A composite type with a subcomponent of a
+-- return-by-reference type (task type).
+--
+-- TEST DESCRIPTION:
+-- The accessibility level of the master that elaborates the body of a
+-- return-by-reference function will always be less deep than that of
+-- the function (which is itself a master).
+--
+-- Thus, the return object may not be any of the following, since each
+-- has an accessibility level at least as deep as that of the function:
+--
+-- (1) An object declared local to the function.
+-- (2) The result of a local function.
+-- (3) A parameter of the function.
+--
+-- Verify that Program_Error is raised within the return-by-reference
+-- function if the return object is any of (1)-(3) above, for various
+-- subsets of the return types (a)-(d) above. Include cases where (1)-(3)
+-- are operands of parenthesized expressions.
+--
+-- Verify that no exception is raised if the return object is any of the
+-- following:
+--
+-- (4) An object declared at a less deep level than that of the
+-- master that elaborated the function body.
+-- (5) The result of a function declared at the same level as the
+-- original function (assuming the new function is also legal).
+-- (6) A parameter of the master that elaborated the function body.
+--
+-- For (5), pass the new function as an actual via an access-to-
+-- subprogram parameter of the original function. Check for cases where
+-- the new function does and does not raise an exception.
+--
+-- Since the functions to be tested cannot be part of an assignment
+-- statement (since they return values of a limited type), pass each
+-- function result as an actual parameter to a dummy procedure, e.g.,
+--
+-- Dummy_Proc ( Function_Call );
+--
+--
+-- CHANGE HISTORY:
+-- 03 May 95 SAIC Initial prerelease version.
+-- 08 Feb 99 RLB Removed subcase with two errors.
+--
+--!
+
+package C650001_0 is
+
+ type Tagged_Limited is tagged limited record
+ C: String (1 .. 10);
+ end record;
+
+ task type Task_Type;
+
+ protected type Protected_Type is
+ procedure Op;
+ end Protected_Type;
+
+ type Task_Array is array (1 .. 10) of Task_Type;
+
+ type Variant_Record (Toggle: Boolean) is record
+ case Toggle is
+ when True =>
+ T: Task_Type; -- Return-by-reference component.
+ when False =>
+ I: Integer; -- Non-return-by-reference component.
+ end case;
+ end record;
+
+ -- Limited type even though variant contains no limited components:
+ type Non_Task_Variant is new Variant_Record (Toggle => False);
+
+end C650001_0;
+
+
+ --==================================================================--
+
+
+package body C650001_0 is
+
+ task body Task_Type is
+ begin
+ null;
+ end Task_Type;
+
+ protected body Protected_Type is
+ procedure Op is
+ begin
+ null;
+ end Op;
+ end Protected_Type;
+
+end C650001_0;
+
+
+ --==================================================================--
+
+
+with C650001_0;
+package C650001_1 is
+
+ type TC_Result_Kind is (OK, P_E, O_E);
+
+ procedure TC_Display_Results (Actual : in TC_Result_Kind;
+ Expected: in TC_Result_Kind;
+ Message : in String);
+
+ -- Dummy procedures:
+
+ procedure Check_Tagged (P: C650001_0.Tagged_Limited);
+ procedure Check_Task (P: C650001_0.Task_Type);
+ procedure Check_Protected (P: C650001_0.Protected_Type);
+ procedure Check_Composite (P: C650001_0.Non_Task_Variant);
+
+end C650001_1;
+
+
+ --==================================================================--
+
+
+with Report;
+package body C650001_1 is
+
+ procedure TC_Display_Results (Actual : in TC_Result_Kind;
+ Expected: in TC_Result_Kind;
+ Message : in String) is
+ begin
+ if Actual /= Expected then
+ case Actual is
+ when OK =>
+ Report.Failed ("No exception raised: " & Message);
+ when P_E =>
+ Report.Failed ("Program_Error raised: " & Message);
+ when O_E =>
+ Report.Failed ("Unexpected exception raised: " & Message);
+ end case;
+ end if;
+ end TC_Display_Results;
+
+
+ procedure Check_Tagged (P: C650001_0.Tagged_Limited) is
+ begin
+ null;
+ end;
+
+ procedure Check_Task (P: C650001_0.Task_Type) is
+ begin
+ null;
+ end;
+
+ procedure Check_Protected (P: C650001_0.Protected_Type) is
+ begin
+ null;
+ end;
+
+ procedure Check_Composite (P: C650001_0.Non_Task_Variant) is
+ begin
+ null;
+ end;
+
+end C650001_1;
+
+
+
+ --==================================================================--
+
+
+with C650001_0;
+with C650001_1;
+
+with Report;
+procedure C650001 is
+begin
+
+ Report.Test ("C650001", "Check that, for a function result type that " &
+ "is a return-by-reference type, Program_Error is raised " &
+ "if the return expression is a name that denotes an " &
+ "object view whose accessibility level is deeper than " &
+ "that of the master that elaborated the function body");
+
+
+
+ SUBTEST1:
+ declare
+
+ Result: C650001_1.TC_Result_Kind;
+ PO : C650001_0.Protected_Type;
+
+ function Return_Prot (P: C650001_0.Protected_Type)
+ return C650001_0.Protected_Type is
+ begin
+ Result := C650001_1.OK;
+ return P; -- Formal parameter (3).
+ exception
+ when Program_Error =>
+ Result := C650001_1.P_E; -- Expected result.
+ return PO;
+ when others =>
+ Result := C650001_1.O_E;
+ return PO;
+ end Return_Prot;
+
+ begin -- SUBTEST1.
+ C650001_1.Check_Protected ( Return_Prot(PO) );
+ C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #1");
+ exception
+ when others =>
+ Report.Failed ("SUBTEST #1: Unexpected exception in outer block");
+ end SUBTEST1;
+
+
+
+ SUBTEST2:
+ declare
+
+ Result: C650001_1.TC_Result_Kind;
+ Comp : C650001_0.Non_Task_Variant;
+
+ function Return_Composite return C650001_0.Non_Task_Variant is
+ Local: C650001_0.Non_Task_Variant;
+ begin
+ Result := C650001_1.OK;
+ return (Local); -- Parenthesized local object (1).
+ exception
+ when Program_Error =>
+ Result := C650001_1.P_E; -- Expected result.
+ return Comp;
+ when others =>
+ Result := C650001_1.O_E;
+ return Comp;
+ end Return_Composite;
+
+ begin -- SUBTEST2.
+ C650001_1.Check_Composite ( Return_Composite );
+ C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #2");
+ exception
+ when others =>
+ Report.Failed ("SUBTEST #2: Unexpected exception in outer block");
+ end SUBTEST2;
+
+
+
+ SUBTEST3:
+ declare
+
+ Result: C650001_1.TC_Result_Kind;
+ Tsk : C650001_0.Task_Type;
+ TskArr: C650001_0.Task_Array;
+
+ function Return_Task (P: C650001_0.Task_Array)
+ return C650001_0.Task_Type is
+
+ function Inner return C650001_0.Task_Type is
+ begin
+ return P(P'First); -- OK: should not raise exception (6).
+ exception
+ when Program_Error =>
+ Report.Failed ("SUBTEST #3: Program_Error incorrectly " &
+ "raised within function Inner");
+ return Tsk;
+ when others =>
+ Report.Failed ("SUBTEST #3: Unexpected exception " &
+ "raised within function Inner");
+ return Tsk;
+ end Inner;
+
+ begin -- Return_Task.
+ Result := C650001_1.OK;
+ return Inner; -- Call to local function (2).
+ exception
+ when Program_Error =>
+ Result := C650001_1.P_E; -- Expected result.
+ return Tsk;
+ when others =>
+ Result := C650001_1.O_E;
+ return Tsk;
+ end Return_Task;
+
+ begin -- SUBTEST3.
+ C650001_1.Check_Task ( Return_Task(TskArr) );
+ C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #3");
+ exception
+ when others =>
+ Report.Failed ("SUBTEST #3: Unexpected exception in outer block");
+ end SUBTEST3;
+
+
+
+ SUBTEST4:
+ declare
+
+ Result: C650001_1.TC_Result_Kind;
+ TagLim: C650001_0.Tagged_Limited;
+
+ function Return_TagLim (P: C650001_0.Tagged_Limited'Class)
+ return C650001_0.Tagged_Limited is
+ begin
+ Result := C650001_1.OK;
+ return C650001_0.Tagged_Limited(P); -- Conversion of formal param (3).
+ exception
+ when Program_Error =>
+ Result := C650001_1.P_E; -- Expected result.
+ return TagLim;
+ when others =>
+ Result := C650001_1.O_E;
+ return TagLim;
+ end Return_TagLim;
+
+ begin -- SUBTEST4.
+ C650001_1.Check_Tagged ( Return_TagLim(TagLim) );
+ C650001_1.TC_Display_Results (Result, C650001_1.P_E,
+ "SUBTEST #4 (root type)");
+ exception
+ when others =>
+ Report.Failed ("SUBTEST #4: Unexpected exception in outer block");
+ end SUBTEST4;
+
+
+
+ SUBTEST5:
+ declare
+ Tsk : C650001_0.Task_Type;
+ begin -- SUBTEST5.
+
+ declare
+ Result: C650001_1.TC_Result_Kind;
+
+ type AccToFunc is access function return C650001_0.Task_Type;
+
+ function Return_Global return C650001_0.Task_Type is
+ begin
+ return Tsk; -- OK: should not raise exception (4).
+ end Return_Global;
+
+ function Return_Local return C650001_0.Task_Type is
+ Local : C650001_0.Task_Type;
+ begin
+ return Local; -- Propagate Program_Error.
+ end Return_Local;
+
+
+ function Return_Func (P: AccToFunc) return C650001_0.Task_Type is
+ begin
+ Result := C650001_1.OK;
+ return P.all; -- Function call (5).
+ exception
+ when Program_Error =>
+ Result := C650001_1.P_E;
+ return Tsk;
+ when others =>
+ Result := C650001_1.O_E;
+ return Tsk;
+ end Return_Func;
+
+ RG : AccToFunc := Return_Global'Access;
+ RL : AccToFunc := Return_Local'Access;
+
+ begin
+ C650001_1.Check_Task ( Return_Func(RG) );
+ C650001_1.TC_Display_Results (Result, C650001_1.OK,
+ "SUBTEST #5 (global task)");
+
+ C650001_1.Check_Task ( Return_Func(RL) );
+ C650001_1.TC_Display_Results (Result, C650001_1.P_E,
+ "SUBTEST #5 (local task)");
+ exception
+ when others =>
+ Report.Failed ("SUBTEST #5: Unexpected exception in outer block");
+ end;
+
+ end SUBTEST5;
+
+
+
+ Report.Result;
+
+end C650001;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c65003a.ada b/gcc/testsuite/ada/acats/tests/c6/c65003a.ada
new file mode 100644
index 000000000..49cd2b55e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c65003a.ada
@@ -0,0 +1,100 @@
+-- C65003A.ADA
+
+-- 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.
+--*
+-- CHECK THAT IF NO RETURN STATEMENT IS EXECUTED, A FUNCTION RAISES
+-- PROGRAM_ERROR. DETERMINE WHERE THE EXCEPTION IS RAISED.
+
+-- THIS LACK OF AN EXECUTABLE RETURN IS DETECTABLE AT COMPILE TIME IN
+-- THIS TEST.
+
+-- JBG 10/14/83
+-- SPS 2/22/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C65003A IS
+
+ EXCEPTION_RAISED : BOOLEAN := FALSE;
+ FUNCTION RETURN_IN_EXCEPTION RETURN INTEGER IS
+ BEGIN
+ IF FALSE THEN
+ RETURN 5;
+ END IF;
+ EXCEPTION
+ WHEN PROGRAM_ERROR =>
+ COMMENT ("PROGRAM_ERROR RAISED IN FUNCTION BODY - " &
+ "RETURN_IN_EXCEPTION");
+ EXCEPTION_RAISED := TRUE;
+ RETURN 5;
+ END RETURN_IN_EXCEPTION;
+
+ FUNCTION NO_RETURN RETURN INTEGER IS
+ NO_RETURN_EXCEPTION : EXCEPTION;
+ BEGIN
+ RAISE NO_RETURN_EXCEPTION;
+ RETURN 5;
+ EXCEPTION
+ WHEN NO_RETURN_EXCEPTION =>
+ NULL;
+ END NO_RETURN;
+
+BEGIN
+
+ TEST ("C65003A", "CHECK THAT PROGRAM_ERROR IS RAISED IF A " &
+ "FUNCTION RETURNS WITHOUT EXECUTING A RETURN " &
+ "STATEMENT");
+
+ BEGIN
+
+ IF RETURN_IN_EXCEPTION = RETURN_IN_EXCEPTION THEN
+ IF NOT EXCEPTION_RAISED THEN
+ FAILED ("PROGRAM_ERROR NOT RAISED - " &
+ "RETURN_IN_EXCEPTION");
+ END IF;
+ END IF;
+
+ EXCEPTION
+
+ WHEN PROGRAM_ERROR =>
+ COMMENT ("PROGRAM_ERROR RAISED AT POINT OF CALL " &
+ "- RETURN_IN_EXCEPTION");
+
+ END;
+
+
+ BEGIN
+
+ IF NO_RETURN = NO_RETURN THEN
+ FAILED ("PROGRAM_ERROR NOT RAISED - NO_RETURN");
+ END IF;
+
+ EXCEPTION
+
+ WHEN PROGRAM_ERROR =>
+ COMMENT ("PROGRAM_ERROR RAISED WHEN NO RETURN IN " &
+ "EXCEPTION HANDLER");
+ END;
+
+ RESULT;
+
+END C65003A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c65003b.ada b/gcc/testsuite/ada/acats/tests/c6/c65003b.ada
new file mode 100644
index 000000000..d93d1b480
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c65003b.ada
@@ -0,0 +1,73 @@
+-- C65003B.ADA
+
+-- 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.
+--*
+-- CHECK THAT IF NO RETURN STATEMENT IS EXECUTED, A FUNCTION RAISES
+-- PROGRAM_ERROR. DETERMINE WHERE THE EXCEPTION IS RAISED.
+
+-- THIS LACK OF AN EXECUTABLE RETURN IS NOT DETECTABLE AT COMPILE TIME.
+
+-- JBG 10/14/83
+-- SPS 2/22/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C65003B IS
+
+ EXCEPTION_RAISED : BOOLEAN := FALSE;
+
+ FUNCTION RETURN_IN_EXCEPTION RETURN INTEGER IS
+ BEGIN
+ WHILE NOT EQUAL (1, 1) LOOP
+ RETURN 5;
+ END LOOP;
+ EXCEPTION
+ WHEN PROGRAM_ERROR =>
+ COMMENT ("PROGRAM_ERROR RAISED IN FUNCTION BODY");
+ EXCEPTION_RAISED := TRUE;
+ RETURN 5;
+ END RETURN_IN_EXCEPTION;
+
+BEGIN
+
+ TEST ("C65003B", "CHECK THAT PROGRAM_ERROR IS RAISED IF A " &
+ "FUNCTION RETURNS WITHOUT EXECUTING A RETURN " &
+ "STATEMENT");
+
+ BEGIN
+
+ IF RETURN_IN_EXCEPTION = RETURN_IN_EXCEPTION THEN
+ IF NOT EXCEPTION_RAISED THEN
+ FAILED ("PROGRAM_ERROR NOT RAISED");
+ END IF;
+ END IF;
+
+ EXCEPTION
+
+ WHEN PROGRAM_ERROR =>
+ COMMENT ("PROGRAM_ERROR RAISED AT POINT OF CALL");
+
+ END;
+
+ RESULT;
+
+END C65003B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002a.ada b/gcc/testsuite/ada/acats/tests/c6/c66002a.ada
new file mode 100644
index 000000000..8afec993a
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c66002a.ada
@@ -0,0 +1,104 @@
+-- C66002A.ADA
+
+-- 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.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (A) ONE SUBPROGRAM IS A FUNCTION; THE OTHER IS A PROCEDURE.
+
+-- CVP 5/4/81
+-- JRK 5/8/81
+-- NL 10/13/81
+-- SPS 11/2/82
+
+WITH REPORT;
+PROCEDURE C66002A IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C66002A", "SUBPROGRAM OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES ALLOWED");
+
+ --------------------------------------------------
+
+ -- ONE SUBPROGRAM IS A PROCEDURE; THE OTHER IS
+ -- A FUNCTION. BOTH PARAMETERIZED AND PARAMETERLESS
+ -- SUBPROGRAMS ARE TESTED.
+
+ DECLARE
+ I, J, K : INTEGER := 0;
+ S : STRING (1..2) := "12";
+
+ PROCEDURE P1 (I1, I2 : INTEGER) IS
+ BEGIN
+ S(1) := 'A';
+ END P1;
+
+ FUNCTION P1 (I1, I2 : INTEGER) RETURN INTEGER IS
+ BEGIN
+ S(2) := 'B';
+ RETURN I1; -- RETURNED VALUE IS IRRELEVENT.
+ END P1;
+
+ PROCEDURE P2 IS
+ BEGIN
+ S(1) := 'C';
+ END P2;
+
+ FUNCTION P2 RETURN INTEGER IS
+ BEGIN
+ S(2) := 'D';
+ RETURN I; -- RETURNED VALUE IS IRRELEVENT.
+ END P2;
+
+ BEGIN
+ P1 (I, J);
+ K := P1 (I, J);
+
+ IF S /= "AB" THEN
+ FAILED ("PARAMETERIZED OVERLOADED " &
+ "SUBPROGRAMS, ONE A PROCEDURE AND " &
+ "THE OTHER A FUNCTION, CAUSED " &
+ "CONFUSION");
+ END IF;
+
+ S := "12";
+ P2;
+ K := P2 ;
+
+ IF S /= "CD" THEN
+ FAILED ("PARAMETERLESS OVERLOADED " &
+ "SUBPROGRAMS, ONE A PROCEDURE AND " &
+ "THE OTHER A FUNCTION, CAUSED " &
+ "CONFUSION");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C66002A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002c.ada b/gcc/testsuite/ada/acats/tests/c6/c66002c.ada
new file mode 100644
index 000000000..d646f0603
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c66002c.ada
@@ -0,0 +1,102 @@
+-- C66002C.ADA
+
+-- 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.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (C) ONE SUBPROGRAM HAS ONE LESS PARAMETER THAN THE OTHER.
+
+-- CVP 5/4/81
+-- JRK 5/8/81
+-- NL 10/13/81
+
+WITH REPORT;
+PROCEDURE C66002C IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C66002C", "SUBPROGRAM OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES ALLOWED");
+
+ --------------------------------------------------
+
+ -- ONE PROCEDURE HAS ONE MORE PARAMETER
+ -- THAN THE OTHER. THIS IS TESTED IN THE
+ -- CASE IN WHICH THAT PARAMETER HAS A DEFAULT
+ -- VALUE, AND THE CASE IN WHICH IT DOES NOT.
+
+ DECLARE
+ I, J : INTEGER := 0;
+ B : BOOLEAN := TRUE;
+ S : STRING (1..2) := "12";
+
+ PROCEDURE P1 (I1, I2 : INTEGER; B1 : IN OUT BOOLEAN) IS
+ BEGIN
+ S(1) := 'A';
+ END P1;
+
+ PROCEDURE P1 (I1, I2 : INTEGER) IS
+ BEGIN
+ S(2) := 'B';
+ END P1;
+
+ PROCEDURE P2 (B1 : IN OUT BOOLEAN; I1 : INTEGER := 0) IS
+ BEGIN
+ S(1) := 'C';
+ END P2;
+
+ PROCEDURE P2 (B1 : IN OUT BOOLEAN) IS
+ BEGIN
+ S(2) := 'D';
+ END P2;
+
+ BEGIN
+ P1 (I, J, B);
+ P1 (I, J);
+
+ IF S /= "AB" THEN
+ FAILED ("PROCEDURES DIFFERING ONLY IN " &
+ "NUMBER OF PARAMETERS (NO DEFAULTS) " &
+ "CAUSED CONFUSION");
+ END IF;
+
+ S := "12";
+ P2 (B, I);
+ -- NOTE THAT A CALL TO P2 WITH ONLY
+ -- ONE PARAMETER IS AMBIGUOUS.
+
+ IF S /= "C2" THEN
+ FAILED ("PROCEDURES DIFFERING ONLY IN " &
+ "EXISTENCE OF ONE PARAMETER (WITH " &
+ "DEFAULT) CAUSED CONFUSION");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C66002C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002d.ada b/gcc/testsuite/ada/acats/tests/c6/c66002d.ada
new file mode 100644
index 000000000..fe4209894
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c66002d.ada
@@ -0,0 +1,85 @@
+-- C66002D.ADA
+
+-- 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.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (D) THE BASE TYPE OF A PARAMETER IS DIFFERENT FROM THAT
+-- OF THE CORRESPONDING ONE.
+
+-- CVP 5/4/81
+-- JRK 5/8/81
+-- NL 10/13/81
+
+WITH REPORT;
+PROCEDURE C66002D IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C66002D", "SUBPROGRAM OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES ALLOWED");
+
+ --------------------------------------------------
+
+ -- THE BASE TYPE OF ONE PARAMETER IS
+ -- DIFFERENT FROM THAT OF THE CORRESPONDING
+ -- ONE.
+
+ DECLARE
+ I, J, K : INTEGER := 0;
+ B : BOOLEAN;
+ S : STRING (1..2) := "12";
+
+ PROCEDURE P (I1 : INTEGER; BI : OUT BOOLEAN;
+ I2 : IN OUT INTEGER) IS
+ BEGIN
+ S(1) := 'A';
+ BI := TRUE; -- THIS VALUE IS IRRELEVENT.
+ END P;
+
+ PROCEDURE P (I1 : INTEGER; BI : OUT INTEGER;
+ I2 : IN OUT INTEGER) IS
+ BEGIN
+ S(2) := 'B';
+ BI := 0; -- THIS VALUE IS IRRELEVENT.
+ END P;
+
+ BEGIN
+ P (I, B, K);
+ P (I, J, K);
+
+ IF S /= "AB" THEN
+ FAILED ("PROCEDURES DIFFERING ONLY BY " &
+ "THE BASE TYPE OF A PARAMETER " &
+ "CAUSED CONFUSION");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C66002D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002e.ada b/gcc/testsuite/ada/acats/tests/c6/c66002e.ada
new file mode 100644
index 000000000..d2b509639
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c66002e.ada
@@ -0,0 +1,91 @@
+-- C66002E.ADA
+
+-- 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.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (E) ONE SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE
+-- PART, THE OTHER IN AN INNER PART, AND THE PARAMETERS ARE
+-- ORDERED DIFFERENTLY.
+
+-- CVP 5/4/81
+-- JRK 5/8/81
+-- NL 10/13/81
+
+WITH REPORT;
+PROCEDURE C66002E IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C66002E", "SUBPROGRAM OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES ALLOWED");
+
+ --------------------------------------------------
+
+ -- ONE SUBPROGRAM IS DECLARED IN AN OUTER
+ -- DECLARATIVE PART, THE OTHER IN AN INNER
+ -- PART, AND THE PARAMETERS ARE ORDERED
+ -- DIFFERENTLY.
+
+ DECLARE
+ S : STRING (1..2) := "12";
+
+ PROCEDURE P (I1 : INTEGER; I2 : IN OUT INTEGER;
+ B1 : BOOLEAN) IS
+ BEGIN
+ S(1) := 'A';
+ END P;
+
+ BEGIN
+ DECLARE
+ I : INTEGER := 0;
+
+ PROCEDURE P (B1 : BOOLEAN; I1 : INTEGER;
+ I2 : IN OUT INTEGER) IS
+ BEGIN
+ S(2) := 'B';
+ END P;
+
+ BEGIN
+ P (5, I, TRUE);
+ P (TRUE, 5, I);
+ -- NOTE THAT A CALL IN WHICH ALL ACTUAL PARAMETERS
+ -- ARE NAMED_ASSOCIATIONS IS AMBIGUOUS.
+
+ IF S /= "AB" THEN
+ FAILED ("PROCEDURES IN " &
+ "ENCLOSING-ENCLOSED SCOPES " &
+ "DIFFERING ONLY IN PARAMETER " &
+ "TYPE ORDER CAUSED CONFUSION");
+ END IF;
+ END;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C66002E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002f.ada b/gcc/testsuite/ada/acats/tests/c6/c66002f.ada
new file mode 100644
index 000000000..a62897786
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c66002f.ada
@@ -0,0 +1,92 @@
+-- C66002F.ADA
+
+-- 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.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (F) ONE SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE PART,
+-- THE OTHER IN AN INNER PART, AND ONE HAS ONE MORE PARAMETER
+-- THAN THE OTHER; THE OMITTED PARAMETER HAS A DEFAULT VALUE.
+
+-- CVP 5/4/81
+-- JRK 5/8/81
+-- NL 10/13/81
+
+WITH REPORT;
+PROCEDURE C66002F IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C66002F", "SUBPROGRAM OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES ALLOWED");
+
+ --------------------------------------------------
+
+ -- ONE SUBPROGRAM IS IN AN OUTER DECLARATIVE
+ -- PART, THE OTHER IN AN INNER PART, AND ONE
+ -- HAS ONE MORE PARAMETER (WITH A DEFAULT
+ -- VALUE) THAN THE OTHER.
+
+ BF :
+ DECLARE
+ S : STRING (1..3) := "123";
+
+ PROCEDURE P (I1, I2, I3 : INTEGER := 1) IS
+ C : CONSTANT STRING := "CXA";
+ BEGIN
+ S(I3) := C(I3);
+ END P;
+
+ PROCEDURE ENCLOSE IS
+
+ PROCEDURE P (I1, I2 : INTEGER := 1) IS
+ BEGIN
+ S(2) := 'B';
+ END P;
+
+ BEGIN -- ENCLOSE
+ P (1, 2, 3);
+ ENCLOSE.P (1, 2); -- NOTE THAT THESE CALLS
+ BF.P (1, 2); -- MUST BE DISAMBIGUATED.
+
+ IF S /= "CBA" THEN
+ FAILED ("PROCEDURES IN ENCLOSING-" &
+ "ENCLOSED SCOPES DIFFERING " &
+ "ONLY IN EXISTENCE OF ONE " &
+ "DEFAULT-VALUED PARAMETER CAUSED " &
+ "CONFUSION");
+ END IF;
+ END ENCLOSE;
+
+ BEGIN
+ ENCLOSE;
+ END BF;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C66002F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c66002g.ada b/gcc/testsuite/ada/acats/tests/c6/c66002g.ada
new file mode 100644
index 000000000..06c6ea33d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c66002g.ada
@@ -0,0 +1,82 @@
+-- C66002G.ADA
+
+-- 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.
+--*
+-- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS
+-- ARE PERMITTED IN WHICH THERE IS A MINIMAL
+-- DIFFERENCE BETWEEN THE DECLARATIONS.
+
+-- (G) THE RESULT TYPE OF TWO FUNCTION DECLARATIONS IS DIFFERENT.
+
+-- CVP 5/4/81
+-- JRK 5/8/81
+-- NL 10/13/81
+-- SPS 10/26/82
+
+WITH REPORT;
+PROCEDURE C66002G IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C66002G", "SUBPROGRAM OVERLOADING WITH " &
+ "MINIMAL DIFFERENCES ALLOWED");
+
+ --------------------------------------------------
+
+ -- THE RESULT TYPES OF TWO FUNCTION
+ -- DECLARATIONS ARE DIFFERENT.
+
+ DECLARE
+ I : INTEGER;
+ B : BOOLEAN;
+ S : STRING (1..2) := "12";
+
+ FUNCTION F RETURN INTEGER IS
+ BEGIN
+ S(1) := 'A';
+ RETURN IDENT_INT (0); -- THIS VALUE IS IRRELEVENT.
+ END F;
+
+ FUNCTION F RETURN BOOLEAN IS
+ BEGIN
+ S(2) := 'B';
+ RETURN IDENT_BOOL (TRUE); -- THIS VALUE IS IRRELEVANT.
+ END F;
+
+ BEGIN
+ I := F;
+ B := F;
+
+ IF S /= "AB" THEN
+ FAILED ("FUNCTIONS DIFFERING ONLY IN " &
+ "BASE TYPE OF RETURNED VALUE " &
+ "CAUSED CONFUSION");
+ END IF;
+ END;
+
+ --------------------------------------------------
+
+ RESULT;
+
+END C66002G;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002a.ada b/gcc/testsuite/ada/acats/tests/c6/c67002a.ada
new file mode 100644
index 000000000..da295994e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67002a.ada
@@ -0,0 +1,426 @@
+-- C67002A.ADA
+
+-- 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.
+--*
+-- CHECK THAT ALL OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
+-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
+-- SUBTESTS ARE:
+-- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
+-- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
+-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
+-- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
+-- WITH ONE PARAMETER.
+
+-- CVP 5/7/81
+-- JRK 6/1/81
+-- CPP 6/25/84
+
+WITH REPORT;
+PROCEDURE C67002A IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C67002A", "USE OF OPERATOR SYMBOLS IN " &
+ "(OVERLOADED) FUNCTION SPECIFICATIONS");
+
+ -------------------------------------------------
+
+ DECLARE -- (A)
+ PACKAGE EQU IS
+ TYPE LP IS LIMITED PRIVATE;
+ FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
+ PRIVATE
+ TYPE LP IS NEW INTEGER;
+ END EQU;
+ USE EQU;
+
+ LP1, LP2 : LP;
+
+ PACKAGE BODY EQU IS
+ FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
+ BEGIN
+ RETURN LPA > LPB;
+ END "=";
+ BEGIN
+ LP1 := LP (IDENT_INT (7));
+ LP2 := LP (IDENT_INT (8));
+ END EQU;
+
+ BEGIN -- (A)
+ IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
+ (LP1 = LP1) OR (LP2 /= LP1) THEN
+ FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (A)
+
+ -------------------------------------------------
+
+ DECLARE -- (B)
+ FUNCTION "AND" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "AND";
+
+ BEGIN -- (B)
+ IF (IDENT_INT (10) AND 1) /= 'G' OR
+ (5 AND 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (B)
+
+ -------------------------------------------------
+
+ DECLARE -- (C)
+ FUNCTION "OR" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "OR";
+
+ BEGIN -- (C)
+ IF (IDENT_INT (10) OR 1) /= 'G' OR
+ (5 OR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (C)
+
+ -------------------------------------------------
+
+ DECLARE -- (D)
+ FUNCTION "XOR" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "XOR";
+
+ BEGIN -- (D)
+ IF (IDENT_INT (10) XOR 1) /= 'G' OR
+ (5 XOR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (D)
+
+ -------------------------------------------------
+
+ DECLARE -- (E)
+ FUNCTION "<" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "<";
+
+ BEGIN -- (E)
+ IF (IDENT_INT (10) < 1) /= 'G' OR
+ (5 < 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (E)
+
+ -------------------------------------------------
+
+ DECLARE -- (F)
+ FUNCTION "<=" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "<=";
+
+ BEGIN -- (F)
+ IF (IDENT_INT (10) <= 1) /= 'G' OR
+ (5 <= 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (F)
+
+ -------------------------------------------------
+
+ DECLARE -- (G)
+ FUNCTION ">" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END ">";
+
+ BEGIN -- (G)
+ IF (IDENT_INT (10) > 1) /= 'G' OR
+ (5 > 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (G)
+
+ -------------------------------------------------
+
+ DECLARE -- (H)
+ FUNCTION ">=" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END ">=";
+
+ BEGIN -- (H)
+ IF (IDENT_INT (10) >= 1) /= 'G' OR
+ (5 >= 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (H)
+
+ -------------------------------------------------
+
+ DECLARE -- (I)
+ FUNCTION "&" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "&";
+
+ BEGIN -- (I)
+ IF (IDENT_INT (10) & 1) /= 'G' OR
+ (5 & 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (I)
+
+ -------------------------------------------------
+
+ DECLARE -- (J)
+ FUNCTION "*" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "*";
+
+ BEGIN -- (J)
+ IF (IDENT_INT (10) * 1) /= 'G' OR
+ (5 * 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (J)
+
+ -------------------------------------------------
+
+ DECLARE -- (K)
+ FUNCTION "/" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "/";
+
+ BEGIN -- (K)
+ IF (IDENT_INT (10) / 1) /= 'G' OR
+ (5 / 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (K)
+
+ -------------------------------------------------
+
+ DECLARE -- (L)
+ FUNCTION "MOD" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "MOD";
+
+ BEGIN -- (L)
+ IF (IDENT_INT (10) MOD 1) /= 'G' OR
+ (5 MOD 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (L)
+
+ -------------------------------------------------
+
+ DECLARE -- (M)
+ FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "REM";
+
+ BEGIN -- (M)
+ IF (IDENT_INT (10) REM 1) /= 'G' OR
+ (5 REM 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (M)
+
+ -------------------------------------------------
+
+ DECLARE -- (N)
+ FUNCTION "**" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "**";
+
+ BEGIN -- (N)
+ IF (IDENT_INT (10) ** 1) /= 'G' OR
+ (5 ** 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (N)
+
+ -------------------------------------------------
+
+ DECLARE -- (O)
+ FUNCTION "+" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "+";
+
+ BEGIN -- (O)
+ IF (IDENT_INT (10) + 1) /= 'G' OR
+ (5 + 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (O)
+
+ -------------------------------------------------
+
+ DECLARE -- (P)
+ FUNCTION "-" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "-";
+
+ BEGIN -- (P)
+ IF (IDENT_INT (10) - 1) /= 'G' OR
+ (5 - 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (P)
+
+ -------------------------------------------------
+
+ DECLARE -- (Q)
+ FUNCTION "+" (I1 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < IDENT_INT (0) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END "+";
+
+ BEGIN -- (Q)
+ IF (+ IDENT_INT(25) /= 'P') OR
+ (+ (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""+"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (Q)
+
+ -------------------------------------------------
+
+ DECLARE -- (R)
+ FUNCTION "-" (I1 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < IDENT_INT (0) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END "-";
+
+ BEGIN -- (R)
+ IF (- IDENT_INT(25) /= 'P') OR
+ (- (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""-"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (R)
+
+ -------------------------------------------------
+
+ DECLARE -- (S)
+ FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < IDENT_INT (0) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END "NOT";
+
+ BEGIN -- (S)
+ IF (NOT IDENT_INT(25) /= 'P') OR
+ (NOT (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""NOT"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (S)
+
+ -------------------------------------------------
+
+ DECLARE -- (T)
+ FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < IDENT_INT (0) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END "ABS";
+
+ BEGIN -- (T)
+ IF (ABS IDENT_INT(25) /= 'P') OR
+ (ABS (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""ABS"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (T)
+
+ -------------------------------------------------
+
+ RESULT;
+END C67002A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002b.ada b/gcc/testsuite/ada/acats/tests/c6/c67002b.ada
new file mode 100644
index 000000000..d716fb33e
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67002b.ada
@@ -0,0 +1,176 @@
+-- C67002B.ADA
+
+-- 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.
+--*
+-- CHECK THAT OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
+-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
+-- THIS TEST CHECKS THE CASE OF CERTAIN OPERATOR SYMBOLS.
+-- SUBTESTS ARE:
+-- (A) THROUGH (E): "AND", "OR", "XOR", "MOD", "REM"
+-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
+-- (F) AND (G): "NOT" AND "ABS", RESPECTIVELY,
+-- WITH ONE PARAMETER.
+
+-- CPP 6/26/84
+
+WITH REPORT;
+PROCEDURE C67002B IS
+
+ USE REPORT;
+
+BEGIN
+ TEST ("C67002B", "USE OF OPERATOR SYMBOLS IN " &
+ "(OVERLOADED) FUNCTION SPECIFICATIONS");
+
+ -------------------------------------------------
+
+ DECLARE -- (A)
+ FUNCTION "And" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "And";
+
+ BEGIN -- (A)
+ IF (IDENT_INT (10) AND 1) /= 'G' OR
+ (5 AnD 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""And"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (A)
+
+ -------------------------------------------------
+
+ DECLARE -- (B)
+ FUNCTION "or" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "or";
+
+ BEGIN -- (B)
+ IF (IDENT_INT (10) Or 1) /= 'G' OR
+ (5 OR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""or"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (B)
+
+ -------------------------------------------------
+
+ DECLARE -- (C)
+ FUNCTION "xOR" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "xOR";
+
+ BEGIN -- (C)
+ IF (IDENT_INT (10) XoR 1) /= 'G' OR
+ (5 xOR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""xOR"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (C)
+
+ -------------------------------------------------
+
+ DECLARE -- (D)
+ FUNCTION "mOd" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "mOd";
+
+ BEGIN -- (D)
+ IF (IDENT_INT (10) MoD 1) /= 'G' OR
+ (5 moD 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""mOd"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (D)
+
+ -------------------------------------------------
+
+ DECLARE -- (E)
+ FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END "REM";
+
+ BEGIN -- (E)
+ IF (IDENT_INT (10) rem 1) /= 'G' OR
+ (5 Rem 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (E)
+
+ -------------------------------------------------
+
+ DECLARE -- (F)
+ FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < IDENT_INT (0) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END "NOT";
+
+ BEGIN -- (F)
+ IF (Not IDENT_INT(25) /= 'P') OR
+ (noT (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""NOT"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (F)
+
+ -------------------------------------------------
+
+ DECLARE -- (G)
+ FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < IDENT_INT (0) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END "ABS";
+
+ BEGIN -- (G)
+ IF (abs IDENT_INT(25) /= 'P') OR
+ (Abs (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""ABS"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (T)
+
+ -------------------------------------------------
+
+ RESULT;
+END C67002B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002c.ada b/gcc/testsuite/ada/acats/tests/c6/c67002c.ada
new file mode 100644
index 000000000..4a40231c7
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67002c.ada
@@ -0,0 +1,548 @@
+-- C67002C.ADA
+
+-- 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.
+--*
+-- CHECK THAT ALL OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
+-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
+-- THIS TEST CHECKS FORMAL SUBPROGRAM PARAMETERS.
+-- SUBTESTS ARE:
+-- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
+-- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
+-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
+-- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
+-- WITH ONE PARAMETER.
+
+-- CPP 6/26/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C67002C IS
+
+ FUNCTION TWO_PARAMS (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END TWO_PARAMS;
+
+ FUNCTION ONE_PARAM (I1 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < IDENT_INT(0) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END ONE_PARAM;
+
+BEGIN
+ TEST ("C67002C", "USE OF OPERATOR SYMBOLS IN " &
+ "(OVERLOADED) FUNCTION SPECIFICATIONS");
+
+ -------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE EQU IS
+ TYPE LP IS LIMITED PRIVATE;
+ FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
+ PRIVATE
+ TYPE LP IS NEW INTEGER;
+ END EQU;
+ USE EQU;
+
+ LP1, LP2 : LP;
+
+ PACKAGE BODY EQU IS
+ FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
+ BEGIN
+ RETURN LPA > LPB;
+ END "=";
+ BEGIN
+ LP1 := LP (IDENT_INT (7));
+ LP2 := LP (IDENT_INT (8));
+ END EQU;
+
+ GENERIC
+ WITH FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
+ (LP1 = LP1) OR (LP2 /= LP1) THEN
+ FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE EQUAL IS NEW PKG ("=" => EQU."=");
+
+ BEGIN -- (A)
+ NULL;
+ END; -- (A)
+
+ -------------------------------------------------
+
+ DECLARE -- (B)
+
+ GENERIC
+ WITH FUNCTION "AND" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) AND 1) /= 'G' OR
+ (5 AND 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("AND" => TWO_PARAMS);
+
+ BEGIN -- (B)
+ NULL;
+ END; -- (B)
+
+ -------------------------------------------------
+
+ DECLARE -- (C)
+
+ GENERIC
+ WITH FUNCTION "OR" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) OR 1) /= 'G' OR
+ (5 OR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("OR" => TWO_PARAMS);
+
+ BEGIN -- (C)
+ NULL;
+ END; -- (C)
+
+ -------------------------------------------------
+
+ DECLARE -- (D)
+
+ GENERIC
+ WITH FUNCTION "XOR" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) XOR 1) /= 'G' OR
+ (5 XOR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("XOR" => TWO_PARAMS);
+
+ BEGIN -- (D)
+ NULL;
+ END; -- (D)
+
+ -------------------------------------------------
+
+ DECLARE -- (E)
+
+ GENERIC
+ WITH FUNCTION "<" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) < 1) /= 'G' OR
+ (5 < 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("<" => TWO_PARAMS);
+
+ BEGIN -- (E)
+ NULL;
+ END; -- (E)
+
+ -------------------------------------------------
+
+ DECLARE -- (F)
+
+ GENERIC
+ WITH FUNCTION "<=" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) <= 1) /= 'G' OR
+ (5 <= 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("<=" => TWO_PARAMS);
+
+ BEGIN -- (F)
+ NULL;
+ END; -- (F)
+
+ -------------------------------------------------
+
+ DECLARE -- (G)
+
+ GENERIC
+ WITH FUNCTION ">" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) > 1) /= 'G' OR
+ (5 > 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG (">" => TWO_PARAMS);
+
+ BEGIN -- (G)
+ NULL;
+ END; -- (G)
+
+ -------------------------------------------------
+
+ DECLARE -- (H)
+
+ GENERIC
+ WITH FUNCTION ">=" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) >= 1) /= 'G' OR
+ (5 >= 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG (">=" => TWO_PARAMS);
+
+ BEGIN -- (H)
+ NULL;
+ END; -- (H)
+
+ -------------------------------------------------
+
+ DECLARE -- (I)
+
+ GENERIC
+ WITH FUNCTION "&" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) & 1) /= 'G' OR
+ (5 & 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("&" => TWO_PARAMS);
+
+ BEGIN -- (I)
+ NULL;
+ END; -- (I)
+
+ -------------------------------------------------
+
+ DECLARE -- (J)
+
+ GENERIC
+ WITH FUNCTION "*" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) * 1) /= 'G' OR
+ (5 * 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("*" => TWO_PARAMS);
+
+ BEGIN -- (J)
+ NULL;
+ END; -- (J)
+
+ -------------------------------------------------
+
+ DECLARE -- (K)
+
+ GENERIC
+ WITH FUNCTION "/" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) / 1) /= 'G' OR
+ (5 / 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("/" => TWO_PARAMS);
+
+ BEGIN -- (K)
+ NULL;
+ END; -- (K)
+
+ -------------------------------------------------
+
+ DECLARE -- (L)
+
+ GENERIC
+ WITH FUNCTION "MOD" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) MOD 1) /= 'G' OR
+ (5 MOD 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("MOD" => TWO_PARAMS);
+
+ BEGIN -- (L)
+ NULL;
+ END; -- (L)
+
+ -------------------------------------------------
+
+ DECLARE -- (M)
+
+ GENERIC
+ WITH FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) REM 1) /= 'G' OR
+ (5 REM 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("REM" => TWO_PARAMS);
+
+ BEGIN -- (M)
+ NULL;
+ END; -- (M)
+
+ -------------------------------------------------
+
+ DECLARE -- (N)
+
+ GENERIC
+ WITH FUNCTION "**" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) ** 1) /= 'G' OR
+ (5 ** 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("**" => TWO_PARAMS);
+
+ BEGIN -- (N)
+ NULL;
+ END; -- (N)
+
+ -------------------------------------------------
+
+ DECLARE -- (O)
+
+ GENERIC
+ WITH FUNCTION "+" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) + 1) /= 'G' OR
+ (5 + 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("+" => TWO_PARAMS);
+
+ BEGIN -- (O)
+ NULL;
+ END; -- (O)
+
+ -------------------------------------------------
+
+ DECLARE -- (P)
+
+ GENERIC
+ WITH FUNCTION "-" (I1, I2 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (IDENT_INT (10) - 1) /= 'G' OR
+ (5 - 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("-" => TWO_PARAMS);
+
+ BEGIN -- (P)
+ NULL;
+ END; -- (P)
+
+ -------------------------------------------------
+
+ DECLARE -- (Q)
+
+ GENERIC
+ WITH FUNCTION "+" (I1 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (+ IDENT_INT(25) /= 'P') OR
+ (+ (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""+"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("+" => ONE_PARAM);
+
+ BEGIN -- (Q)
+ NULL;
+ END; -- (Q)
+
+ -------------------------------------------------
+
+ DECLARE -- (R)
+
+ GENERIC
+ WITH FUNCTION "-" (I1 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (- IDENT_INT(25) /= 'P') OR
+ (- (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""-"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("-" => ONE_PARAM);
+
+ BEGIN -- (R)
+ NULL;
+ END; -- (R)
+
+ -------------------------------------------------
+
+ DECLARE -- (S)
+
+ GENERIC
+ WITH FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (NOT IDENT_INT(25) /= 'P') OR
+ (NOT (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""NOT"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("NOT" => ONE_PARAM);
+
+ BEGIN -- (S)
+ NULL;
+ END; -- (S)
+
+ -------------------------------------------------
+
+ DECLARE -- (T)
+
+ GENERIC
+ WITH FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER;
+ PACKAGE PKG IS
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ BEGIN
+ IF (ABS IDENT_INT(25) /= 'P') OR
+ (ABS (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""ABS"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END PKG;
+
+ PACKAGE PACK IS NEW PKG ("ABS" => ONE_PARAM);
+
+ BEGIN -- (T)
+ NULL;
+ END; -- (T)
+
+ -------------------------------------------------
+
+ RESULT;
+END C67002C;
+
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002d.ada b/gcc/testsuite/ada/acats/tests/c6/c67002d.ada
new file mode 100644
index 000000000..3d829802f
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67002d.ada
@@ -0,0 +1,354 @@
+-- C67002D.ADA
+
+-- 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.
+--*
+-- CHECK THAT ALL OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
+-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
+-- THIS TEST CHECKS GENERIC INSTANTIATIONS FOR THESE FUNCTIONS.
+-- SUBTESTS ARE:
+-- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
+-- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
+-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
+-- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
+-- WITH ONE PARAMETER.
+
+-- CPP 6/25/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C67002D IS
+
+ GENERIC
+ TYPE ELEMENT IS (<>);
+ FUNCTION TWO_PARAMS (I1, I2 : ELEMENT) RETURN CHARACTER;
+ FUNCTION TWO_PARAMS (I1, I2 : ELEMENT) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END TWO_PARAMS;
+
+ GENERIC
+ TYPE ELEMENT IS (<>);
+ FUNCTION ONE_PARAM (I1 : ELEMENT) RETURN CHARACTER;
+ FUNCTION ONE_PARAM (I1 : ELEMENT) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < ELEMENT'VAL(IDENT_INT(0)) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END ONE_PARAM;
+
+BEGIN
+ TEST ("C67002D", "USE OF OPERATOR SYMBOLS IN " &
+ "(OVERLOADED) FUNCTION SPECIFICATIONS");
+
+ -------------------------------------------------
+
+ DECLARE -- (A)
+ GENERIC
+ TYPE LP IS LIMITED PRIVATE;
+ WITH FUNCTION ">" (L, R : LP) RETURN BOOLEAN IS <>;
+ PACKAGE PKG IS
+ LP1, LP2 : LP;
+ FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
+ END PKG;
+
+ PACKAGE BODY PKG IS
+ FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
+ BEGIN
+ RETURN LPA > LPB;
+ END "=";
+ END PKG;
+
+ BEGIN -- (A)
+ DECLARE
+ PACKAGE PACK IS NEW PKG (LP => INTEGER);
+ USE PACK;
+ FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN
+ RENAMES PACK."=";
+ BEGIN
+ LP1 := IDENT_INT(7);
+ LP2 := IDENT_INT(8);
+ IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
+ (LP1 = LP1) OR (LP2 /= LP1) THEN
+ FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
+ END IF;
+ END;
+ END; -- (A)
+
+ -------------------------------------------------
+
+ DECLARE -- (B)
+ FUNCTION "AND" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (B)
+ IF (IDENT_INT (10) AND 1) /= 'G' OR
+ (5 AND 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (B)
+
+ -------------------------------------------------
+
+ DECLARE -- (C)
+ FUNCTION "OR" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (C)
+ IF (IDENT_INT (10) OR 1) /= 'G' OR
+ (5 OR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (C)
+
+ -------------------------------------------------
+
+ DECLARE -- (D)
+ FUNCTION "XOR" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (D)
+ IF (IDENT_INT (10) XOR 1) /= 'G' OR
+ (5 XOR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (D)
+
+ -------------------------------------------------
+
+ DECLARE -- (E)
+ FUNCTION "<" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (E)
+ IF (IDENT_INT (10) < 1) /= 'G' OR
+ (5 < 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (E)
+
+ -------------------------------------------------
+
+ DECLARE -- (F)
+ FUNCTION "<=" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (F)
+ IF (IDENT_INT (10) <= 1) /= 'G' OR
+ (5 <= 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (F)
+
+ -------------------------------------------------
+
+ DECLARE -- (G)
+ FUNCTION ">" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (G)
+ IF (IDENT_INT (10) > 1) /= 'G' OR
+ (5 > 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (G)
+
+ -------------------------------------------------
+
+ DECLARE -- (H)
+ FUNCTION ">=" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (H)
+ IF (IDENT_INT (10) >= 1) /= 'G' OR
+ (5 >= 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (H)
+
+ -------------------------------------------------
+
+ DECLARE -- (I)
+ FUNCTION "&" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (I)
+ IF (IDENT_INT (10) & 1) /= 'G' OR
+ (5 & 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (I)
+
+ -------------------------------------------------
+
+ DECLARE -- (J)
+ FUNCTION "*" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (J)
+ IF (IDENT_INT (10) * 1) /= 'G' OR
+ (5 * 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (J)
+
+ -------------------------------------------------
+
+ DECLARE -- (K)
+ FUNCTION "/" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (K)
+ IF (IDENT_INT (10) / 1) /= 'G' OR
+ (5 / 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (K)
+
+ -------------------------------------------------
+
+ DECLARE -- (L)
+ FUNCTION "MOD" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (L)
+ IF (IDENT_INT (10) MOD 1) /= 'G' OR
+ (5 MOD 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (L)
+
+ -------------------------------------------------
+
+ DECLARE -- (M)
+ FUNCTION "REM" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (M)
+ IF (IDENT_INT (10) REM 1) /= 'G' OR
+ (5 REM 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (M)
+
+ -------------------------------------------------
+
+ DECLARE -- (N)
+ FUNCTION "**" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (N)
+ IF (IDENT_INT (10) ** 1) /= 'G' OR
+ (5 ** 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (N)
+
+ -------------------------------------------------
+
+ DECLARE -- (O)
+ FUNCTION "+" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (O)
+ IF (IDENT_INT (10) + 1) /= 'G' OR
+ (5 + 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (O)
+
+ -------------------------------------------------
+
+ DECLARE -- (P)
+ FUNCTION "-" IS NEW TWO_PARAMS
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (P)
+ IF (IDENT_INT (10) - 1) /= 'G' OR
+ (5 - 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (P)
+
+ -------------------------------------------------
+
+ DECLARE -- (Q)
+ FUNCTION "+" IS NEW ONE_PARAM
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (Q)
+ IF (+ IDENT_INT(25) /= 'P') OR
+ (+ (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""+"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (Q)
+
+ -------------------------------------------------
+
+ DECLARE -- (R)
+ FUNCTION "-" IS NEW ONE_PARAM
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (R)
+ IF (- IDENT_INT(25) /= 'P') OR
+ (- (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""-"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (R)
+
+ -------------------------------------------------
+
+ DECLARE -- (S)
+ FUNCTION "NOT" IS NEW ONE_PARAM
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (S)
+ IF (NOT IDENT_INT(25) /= 'P') OR
+ (NOT (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""NOT"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (S)
+
+ -------------------------------------------------
+
+ DECLARE -- (T)
+ FUNCTION "ABS" IS NEW ONE_PARAM
+ (ELEMENT => INTEGER);
+
+ BEGIN -- (T)
+ IF (ABS IDENT_INT(25) /= 'P') OR
+ (ABS (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""ABS"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (T)
+
+ -------------------------------------------------
+
+ RESULT;
+END C67002D;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67002e.ada b/gcc/testsuite/ada/acats/tests/c6/c67002e.ada
new file mode 100644
index 000000000..aa3695239
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67002e.ada
@@ -0,0 +1,348 @@
+-- C67002E.ADA
+
+-- 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.
+--*
+-- CHECK THAT ALL OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED)
+-- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS.
+-- THIS TEST CHECKS RENAMING DECLARATIONS FOR THESE FUNCTIONS.
+-- SUBTESTS ARE:
+-- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=",
+-- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-",
+-- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS.
+-- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY,
+-- WITH ONE PARAMETER.
+
+-- CPP 6/26/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C67002E IS
+
+ FUNCTION TWO_PARAMS (I1, I2 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 > I2 THEN
+ RETURN 'G';
+ ELSE RETURN 'L';
+ END IF;
+ END TWO_PARAMS;
+
+ FUNCTION ONE_PARAM (I1 : INTEGER) RETURN CHARACTER IS
+ BEGIN
+ IF I1 < IDENT_INT(0) THEN
+ RETURN 'N';
+ ELSE RETURN 'P';
+ END IF;
+ END ONE_PARAM;
+
+BEGIN
+ TEST ("C67002E", "USE OF OPERATOR SYMBOLS IN " &
+ "(OVERLOADED) FUNCTION SPECIFICATIONS");
+
+ -------------------------------------------------
+
+ DECLARE -- (A)
+
+ PACKAGE PKG IS
+ TYPE LP IS LIMITED PRIVATE;
+ FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN;
+ PRIVATE
+ TYPE LP IS NEW INTEGER;
+ END PKG;
+ USE PKG;
+
+ LP1, LP2 : LP;
+
+ FUNCTION "=" (LPA, LPB : LP)
+ RETURN BOOLEAN RENAMES PKG."=";
+
+ PACKAGE BODY PKG IS
+ FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS
+ BEGIN
+ RETURN LPA > LPB;
+ END "=";
+ BEGIN
+ LP1 := LP (IDENT_INT (7));
+ LP2 := LP (IDENT_INT (8));
+ END PKG;
+
+ BEGIN -- (A)
+ IF (LP1 = LP2) OR NOT (LP2 = LP1) OR
+ (LP1 = LP1) OR (LP2 /= LP1) THEN
+ FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (A)
+
+ -------------------------------------------------
+
+ DECLARE -- (B)
+ FUNCTION "AND" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (B)
+ IF (IDENT_INT (10) AND 1) /= 'G' OR
+ (5 AND 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (B)
+
+ -------------------------------------------------
+
+ DECLARE -- (C)
+ FUNCTION "OR" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (C)
+ IF (IDENT_INT (10) OR 1) /= 'G' OR
+ (5 OR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (C)
+
+ -------------------------------------------------
+
+ DECLARE -- (D)
+ FUNCTION "XOR" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (D)
+ IF (IDENT_INT (10) XOR 1) /= 'G' OR
+ (5 XOR 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (D)
+
+ -------------------------------------------------
+
+ DECLARE -- (E)
+ FUNCTION "<" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (E)
+ IF (IDENT_INT (10) < 1) /= 'G' OR
+ (5 < 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (E)
+
+ -------------------------------------------------
+
+ DECLARE -- (F)
+ FUNCTION "<=" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (F)
+ IF (IDENT_INT (10) <= 1) /= 'G' OR
+ (5 <= 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (F)
+
+ -------------------------------------------------
+
+ DECLARE -- (G)
+ FUNCTION ">" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (G)
+ IF (IDENT_INT (10) > 1) /= 'G' OR
+ (5 > 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (G)
+
+ -------------------------------------------------
+
+ DECLARE -- (H)
+ FUNCTION ">=" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (H)
+ IF (IDENT_INT (10) >= 1) /= 'G' OR
+ (5 >= 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (H)
+
+ -------------------------------------------------
+
+ DECLARE -- (I)
+ FUNCTION "&" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (I)
+ IF (IDENT_INT (10) & 1) /= 'G' OR
+ (5 & 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (I)
+
+ -------------------------------------------------
+
+ DECLARE -- (J)
+ FUNCTION "*" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (J)
+ IF (IDENT_INT (10) * 1) /= 'G' OR
+ (5 * 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (J)
+
+ -------------------------------------------------
+
+ DECLARE -- (K)
+ FUNCTION "/" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (K)
+ IF (IDENT_INT (10) / 1) /= 'G' OR
+ (5 / 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (K)
+
+ -------------------------------------------------
+
+ DECLARE -- (L)
+ FUNCTION "MOD" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (L)
+ IF (IDENT_INT (10) MOD 1) /= 'G' OR
+ (5 MOD 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (L)
+
+ -------------------------------------------------
+
+ DECLARE -- (M)
+ FUNCTION "REM" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (M)
+ IF (IDENT_INT (10) REM 1) /= 'G' OR
+ (5 REM 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (M)
+
+ -------------------------------------------------
+
+ DECLARE -- (N)
+ FUNCTION "**" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (N)
+ IF (IDENT_INT (10) ** 1) /= 'G' OR
+ (5 ** 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (N)
+
+ -------------------------------------------------
+
+ DECLARE -- (O)
+ FUNCTION "+" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (O)
+ IF (IDENT_INT (10) + 1) /= 'G' OR
+ (5 + 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (O)
+
+ -------------------------------------------------
+
+ DECLARE -- (P)
+ FUNCTION "-" (I1, I2 : INTEGER)
+ RETURN CHARACTER RENAMES TWO_PARAMS;
+
+ BEGIN -- (P)
+ IF (IDENT_INT (10) - 1) /= 'G' OR
+ (5 - 10) /= 'L' THEN
+ FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE");
+ END IF;
+ END; -- (P)
+
+ -------------------------------------------------
+
+ DECLARE -- (Q)
+ FUNCTION "+" (I1 : INTEGER)
+ RETURN CHARACTER RENAMES ONE_PARAM;
+
+ BEGIN -- (Q)
+ IF (+ IDENT_INT(25) /= 'P') OR
+ (+ (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""+"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (Q)
+
+ -------------------------------------------------
+
+ DECLARE -- (R)
+ FUNCTION "-" (I1 : INTEGER)
+ RETURN CHARACTER RENAMES ONE_PARAM;
+
+ BEGIN -- (R)
+ IF (- IDENT_INT(25) /= 'P') OR
+ (- (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""-"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (R)
+
+ -------------------------------------------------
+
+ DECLARE -- (S)
+ FUNCTION "NOT" (I1 : INTEGER)
+ RETURN CHARACTER RENAMES ONE_PARAM;
+
+ BEGIN -- (S)
+ IF (NOT IDENT_INT(25) /= 'P') OR
+ (NOT (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""NOT"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (S)
+
+ -------------------------------------------------
+
+ DECLARE -- (T)
+ FUNCTION "ABS" (I1 : INTEGER)
+ RETURN CHARACTER RENAMES ONE_PARAM;
+
+ BEGIN -- (T)
+ IF (ABS IDENT_INT(25) /= 'P') OR
+ (ABS (0-25) /= 'N') THEN
+ FAILED ("OVERLOADING OF ""ABS"" " &
+ "OPERATOR (ONE OPERAND) DEFECTIVE");
+ END IF;
+ END; -- (T)
+
+ -------------------------------------------------
+
+ RESULT;
+END C67002E;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67003f.ada b/gcc/testsuite/ada/acats/tests/c6/c67003f.ada
new file mode 100644
index 000000000..fde865c08
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67003f.ada
@@ -0,0 +1,319 @@
+-- C67003F.ADA
+
+-- 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.
+--*
+-- CHECK THAT THE PREDEFINED OPERATORS FOR THE PREDEFINED TYPES CAN BE
+-- REDEFINED.
+-- CHECK THAT THE REDEFINED OPERATOR IS INVOKED WHEN INFIX OR PREFIX
+-- NOTATION IS USED.
+
+-- HISTORY:
+-- WMC 03/21/92 TEST CREATED FROM CONSOLIDATION OF C67003[A-E].ADA
+
+
+WITH REPORT;
+
+PROCEDURE C67003F IS
+
+ USE REPORT;
+
+BEGIN
+
+ TEST ("C67003F", "CHECK THAT REDEFINITION OF " &
+ "OPERATORS FOR PREDEFINED TYPES WORKS");
+
+ DECLARE -- INTEGER OPERATORS.
+
+ -- INTEGER INFIX OPERATORS.
+
+ FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER IS
+ BEGIN
+ IF X /= Y THEN
+ RETURN 1;
+ ELSE RETURN 0;
+ END IF;
+ END "*";
+
+ FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER IS
+ BEGIN
+ IF X /= Y THEN
+ RETURN 2;
+ ELSE RETURN 0;
+ END IF;
+ END "+";
+
+ FUNCTION "REM" (X, Y : INTEGER) RETURN INTEGER IS
+ BEGIN
+ IF X /= Y THEN
+ RETURN 3;
+ ELSE RETURN 0;
+ END IF;
+ END "REM";
+
+ -- INTEGER PREFIX OPERATORS.
+
+ FUNCTION "+" (X : INTEGER) RETURN INTEGER IS
+ BEGIN
+ IF X /= 0 THEN
+ RETURN 4;
+ ELSE RETURN 0;
+ END IF;
+ END "+";
+
+ FUNCTION "ABS" (X : INTEGER) RETURN INTEGER IS
+ BEGIN
+ IF X /= 0 THEN
+ RETURN 5;
+ ELSE RETURN 0;
+ END IF;
+ END "ABS";
+
+ -- INTEGER RELATIONAL OPERATOR.
+
+ FUNCTION "<" (X, Y : INTEGER) RETURN BOOLEAN IS
+ BEGIN
+ RETURN X = Y;
+ END "<";
+
+ BEGIN
+
+ IF IDENT_INT (3) * IDENT_INT (5) /= 1 THEN
+ FAILED ("REDEFINITION OF INTEGER ""*"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_INT (1) + IDENT_INT (30) /= 2 THEN
+ FAILED ("REDEFINITION OF INTEGER ""+"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_INT (7) REM IDENT_INT (8) /= 3 THEN
+ FAILED ("REDEFINITION OF ""REM"" IS DEFECTIVE");
+ END IF;
+
+ IF + (IDENT_INT (10)) /= 4 THEN
+ FAILED ("REDEFINITION OF INTEGER UNARY ""+"" IS DEFECTIVE");
+ END IF;
+
+ IF ABS (IDENT_INT (2)) /= 5 THEN
+ FAILED ("REDEFINITION OF INTEGER ""ABS"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_INT (7) < IDENT_INT (8) THEN
+ FAILED ("REDEFINITION OF INTEGER ""<"" IS DEFECTIVE");
+ END IF;
+
+ END;
+
+ DECLARE -- FLOAT OPERATORS.
+
+ -- NOTE THAT ALL LITERAL VALUES USED SHOULD BE
+ -- REPRESENTABLE EXACTLY.
+
+ FUNCTION IDENT_FLOAT (X : FLOAT) RETURN FLOAT IS
+ I : INTEGER := INTEGER (X);
+ BEGIN
+ IF EQUAL (I, I) THEN -- ALWAYS EQUAL.
+ RETURN X;
+ END IF;
+ RETURN 0.0;
+ END IDENT_FLOAT;
+
+ -- FLOAT INFIX OPERATORS.
+
+ FUNCTION "-" (X, Y : FLOAT) RETURN FLOAT IS
+ BEGIN
+ IF X /= Y THEN
+ RETURN 1.0;
+ ELSE RETURN 0.0;
+ END IF;
+ END "-";
+
+ FUNCTION "/" (X, Y : FLOAT) RETURN FLOAT IS
+ BEGIN
+ IF X /= Y THEN
+ RETURN 2.0;
+ ELSE RETURN 0.0;
+ END IF;
+ END "/";
+
+ FUNCTION "**" (X : FLOAT; Y : INTEGER) RETURN FLOAT IS
+ BEGIN
+ IF INTEGER (X) /= Y THEN
+ RETURN 3.0;
+ ELSE RETURN 0.0;
+ END IF;
+ END "**";
+
+ -- FLOAT PREFIX OPERATOR.
+
+ FUNCTION "-" (X : FLOAT) RETURN FLOAT IS
+ BEGIN
+ IF X /= 0.0 THEN
+ RETURN 4.0;
+ ELSE RETURN 0.0;
+ END IF;
+ END "-";
+
+ -- FLOAT RELATIONAL OPERATOR.
+
+ FUNCTION "<=" (X, Y : FLOAT) RETURN BOOLEAN IS
+ BEGIN
+ RETURN X = Y;
+ END "<=";
+
+ BEGIN
+
+ IF IDENT_FLOAT (50.0) - IDENT_FLOAT (100.0) /= 1.0 THEN
+ FAILED ("REDEFINITION OF FLOAT ""-"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_FLOAT (5.0) / IDENT_FLOAT (1.0) /= 2.0 THEN
+ FAILED ("REDEFINITION OF FLOAT ""/"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_FLOAT (3.0) ** IDENT_INT (2) /= 3.0 THEN
+ FAILED ("REDEFINITION OF FLOAT ""**"" IS DEFECTIVE");
+ END IF;
+
+ IF -(IDENT_FLOAT (5.0)) /= 4.0 THEN
+ FAILED ("REDEFINITION OF FLOAT UNARY ""-"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_FLOAT (1.0) <= IDENT_FLOAT (5.0) THEN
+ FAILED ("REDEFINITION OF FLOAT ""<="" IS DEFECTIVE");
+ END IF;
+
+ END;
+
+ DECLARE -- BOOLEAN OPERATORS.
+
+ -- BOOLEAN LOGICAL OPERATORS.
+
+ FUNCTION "AND" (X, Y : BOOLEAN) RETURN BOOLEAN IS
+ BEGIN
+ IF X AND THEN Y THEN
+ RETURN FALSE;
+ ELSE RETURN TRUE;
+ END IF;
+ END "AND";
+
+ FUNCTION "XOR" (X, Y : BOOLEAN) RETURN BOOLEAN IS
+ BEGIN
+ RETURN X = Y;
+ END "XOR";
+
+ -- BOOLEAN RELATIONAL OPERATOR.
+
+ FUNCTION ">" (X, Y : BOOLEAN) RETURN BOOLEAN IS
+ BEGIN
+ RETURN X = Y;
+ END ">";
+
+ BEGIN
+
+ IF IDENT_BOOL (TRUE) AND IDENT_BOOL (TRUE) THEN
+ FAILED ("REDEFINITION OF ""AND"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_BOOL (TRUE) XOR IDENT_BOOL (FALSE) THEN
+ FAILED ("REDEFINITION OF ""XOR"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_BOOL (TRUE) > IDENT_BOOL (FALSE) THEN
+ FAILED ("REDEFINITION OF BOOLEAN "">"" IS DEFECTIVE");
+ END IF;
+
+ END;
+
+ DECLARE -- STRING OPERATORS.
+
+ S1 : STRING (1..2) := "A" & IDENT_CHAR ('B');
+ S2 : STRING (1..2) := "C" & IDENT_CHAR ('D');
+
+ FUNCTION "&" (X, Y : STRING) RETURN STRING IS
+ Z : STRING (1 .. X'LENGTH + Y'LENGTH);
+ BEGIN
+ Z (1 .. Y'LENGTH) := Y;
+ Z (Y'LENGTH + 1 .. Z'LAST) := X;
+ RETURN Z;
+ END "&";
+
+ FUNCTION "&" (X : CHARACTER; Y : STRING) RETURN STRING IS
+ Z : STRING (1 .. Y'LENGTH + 1);
+ BEGIN
+ Z (1 .. Y'LENGTH) := Y;
+ Z (Z'LAST) := X;
+ RETURN Z;
+ END "&";
+
+ -- STRING RELATIONAL OPERATOR.
+
+ FUNCTION ">=" (X, Y : STRING) RETURN BOOLEAN IS
+ BEGIN
+ RETURN X = Y;
+ END ">=";
+
+ BEGIN
+
+ IF S1 & S2 /= "CDAB" THEN
+ FAILED ("BAD REDEFINITION OF ""&"" (S,S)");
+ END IF;
+
+ IF IDENT_CHAR ('C') & S1 /= "ABC" THEN
+ FAILED ("BAD REDEFINITION OF ""&"" (C,S)");
+ END IF;
+
+ IF S2 >= S1 THEN
+ FAILED ("BAD REDEFINITION OF STRING "">=""");
+ END IF;
+
+ END;
+
+ DECLARE -- CHARACTER OPERATORS.
+
+ -- CHARACTER RELATIONAL OPERATORS.
+
+ FUNCTION ">" (X, Y : CHARACTER) RETURN BOOLEAN IS
+ BEGIN
+ RETURN X = Y;
+ END ">";
+
+ FUNCTION "<=" (X, Y : CHARACTER) RETURN BOOLEAN IS
+ BEGIN
+ RETURN X = Y;
+ END "<=";
+
+ BEGIN
+
+ IF IDENT_CHAR ('C') > IDENT_CHAR ('B') THEN
+ FAILED ("REDEFINITION OF CHARACTER "">"" IS DEFECTIVE");
+ END IF;
+
+ IF IDENT_CHAR ('A') <= IDENT_CHAR ('E') THEN
+ FAILED ("REDEFINITION OF CHARACTER ""<="" IS DEFECTIVE");
+ END IF;
+
+ END;
+
+ RESULT;
+
+END C67003F;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67005a.ada b/gcc/testsuite/ada/acats/tests/c6/c67005a.ada
new file mode 100644
index 000000000..e83d8d1d0
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67005a.ada
@@ -0,0 +1,96 @@
+-- C67005A.ADA
+
+-- 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.
+--*
+-- CHECK IF A RENAMING DECLARATION DECLARES AN EQUALITY OPERATOR, THE
+-- TYPES OF THE PARAMETERS NEED NOT BE LIMITED TYPES.
+
+-- JBG 9/28/83
+
+WITH REPORT; USE REPORT;
+PROCEDURE C67005A IS
+BEGIN
+ TEST ("C67005A", "CHECK THAT AN EQUALITY OPERATOR DECLARED BY " &
+ "A RENAMING DECLARATION NEED NOT HAVE " &
+ "PARAMETERS OF A LIMITED TYPE");
+ DECLARE
+ GENERIC
+ TYPE LP IS LIMITED PRIVATE;
+ WITH FUNCTION EQUAL (L, R : LP) RETURN BOOLEAN;
+ PACKAGE EQUALITY_OPERATOR IS
+ FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
+ END EQUALITY_OPERATOR;
+
+ PACKAGE BODY EQUALITY_OPERATOR IS
+ FUNCTION "=" (L, R : LP) RETURN BOOLEAN IS
+ BEGIN
+ RETURN EQUAL(L, R);
+ END "=";
+ END EQUALITY_OPERATOR;
+
+ PACKAGE POLAR_COORDINATES IS
+ TYPE POLAR_COORD IS
+ RECORD
+ R : INTEGER;
+ THETA : INTEGER;
+ END RECORD;
+ FUNCTION EQUAL (L, R : POLAR_COORD) RETURN BOOLEAN;
+ PACKAGE POLAR_EQUAL IS NEW EQUALITY_OPERATOR
+ (POLAR_COORD, EQUAL);
+ FUNCTION "=" (L, R : POLAR_COORD) RETURN BOOLEAN
+ RENAMES POLAR_EQUAL."=";
+ END POLAR_COORDINATES;
+
+ PACKAGE BODY POLAR_COORDINATES IS
+ FUNCTION EQUAL (L, R : POLAR_COORD) RETURN BOOLEAN IS
+ BEGIN
+ RETURN (L.THETA MOD 360) = (R.THETA MOD 360) AND
+ L.R = R.R;
+ END EQUAL;
+ END POLAR_COORDINATES;
+
+ USE POLAR_COORDINATES;
+
+ PACKAGE VARIABLES IS
+ P270 : POLAR_COORD := (R => 3, THETA => 270);
+ P360 : POLAR_COORD := (R => 3, THETA => IDENT_INT(360));
+ END VARIABLES;
+
+ USE VARIABLES;
+
+ BEGIN
+
+ IF P270 /= (3, -90) THEN
+ FAILED ("INCORRECT INEQUALITY OPERATOR");
+ END IF;
+
+ IF P360 = (3, 0) THEN
+ NULL;
+ ELSE
+ FAILED ("INCORRECT EQUALITY OPERATOR");
+ END IF;
+
+ RESULT;
+
+ END;
+END C67005A;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67005b.ada b/gcc/testsuite/ada/acats/tests/c6/c67005b.ada
new file mode 100644
index 000000000..27579605d
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67005b.ada
@@ -0,0 +1,124 @@
+-- C67005B.ADA
+
+-- 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.
+--*
+-- CHECK THAT IF EQUALITY IS REDEFINED FOR A SCALAR TYPE, CASE
+-- STATEMENTS STILL USE THE PREDEFINED EQUALITY OPERATION.
+
+-- JBG 9/28/83
+
+WITH REPORT; USE REPORT;
+PROCEDURE C67005B IS
+
+ GENERIC
+ TYPE LP IS LIMITED PRIVATE;
+ WITH FUNCTION EQUAL (L, R : LP) RETURN BOOLEAN;
+ PACKAGE EQUALITY_OPERATOR IS
+ FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
+ END EQUALITY_OPERATOR;
+
+ PACKAGE BODY EQUALITY_OPERATOR IS
+ FUNCTION "=" (L, R : LP) RETURN BOOLEAN IS
+ BEGIN
+ RETURN EQUAL(L, R);
+ END "=";
+ END EQUALITY_OPERATOR;
+
+BEGIN
+ TEST ("C67005B", "CHECK THAT REDEFINING EQUALITY FOR A " &
+ "SCALAR TYPE DOES NOT AFFECT CASE STATEMENTS");
+
+ DECLARE
+ TYPE MY IS NEW INTEGER;
+ CHECK : MY;
+
+ VAR : INTEGER RANGE 1..3 := 3;
+
+ PACKAGE INTEGER_EQUALS IS
+ FUNCTION EQUAL (L, R : INTEGER) RETURN BOOLEAN;
+ PACKAGE INTEGER_EQUAL IS NEW EQUALITY_OPERATOR
+ (INTEGER, EQUAL);
+ END INTEGER_EQUALS;
+
+ FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN RENAMES
+ INTEGER_EQUALS.INTEGER_EQUAL."=";
+
+ PACKAGE BODY INTEGER_EQUALS IS
+ FUNCTION EQUAL (L, R : INTEGER) RETURN BOOLEAN IS
+ BEGIN
+ RETURN FALSE;
+ END EQUAL;
+ END INTEGER_EQUALS;
+
+ BEGIN
+
+ IF VAR = 3 THEN
+ FAILED ("DID NOT USE REDEFINED '=' - 1");
+ END IF;
+
+ IF VAR /= 3 THEN
+ NULL;
+ ELSE
+ FAILED ("DID NOT USE REDEFINED '/=' - 1");
+ END IF;
+
+ IF VAR = IDENT_INT(3) THEN
+ FAILED ("DID NOT USE REDEFINED '=' - 2");
+ END IF;
+
+ IF VAR /= IDENT_INT(3) THEN
+ NULL;
+ ELSE
+ FAILED ("DID NOT USE REDEFINED '/=' - 2");
+ END IF;
+
+ CHECK := MY(IDENT_INT(0));
+ IF CHECK /= 0 THEN
+ FAILED ("USING WRONG EQUALITY FOR DERIVED TYPE");
+ END IF;
+
+ CASE VAR IS
+ WHEN 1..3 => CHECK := MY(IDENT_INT(1));
+ WHEN OTHERS => NULL;
+ END CASE;
+
+ IF CHECK /= 1 THEN
+ FAILED ("DID NOT USE PREDEFINED EQUALS IN CASE - 1");
+ END IF;
+
+ CASE IDENT_INT(VAR) IS
+ WHEN 1 => CHECK := 4;
+ WHEN 2 => CHECK := 5;
+ WHEN 3 => CHECK := 6;
+ WHEN OTHERS => CHECK := 7;
+ END CASE;
+
+ IF CHECK /= 6 THEN
+ FAILED ("DID NOT USE PREDEFINED EQUALS IN CASE - 2");
+ END IF;
+
+ END;
+
+ RESULT;
+
+END C67005B;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67005c.ada b/gcc/testsuite/ada/acats/tests/c6/c67005c.ada
new file mode 100644
index 000000000..b52c40d64
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67005c.ada
@@ -0,0 +1,109 @@
+-- C67005C.ADA
+
+-- 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.
+--*
+-- CHECK THAT A DECLARATION OF "=" NEED NOT HAVE PARAMETERS
+-- OF A LIMITED TYPE IN A RENAMING DECLARATION. THIS TEST CHECKS
+-- ACCESS TYPES.
+
+-- BRYCE BARDIN (HUGHES AIRCRAFT) 7/2/84
+-- CPP 7/12/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C67005C IS
+
+ GENERIC
+ TYPE T IS LIMITED PRIVATE;
+ WITH FUNCTION EQUAL (LEFT, RIGHT : T) RETURN BOOLEAN IS <>;
+ PACKAGE EQUALITY IS
+ FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN;
+ -- PRAGMA INLINE ("=");
+ END EQUALITY;
+
+ PACKAGE BODY EQUALITY IS
+ FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN IS
+ BEGIN
+ RETURN EQUAL (LEFT, RIGHT);
+ END "=";
+ END EQUALITY;
+
+ PACKAGE STARTER IS
+ TYPE INT IS PRIVATE;
+ FUNCTION VALUE_OF (I : INTEGER) RETURN INT;
+ FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN;
+ PRIVATE
+ TYPE INT IS ACCESS INTEGER;
+ END STARTER;
+
+ PACKAGE BODY STARTER IS
+ FUNCTION VALUE_OF (I : INTEGER) RETURN INT IS
+ BEGIN
+ RETURN NEW INTEGER'(I);
+ END VALUE_OF;
+
+ FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN IS
+ BEGIN
+ RETURN LEFT.ALL = RIGHT.ALL;
+ END EQUAL;
+ END STARTER;
+
+ PACKAGE ABSTRACTION IS
+ TYPE INT IS NEW STARTER.INT;
+ PACKAGE INT_EQUALITY IS NEW EQUALITY (INT, EQUAL);
+ FUNCTION "=" (LEFT, RIGHT : INT) RETURN BOOLEAN
+ RENAMES INT_EQUALITY."=";
+ END ABSTRACTION;
+ USE ABSTRACTION;
+
+BEGIN
+
+ TEST ("C67005C", "RENAMING OF EQUALITY OPERATOR WITH " &
+ "NON-LIMITED PARAMETERS");
+
+ DECLARE
+
+ I : INT := VALUE_OF(1);
+ J : INT := VALUE_OF(0);
+
+ PROCEDURE CHECK (B : BOOLEAN) IS
+ BEGIN
+ IF I = J AND B THEN
+ COMMENT ("I = J");
+ ELSIF I /= J AND NOT B THEN
+ COMMENT ("I /= J");
+ ELSE
+ FAILED ("WRONG ""="" OPERATOR");
+ END IF;
+ END CHECK;
+
+ BEGIN
+
+ CHECK(FALSE);
+ I := VALUE_OF(0);
+ CHECK(TRUE);
+
+ RESULT;
+
+ END;
+
+END C67005C;
diff --git a/gcc/testsuite/ada/acats/tests/c6/c67005d.ada b/gcc/testsuite/ada/acats/tests/c6/c67005d.ada
new file mode 100644
index 000000000..95eafe243
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c6/c67005d.ada
@@ -0,0 +1,78 @@
+-- C67005D.ADA
+
+-- 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.
+--*
+-- CHECK THAT EQUALITY CAN BE REDEFINED FOR AN ARBITRARY TYPE BY USING A
+-- SEQUENCE OF RENAMING DECLARATIONS.
+
+-- JBG 9/11/84
+
+WITH REPORT; USE REPORT;
+PROCEDURE C67005D IS
+
+ FUNCTION MY_EQUALS (L, R : INTEGER) RETURN BOOLEAN IS
+ BEGIN
+ RETURN FALSE;
+ END MY_EQUALS;
+
+ GENERIC
+ TYPE LP IS LIMITED PRIVATE;
+ WITH FUNCTION "=" (L, R : LP) RETURN BOOLEAN;
+ PACKAGE EQUALITY_OPERATOR IS
+ PACKAGE INNER IS
+ FUNCTION "=" (L, R : LP) RETURN BOOLEAN RENAMES
+ EQUALITY_OPERATOR."=";
+ END INNER;
+ END EQUALITY_OPERATOR;
+
+BEGIN
+ TEST ("C67005D", "CHECK REDEFINITION OF ""="" BY RENAMING");
+
+ DECLARE
+
+ CHK1 : BOOLEAN := 3 = IDENT_INT(3); -- PREDEFINED "="
+
+ -- REDEFINE INTEGER "=".
+
+ PACKAGE INT_EQUALITY IS NEW
+ EQUALITY_OPERATOR (INTEGER, MY_EQUALS);
+ FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN RENAMES
+ INT_EQUALITY.INNER."=";
+
+ CHK2 : BOOLEAN := 3 = IDENT_INT(3); -- REDEFINED "=".
+
+ BEGIN
+
+ IF NOT CHK1 THEN
+ FAILED ("PREDEFINED ""="" NOT USED");
+ END IF;
+
+ IF CHK2 THEN
+ FAILED ("REDEFINED ""="" NOT USED");
+ END IF;
+
+ END;
+
+ RESULT;
+
+END C67005D;