diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c6')
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; |